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.

3 files changed, 37 insertions, 21 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"