From 08db4c81ffac672a4a5a90291be70279e9a1f098 Mon Sep 17 00:00:00 2001 From: Mateusz Kowalczyk Date: Mon, 28 Jul 2014 14:31:03 +0200 Subject: Fix #313 by doing some list munging. I get rid of the Monoid instance because we weren't satisfying the laws. Convenience of having <> didn't outweigh the shock-factor of having it behave badly. --- haddock-library/src/Documentation/Haddock/Doc.hs | 12 +- .../src/Documentation/Haddock/Parser.hs | 26 ++-- .../test/Documentation/Haddock/ParserSpec.hs | 20 +++- html-test/ref/Bug313.html | 132 +++++++++++++++++++++ html-test/src/Bug313.hs | 37 ++++++ src/Haddock/Doc.hs | 3 +- src/Haddock/Interface/Create.hs | 7 +- src/Haddock/Interface/LexParseRn.hs | 4 +- 8 files changed, 214 insertions(+), 27 deletions(-) create mode 100644 html-test/ref/Bug313.html create mode 100644 html-test/src/Bug313.hs diff --git a/haddock-library/src/Documentation/Haddock/Doc.hs b/haddock-library/src/Documentation/Haddock/Doc.hs index 4d6c10a4..1c20555d 100644 --- a/haddock-library/src/Documentation/Haddock/Doc.hs +++ b/haddock-library/src/Documentation/Haddock/Doc.hs @@ -1,21 +1,19 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Documentation.Haddock.Doc (docParagraph) where +module Documentation.Haddock.Doc (docParagraph, docAppend, docConcat) where -import Data.Monoid import Documentation.Haddock.Types import Data.Char (isSpace) --- We put it here so that we can avoid a circular import --- anything relevant imports this module anyway -instance Monoid (DocH mod id) where - mempty = DocEmpty - mappend = docAppend +docConcat :: [DocH mod id] -> DocH mod id +docConcat = foldr docAppend DocEmpty docAppend :: DocH mod id -> DocH mod id -> DocH mod id docAppend (DocDefList ds1) (DocDefList ds2) = DocDefList (ds1++ds2) docAppend (DocDefList ds1) (DocAppend (DocDefList ds2) d) = DocAppend (DocDefList (ds1++ds2)) d docAppend (DocOrderedList ds1) (DocOrderedList ds2) = DocOrderedList (ds1 ++ ds2) +docAppend (DocOrderedList ds1) (DocAppend (DocOrderedList ds2) d) = DocAppend (DocOrderedList (ds1++ds2)) d docAppend (DocUnorderedList ds1) (DocUnorderedList ds2) = DocUnorderedList (ds1 ++ ds2) +docAppend (DocUnorderedList ds1) (DocAppend (DocUnorderedList ds2) d) = DocAppend (DocUnorderedList (ds1++ds2)) d docAppend DocEmpty d = d docAppend d DocEmpty = d docAppend (DocString s1) (DocString s2) = DocString (s1 ++ s2) diff --git a/haddock-library/src/Documentation/Haddock/Parser.hs b/haddock-library/src/Documentation/Haddock/Parser.hs index 68d9ecec..ab3f3625 100644 --- a/haddock-library/src/Documentation/Haddock/Parser.hs +++ b/haddock-library/src/Documentation/Haddock/Parser.hs @@ -93,7 +93,7 @@ parseParas :: String -- ^ String to parse parseParas = parse (p <* skipSpace) . encodeUtf8 . (++ "\n") where p :: Parser (DocH mod Identifier) - p = mconcat <$> paragraph `sepBy` many (skipHorizontalSpace *> "\n") + p = docConcat <$> paragraph `sepBy` many (skipHorizontalSpace *> "\n") -- | Parse a text paragraph. Actually just a wrapper over 'parseStringBS' which -- drops leading whitespace and encodes the string to UTF8 first. @@ -104,10 +104,10 @@ parseStringBS :: BS.ByteString -> DocH mod Identifier parseStringBS = parse p where p :: Parser (DocH mod Identifier) - p = mconcat <$> many (monospace <|> anchor <|> identifier <|> moduleName - <|> picture <|> hyperlink <|> bold - <|> emphasis <|> encodedChar <|> string' - <|> skipSpecialChar) + p = docConcat <$> many (monospace <|> anchor <|> identifier <|> moduleName + <|> picture <|> hyperlink <|> bold + <|> emphasis <|> encodedChar <|> string' + <|> skipSpecialChar) -- | Parses and processes -- @@ -231,8 +231,8 @@ header = do pser = foldl1 (<|>) psers delim <- decodeUtf8 <$> pser line <- skipHorizontalSpace *> nonEmptyLine >>= return . parseString - rest <- paragraph <|> return mempty - return $ DocHeader (Header (length delim) line) <> rest + rest <- paragraph <|> return DocEmpty + return $ DocHeader (Header (length delim) line) `docAppend` rest textParagraph :: Parser (DocH mod Identifier) textParagraph = docParagraph . parseString . intercalate "\n" <$> many1 nonEmptyLine @@ -265,7 +265,7 @@ innerList item = do (cs, items) <- more item let contents = docParagraph . parseString . dropNLs . unlines $ c : cs return $ case items of - Left p -> [contents <> p] + Left p -> [contents `docAppend` p] Right i -> contents : i -- | Parses definition lists. @@ -276,7 +276,7 @@ definitionList = do (cs, items) <- more definitionList let contents = parseString . dropNLs . unlines $ c : cs return $ case items of - Left p -> [(label, contents <> p)] + Left p -> [(label, contents `docAppend` p)] Right i -> (label, contents) : i -- | Drops all trailing newlines. @@ -291,12 +291,12 @@ more :: Monoid a => Parser a more item = innerParagraphs <|> moreListItems item <|> moreContent item <|> pure ([], Right mempty) --- | Use by 'innerList' and 'definitionList' to parse any nested paragraphs. +-- | Used by 'innerList' and 'definitionList' to parse any nested paragraphs. innerParagraphs :: Parser ([String], Either (DocH mod Identifier) a) innerParagraphs = (,) [] . Left <$> ("\n" *> indentedParagraphs) --- | Attemps to fetch the next list if possibly. Used by 'innerList' and --- 'definitionList' to recursivly grab lists that aren't separated by a whole +-- | Attempts to fetch the next list if possibly. Used by 'innerList' and +-- 'definitionList' to recursively grab lists that aren't separated by a whole -- paragraph. moreListItems :: Parser a -> Parser ([String], Either (DocH mod Identifier) a) @@ -456,7 +456,7 @@ autoUrl = mkLink <$> url url = mappend <$> ("http://" <|> "https://" <|> "ftp://") <*> takeWhile1 (not . isSpace) mkLink :: BS.ByteString -> DocH mod a mkLink s = case unsnoc s of - Just (xs, x) | x `elem` ",.!?" -> DocHyperlink (Hyperlink (decodeUtf8 xs) Nothing) <> DocString [x] + Just (xs, x) | x `elem` ",.!?" -> DocHyperlink (Hyperlink (decodeUtf8 xs) Nothing) `docAppend` DocString [x] _ -> DocHyperlink (Hyperlink (decodeUtf8 s) Nothing) -- | Parses strings between identifier delimiters. Consumes all input that it diff --git a/haddock-library/test/Documentation/Haddock/ParserSpec.hs b/haddock-library/test/Documentation/Haddock/ParserSpec.hs index 5181a3f3..7df9dab2 100644 --- a/haddock-library/test/Documentation/Haddock/ParserSpec.hs +++ b/haddock-library/test/Documentation/Haddock/ParserSpec.hs @@ -4,13 +4,16 @@ module Documentation.Haddock.ParserSpec (main, spec) where -import Data.Monoid import Data.String import qualified Documentation.Haddock.Parser as Parse import Documentation.Haddock.Types +import Documentation.Haddock.Doc (docAppend) import Test.Hspec import Test.QuickCheck +infixr 6 <> +(<>) = docAppend + type Doc id = DocH () id instance IsString (Doc String) where @@ -605,6 +608,21 @@ spec = do ] <> DocOrderedList [ DocParagraph "baz" ] + it "list order is preserved in presence of nesting + extra text" $ do + "1. Foo\n\n > Some code\n\n2. Bar\n\nSome text" + `shouldParseTo` + DocOrderedList [ DocParagraph "Foo" <> DocCodeBlock "Some code" + , DocParagraph "Bar" + ] + <> DocParagraph (DocString "Some text") + + "1. Foo\n\n2. Bar\n\nSome text" + `shouldParseTo` + DocOrderedList [ DocParagraph "Foo" + , DocParagraph "Bar" + ] + <> DocParagraph (DocString "Some text") + context "when parsing properties" $ do it "can parse a single property" $ do "prop> 23 == 23" `shouldParseTo` DocProperty "23 == 23" diff --git a/html-test/ref/Bug313.html b/html-test/ref/Bug313.html new file mode 100644 index 00000000..a3a03b0e --- /dev/null +++ b/html-test/ref/Bug313.html @@ -0,0 +1,132 @@ + +Bug313
Safe HaskellSafe-Inferred

