Rewrote haddock reader to use haddock-library.

This brings pandoc's rendering of haddock markup in line
with the new haddock.

Note that we preserve line breaks in `@` code blocks, unlike
the earlier version.

Modified tests pass.  More tests would be good.

src/Text/Pandoc/Readers/Haddock.hs

@@ -15,10 +15,13 @@ module Text.Pandoc.Readers.Haddock
 
 import Text.Pandoc.Builder (Blocks, Inlines)
 import qualified Text.Pandoc.Builder as B
+import Text.Pandoc.Shared (trim, splitBy)
 import Data.Monoid
+import Data.List (intersperse, stripPrefix)
+import Data.Maybe (fromMaybe)
 import Text.Pandoc.Definition
 import Text.Pandoc.Options
-import Documentation.Haddock.Parser (parseParas, Identifier)
+import Documentation.Haddock.Parser
 import Documentation.Haddock.Types
 
 -- | Parse Haddock markup and return a 'Pandoc' document.
@@ -27,25 +30,102 @@ readHaddock :: ReaderOptions -- ^ Reader options
             -> Pandoc
 readHaddock _ = B.doc . docHToBlocks . parseParas
 
-docHToBlocks :: DocH mod Identifier -> Blocks
+docHToBlocks :: DocH String Identifier -> Blocks
-docHToBlocks d =
+docHToBlocks d' =
-  case d of
+  case d' of
+    DocEmpty -> mempty
     DocAppend d1 d2 -> mappend (docHToBlocks d1) (docHToBlocks d2)
-    DocParagraph ils -> B.para $ docHToInlines ils
+    DocString _ -> inlineFallback
+    DocParagraph ils -> B.para $ docHToInlines False ils
+    DocIdentifier _ -> inlineFallback
+    DocIdentifierUnchecked _ -> inlineFallback
+    DocModule s -> B.plain $ docHToInlines False $ DocModule s
+    DocWarning _ -> mempty -- TODO
+    DocEmphasis _ -> inlineFallback
+    DocMonospaced _ -> inlineFallback
+    DocBold _ -> inlineFallback
+    DocHeader h -> B.header (headerLevel h)
+                           (docHToInlines False $ headerTitle h)
+    DocUnorderedList items -> B.bulletList (map docHToBlocks items)
+    DocOrderedList items -> B.orderedList (map docHToBlocks items)
+    DocDefList items -> B.definitionList (map (\(d,t) ->
+                               (docHToInlines False d,
+                                [consolidatePlains $ docHToBlocks t])) items)
+    DocCodeBlock (DocString s) -> B.codeBlockWith ("",["haskell"],[]) s
+    DocCodeBlock d -> B.para $ docHToInlines True d
+    DocHyperlink _ -> inlineFallback
+    DocPic _ -> inlineFallback
+    DocAName _ -> inlineFallback
+    DocProperty s -> B.codeBlockWith ("",["property","haskell"],[]) (trim s)
+    DocExamples es -> mconcat $ map (\e ->
+       makeExample ">>>" (exampleExpression e) (exampleResult e)) es
 
