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.
This commit is contained in:
John MacFarlane
parent
a78d8b84ca
commit
9fc5c8d7af
3 changed files with 113 additions and 33 deletions
|
|
@ -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
|
||||
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
|
||||
docHToInlines d =
|
||||
case d of
|
||||
DocAppend d1 d2 -> mappend (docHToInlines d1) (docHToInlines d2)
|
||||
DocString s -> B.text s
|
||||
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"], [])
|
||||
|
||||
-- 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 [] = []
|
||||
|
|
|
|||
|
|
@ -18,10 +18,10 @@ This is a code block:
|
|||
This is another code block:
|
||||
|
||||
@
|
||||
f x = x + x.
|
||||
The \@...\@ code block /interprets markup normally/.
|
||||
"Module.Foo"
|
||||
\"Hello World\"
|
||||
f x = x + x.
|
||||
The \@...\@ code block /interprets markup normally/.
|
||||
"Module.Foo"
|
||||
\"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>
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue