diff options
-rw-r--r-- | haddock-library/src/Documentation/Haddock/Doc.hs | 12 | ||||
-rw-r--r-- | haddock-library/src/Documentation/Haddock/Parser.hs | 26 | ||||
-rw-r--r-- | haddock-library/test/Documentation/Haddock/ParserSpec.hs | 20 | ||||
-rw-r--r-- | html-test/ref/Bug313.html | 132 | ||||
-rw-r--r-- | html-test/src/Bug313.hs | 37 | ||||
-rw-r--r-- | src/Haddock/Doc.hs | 3 | ||||
-rw-r--r-- | src/Haddock/Interface/Create.hs | 7 | ||||
-rw-r--r-- | src/Haddock/Interface/LexParseRn.hs | 4 |
8 files changed, 214 insertions, 27 deletions
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 -- <https://en.wikipedia.org/wiki/Numeric_character_reference Numeric character references> @@ -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 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Bug313</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_Bug313.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >Safe-Inferred</td + ></tr + ></table + ><p class="caption" + >Bug313</p + ></div + ><div id="description" + ><p class="caption" + >Description</p + ><div class="doc" + ><p + >The first list is incorrectly numbered as 1. 2. 1.; the second example + renders fine (1. 2. 3.).</p + ><p + >See <a href="" + >https://github.com/haskell/haddock/issues/313</a + ></p + ></div + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><a href="" + >a</a + > :: a</li + ><li class="src short" + ><a href="" + >b</a + > :: a</li + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a name="v:a" class="def" + >a</a + > :: a</p + ><div class="doc" + ><p + >Some text.</p + ><ol + ><li + >Item 1</li + ><li + ><p + >Item 2</p + ><pre + >Some code</pre + ></li + ><li + >Item 3</li + ></ol + ><p + >Some more text.</p + ></div + ></div + ><div class="top" + ><p class="src" + ><a name="v:b" class="def" + >b</a + > :: a</p + ><div class="doc" + ><p + >Some text.</p + ><ol + ><li + >Item 1</li + ><li + ><p + >Item 2</p + ><pre + >Some code</pre + ></li + ><li + >Item 3</li + ></ol + ><p + >Some more text.</p + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.15.0</p + ></div + ></body + ></html +> 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 |