aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haddock-library/src/Documentation/Haddock/Doc.hs12
-rw-r--r--haddock-library/src/Documentation/Haddock/Parser.hs26
-rw-r--r--haddock-library/test/Documentation/Haddock/ParserSpec.hs20
-rw-r--r--html-test/ref/Bug313.html132
-rw-r--r--html-test/src/Bug313.hs37
-rw-r--r--src/Haddock/Doc.hs3
-rw-r--r--src/Haddock/Interface/Create.hs7
-rw-r--r--src/Haddock/Interface/LexParseRn.hs4
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"
+ >&nbsp;</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
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-21 08:41:39 +0000