-docHToInlines :: DocH mod Identifier -> Inlines
+  where inlineFallback = B.plain $ docHToInlines False d'
-docHToInlines d =
+        consolidatePlains = B.fromList . consolidatePlains' . B.toList
-  case d of
+        consolidatePlains' zs@(Plain _ : _) =
-    DocAppend d1 d2 -> mappend (docHToInlines d1) (docHToInlines d2)
+          let (xs, ys) = span isPlain zs in
-    DocString s -> B.text s
+          Plain (concatMap extractContents xs) : consolidatePlains' ys
+        consolidatePlains' (x : xs) = x : consolidatePlains' xs
+        consolidatePlains' [] = []
+        isPlain (Plain _) = True
+        isPlain _         = False
+        extractContents (Plain xs) = xs
+        extractContents _ = []
+
+docHToInlines :: Bool -> DocH String Identifier -> Inlines
+docHToInlines isCode d' =
+  case d' of
+    DocEmpty -> mempty
+    DocAppend d1 d2 -> mappend (docHToInlines isCode d1)
+                               (docHToInlines isCode d2)
+    DocString s
+      | isCode -> mconcat $ intersperse B.linebreak
+                              $ map B.code $ splitBy (=='\n') s
+      | otherwise  -> B.text s
+    DocParagraph _ -> mempty
+    DocIdentifier (_,s,_) -> B.codeWith ("",["haskell"],[]) s
+    DocIdentifierUnchecked s -> B.codeWith ("",["haskell"],[]) s
+    DocModule s -> B.codeWith ("",["haskell"],[]) s
+    DocWarning _ -> mempty -- TODO
+    DocEmphasis d -> B.emph (docHToInlines isCode d)
+    DocMonospaced (DocString s) -> B.code s
+    DocMonospaced d -> docHToInlines True d
+    DocBold d -> B.strong (docHToInlines isCode d)
+    DocHeader _ -> mempty
+    DocUnorderedList _ -> mempty
+    DocOrderedList _ -> mempty
+    DocDefList _ -> mempty
+    DocCodeBlock _ -> mempty
+    DocHyperlink h -> B.link (hyperlinkUrl h) (hyperlinkUrl h)
+             (maybe (B.text $ hyperlinkUrl h) B.text $ hyperlinkLabel h)
+    DocPic p -> B.image (pictureUri p) (fromMaybe (pictureUri p) $ pictureTitle p)
+                        (maybe mempty B.text $ pictureTitle p)
+    DocAName s -> B.spanWith (s,["anchor"],[]) mempty
+    DocProperty _ -> mempty
+    DocExamples _ -> mempty
+
+-- | Create an 'Example', stripping superfluous characters as appropriate
+makeExample :: String -> String -> [String] -> Blocks
+makeExample prompt expression result =
+    B.para $ B.codeWith ("",["prompt"],[]) prompt
+        <> B.space
+        <> B.codeWith ([], ["haskell","expr"], []) (trim expression)
+        <> B.linebreak
+        <> (mconcat $ intersperse B.linebreak $ map coder result')
+  where
+    -- 1. drop trailing whitespace from the prompt, remember the prefix
+    prefix = takeWhile (`elem` " \t") prompt
+
+    -- 2. drop, if possible, the exact same sequence of whitespace
+    -- characters from each result line
+    --
+    -- 3. interpret lines that only contain the string "<BLANKLINE>" as an
+    -- empty line
+    result' = map (substituteBlankLine . tryStripPrefix prefix) result
+      where
+        tryStripPrefix xs ys = fromMaybe ys $ stripPrefix xs ys
+
+        substituteBlankLine "<BLANKLINE>" = ""
+        substituteBlankLine line          = line
+    coder = B.codeWith ([], ["result"], [])
 
--- similar to 'docAppend' in Haddock.Doc
-mergeLists :: [Block] -> [Block]
-mergeLists (BulletList xs : BulletList ys : blocks)
-    = mergeLists (BulletList (xs ++ ys) : blocks)
-mergeLists (OrderedList _ xs : OrderedList a ys : blocks) 
-    = mergeLists (OrderedList a (xs ++ ys) : blocks)
-mergeLists (DefinitionList xs : DefinitionList ys : blocks)
-    = mergeLists (DefinitionList (xs ++ ys) : blocks)
-mergeLists (x : blocks) = x : mergeLists blocks
-mergeLists [] = []

tests/haddock-reader.haddock

@@ -18,10 +18,10 @@ This is a code block:
 This is another code block:
 
 @
-    f x = x + x.
+f x = x + x.
-    The \@...\@ code block /interprets markup normally/.
+The \@...\@ code block /interprets markup normally/.
-    "Module.Foo"
+"Module.Foo"
-    \"Hello World\"
+\"Hello World\"
 @
 
 Haddock supports REPL examples:
@@ -42,21 +42,21 @@ This is a reference to the "Foo" module.
 
 This is a bulleted list:
 
-    * first item
+  * first item
 
-    * second item
+  * second item
 
 This is an enumerated list:
 
-    (1) first item
+  (1) first item
 
-    2. second item
+  2. second item
 
 This is a definition list:
 
-    [@foo@] The description of @foo@.
+  [@foo@] The description of @foo@.
 
-    [@bar@] The description of @bar@.
+  [@bar@] The description of @bar@.
 
 Here is a link: <http://haskell.org>
 

tests/haddock-reader.native

@@ -4,13 +4,13 @@ Pandoc (Meta {unMeta = fromList []})
 ,Para [Str "*",Space,Str "This",Space,Str "is",Space,Str "a",Space,Str "paragraph,",Space,Str "not",Space,Str "a",Space,Str "list",Space,Str "item.",Space,Str ">",Space,Str "This",Space,Str "sentence",Space,Str "is",Space,Str "not",Space,Str "code.",Space,Str ">>>",Space,Str "This",Space,Str "is",Space,Str "not",Space,Str "an",Space,Str "example."]
 ,Para [Str "The",Space,Str "references",Space,Str "\955,",Space,Str "\955",Space,Str "and",Space,Str "\955",Space,Str "all",Space,Str "represent",Space,Str "the",Space,Str "lower-case",Space,Str "letter",Space,Str "lambda."]
 ,Para [Str "This",Space,Str "is",Space,Str "a",Space,Str "code",Space,Str "block:"]
-,CodeBlock ("",["haskell"],[]) " map :: (a -> b) -> [a] -> [b]\n map _ []     = []\n map f (x:xs) = f x : map f xs\n"
+,CodeBlock ("",["haskell"],[]) "map :: (a -> b) -> [a] -> [b]\nmap _ []     = []\nmap f (x:xs) = f x : map f xs"
 ,Para [Str "This",Space,Str "is",Space,Str "another",Space,Str "code",Space,Str "block:"]
-,Para [Code ("",[],[]) "f",Space,Code ("",[],[]) "x",Space,Code ("",[],[]) "=",Space,Code ("",[],[]) "x",Space,Code ("",[],[]) "+",Space,Code ("",[],[]) "x.",Space,Code ("",[],[]) "The",Space,Code ("",[],[]) "@...@",Space,Code ("",[],[]) "code",Space,Code ("",[],[]) "block",Space,Emph [Code ("",[],[]) "interprets markup normally"],Code ("",[],[]) ".",Space,Code ("",["haskell"],[]) "Module.Foo",Space,Code ("",[],[]) "\"Hello",Space,Code ("",[],[]) "World\""]
+,Para [Code ("",[],[]) "f x = x + x.",LineBreak,Code ("",[],[]) "The @...@ code block ",Emph [Code ("",[],[]) "interprets markup normally"],Code ("",[],[]) ".",Code ("",["haskell"],[]) "Module.Foo",Code ("",[],[]) "",LineBreak,Code ("",[],[]) "\"Hello World\""]
 ,Para [Str "Haddock",Space,Str "supports",Space,Str "REPL",Space,Str "examples:"]
 ,Para [Code ("",["haskell","expr"],[]) "fib 10",LineBreak,Code ("",["result"],[]) "55"]
 ,Para [Code ("",["haskell","expr"],[]) "putStrLn \"foo\\nbar\"",LineBreak,Code ("",["result"],[]) "foo",LineBreak,Code ("",["result"],[]) "bar"]
-,Para [Str "That",Space,Str "was",Space,Emph [Str "really cool"],Str "!",Space,Str "I",Space,Str "had",Space,Str "no",Space,Str "idea",Space,Code ("",[],[]) "fib",Space,Code ("",[],[]) "10",Space,Code ("",[],[]) "=",Space,Code ("",[],[]) "55",Str "."]
+,Para [Str "That",Space,Str "was",Space,Emph [Str "really",Space,Str "cool"],Str "!",Space,Str "I",Space,Str "had",Space,Str "no",Space,Str "idea",Space,Code ("",[],[]) "fib 10 = 55",Str "."]
 ,Para [Str "This",Space,Str "module",Space,Str "defines",Space,Str "the",Space,Str "type",Space,Code ("",["haskell"],[]) "T",Str ".",Space,Str "The",Space,Str "identifier",Space,Code ("",["haskell"],[]) "M.T",Space,Str "is",Space,Str "not",Space,Str "in",Space,Str "scope",Space,Str "I",Space,Str "don't",Space,Str "have",Space,Str "to",Space,Str "escape",Space,Str "my",Space,Str "apostrophes;",Space,Str "great,",Space,Str "isn't",Space,Str "it?",Space,Str "This",Space,Str "is",Space,Str "a",Space,Str "reference",Space,Str "to",Space,Str "the",Space,Code ("",["haskell"],[]) "Foo",Space,Str "module."]
 ,Para [Str "This",Space,Str "is",Space,Str "a",Space,Str "bulleted",Space,Str "list:"]
 ,BulletList