From 9fc5c8d7af31a47d8e3e8ea6dbb541178ec9ca66 Mon Sep 17 00:00:00 2001
From: John MacFarlane <jgm@berkeley.edu>
Date: Wed, 18 Jun 2014 12:27:27 -0700
Subject: 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 | 124 ++++++++++++++++++++++++++++++-------
1 file changed, 102 insertions(+), 22 deletions(-)
(limited to 'src')
diff --git a/src/Text/Pandoc/Readers/Haddock.hs b/src/Text/Pandoc/Readers/Haddock.hs
index 65d8de98f..a512f969d 100644
--- a/src/Text/Pandoc/Readers/Haddock.hs
+++ b/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 d =
- case d of
+docHToBlocks :: DocH String Identifier -> Blocks
+docHToBlocks d' =
+ case d' of
+ DocEmpty -> mempty
DocAppend d1 d2 -> mappend (docHToBlocks d1) (docHToBlocks d2)
- DocParagraph ils -> B.para $ docHToInlines ils
-
-docHToInlines :: DocH mod Identifier -> Inlines
-docHToInlines d =
- case d of
- DocAppend d1 d2 -> mappend (docHToInlines d1) (docHToInlines d2)
- DocString s -> B.text s
-
--- 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 [] = []
+ 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
+
+ where inlineFallback = B.plain $ docHToInlines False d'
+ consolidatePlains = B.fromList . consolidatePlains' . B.toList
+ consolidatePlains' zs@(Plain _ : _) =
+ let (xs, ys) = span isPlain zs in
+ 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"], [])
+
--
cgit v1.2.3