Bug313

Description

The first list is incorrectly numbered as 1. 2. 1.; the second example + renders fine (1. 2. 3.).

See https://github.com/haskell/haddock/issues/313

Synopsis

  • a :: a
  • b :: a

Documentation

a :: a

Some text.

  1. Item 1

  2. Item 2

    Some code
  3. Item 3

Some more text.

b :: a

Some text.

  1. Item 1

  2. Item 2

    Some code
  3. Item 3

Some more text.

diff --git a/html-test/src/Bug313.hs b/html-test/src/Bug313.hs new file mode 100644 index 00000000..90d4d3b6 --- /dev/null +++ b/html-test/src/Bug313.hs @@ -0,0 +1,37 @@ +-- | The first list is incorrectly numbered as 1. 2. 1.; the second example +-- renders fine (1. 2. 3.). +-- +-- See https://github.com/haskell/haddock/issues/313 +module Bug313 where + +{- | +Some text. + +1. Item 1 + +2. Item 2 + + > Some code + +3. Item 3 + +Some more text. +-} +a :: a +a = undefined + +{- | +Some text. + +1. Item 1 + +2. Item 2 + + > Some code + +3. Item 3 + +-} +-- | Some more text. +b :: a +b = undefined diff --git a/src/Haddock/Doc.hs b/src/Haddock/Doc.hs index 79a59ac2..91ad709f 100644 --- a/src/Haddock/Doc.hs +++ b/src/Haddock/Doc.hs @@ -5,14 +5,13 @@ module Haddock.Doc ( module Documentation.Haddock.Doc ) where import Data.Maybe -import Data.Monoid import Documentation.Haddock.Doc import Haddock.Types combineDocumentation :: Documentation name -> Maybe (Doc name) combineDocumentation (Documentation Nothing Nothing) = Nothing combineDocumentation (Documentation mDoc mWarning) = - Just (fromMaybe mempty mWarning <> fromMaybe mempty mDoc) + Just (fromMaybe DocEmpty mWarning `docAppend` fromMaybe DocEmpty mDoc) -- Drop trailing whitespace from @..@ code blocks. Otherwise this: -- diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index bc615cde..cf7ed841 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -14,7 +14,7 @@ ----------------------------------------------------------------------------- module Haddock.Interface.Create (createInterface) where - +import Documentation.Haddock.Doc (docAppend) import Haddock.Types import Haddock.Options import Haddock.GhcUtils @@ -251,11 +251,14 @@ mkMaps :: DynFlags -> Maps mkMaps dflags gre instances decls = let (a, b, c, d) = unzip4 $ map mappings decls - in (f $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap) + in (f' $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap) where f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b f = M.fromListWith (<>) . concat + f' :: [[(Name, Doc Name)]] -> Map Name (Doc Name) + f' = M.fromListWith docAppend . concat + mappings :: (LHsDecl Name, [HsDocString]) -> ( [(Name, Doc Name)] , [(Name, Map Int (Doc Name))] diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index 54c7351d..f1021436 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -21,7 +21,7 @@ module Haddock.Interface.LexParseRn import Control.Applicative import Data.IntSet (toList) import Data.List -import Data.Monoid (mconcat) +import Documentation.Haddock.Doc (docConcat) import DynFlags (ExtensionFlag(..), languageExtensions) import FastString import GHC @@ -34,7 +34,7 @@ import RdrName processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (Doc Name) processDocStrings dflags gre strs = - case mconcat $ map (processDocStringParas dflags gre) strs of + case docConcat $ map (processDocStringParas dflags gre) strs of DocEmpty -> Nothing x -> Just x -- cgit v1.2.3