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.

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