More polish on Haddock reader/writer.

2 files changed, 47 insertions, 22 deletions

diff --git a/src/Text/Pandoc/Readers/Haddock.hs b/src/Text/Pandoc/Readers/Haddock.hs
index f184eabdb..a3dfb7c3c 100644
--- a/src/Text/Pandoc/Readers/Haddock.hs
+++ b/src/Text/Pandoc/Readers/Haddock.hs
@@ -45,7 +45,9 @@ docHToBlocks d' =
     DocString _ -> inlineFallback
     DocParagraph (DocHeader h) -> docHToBlocks (DocHeader h)
     DocParagraph (DocAName h) -> B.plain $ docHToInlines False $ DocAName h
-    DocParagraph ils -> B.para $ docHToInlines False ils
+    DocParagraph x -> let (ils, rest) = getInlines x
+                       in (B.para $ docHToInlines False ils)
+                          <> docHToBlocks rest
     DocIdentifier _ -> inlineFallback
     DocIdentifierUnchecked _ -> inlineFallback
     DocModule s -> B.plain $ docHToInlines False $ DocModule s
@@ -60,7 +62,7 @@ docHToBlocks d' =
     DocDefList items -> B.definitionList (map (\(d,t) ->
                                (docHToInlines False d,
                                 [consolidatePlains $ docHToBlocks t])) items)
-    DocCodeBlock (DocString s) -> B.codeBlockWith ("",["haskell"],[]) s
+    DocCodeBlock (DocString s) -> B.codeBlockWith ("",[],[]) s
     DocCodeBlock d -> B.para $ docHToInlines True d
     DocHyperlink _ -> inlineFallback
     DocPic _ -> inlineFallback
@@ -92,9 +94,9 @@ docHToInlines isCode d' =
                               $ 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
+    DocIdentifier (_,s,_) -> B.codeWith ("",["haskell","identifier"],[]) s
+    DocIdentifierUnchecked s -> B.codeWith ("",["haskell","identifier"],[]) s
+    DocModule s -> B.codeWith ("",["haskell","module"],[]) s
     DocWarning _ -> mempty -- TODO
     DocEmphasis d -> B.emph (docHToInlines isCode d)
     DocMonospaced (DocString s) -> B.code s
@@ -113,6 +115,40 @@ docHToInlines isCode d' =
     DocProperty _ -> mempty
     DocExamples _ -> mempty
 
+getInlines :: DocH String Identifier -> (DocH String Identifier, DocH String Identifier)
+getInlines (DocAppend x y) = if isInline x
+                                then let (a, b) = getInlines y
+                                     in  (DocAppend x a, b)
+                                else (DocEmpty, DocAppend x y)
+getInlines x = if isInline x
+                  then (x, DocEmpty)
+                  else (DocEmpty, x)
+
+isInline :: DocH String Identifier -> Bool
+isInline d' =
+  case d' of
+    DocEmpty -> True
+    DocAppend d1 _ -> isInline d1
+    DocString _ -> True
+    DocParagraph _ -> False
+    DocIdentifier _ -> True
+    DocIdentifierUnchecked _ -> True
+    DocModule _ -> True
+    DocWarning _ -> True
+    DocEmphasis _ -> True
+    DocMonospaced _ -> True
+    DocBold _ -> True
+    DocHeader _ -> False
+    DocUnorderedList _ -> False
+    DocOrderedList _ -> False
+    DocDefList _ -> False
+    DocCodeBlock _ -> False
+    DocHyperlink _ -> True
+    DocPic _ -> True
+    DocAName _ -> True
+    DocProperty _ -> False
+    DocExamples _ -> False
+
 -- | Create an 'Example', stripping superfluous characters as appropriate
 makeExample :: String -> String -> [String] -> Blocks
 makeExample prompt expression result =
diff --git a/src/Text/Pandoc/Writers/Haddock.hs b/src/Text/Pandoc/Writers/Haddock.hs
index 4d6b8e69f..36f57c2b7 100644
--- a/src/Text/Pandoc/Writers/Haddock.hs
+++ b/src/Text/Pandoc/Writers/Haddock.hs
@@ -80,22 +80,11 @@ pandocToHaddock opts (Pandoc meta blocks) = do
 -- | Return haddock representation of notes.
 notesToHaddock :: WriterOptions -> [[Block]] -> State WriterState Doc
 notesToHaddock opts notes =
-  mapM (\(num, note) -> noteToHaddock opts num note) (zip [1..] notes) >>=
-  return . vsep
-
--- | Return haddock representation of a note.
-noteToHaddock :: WriterOptions -> Int -> [Block] -> State WriterState Doc
-noteToHaddock opts num blocks = do
-  contents  <- blockListToHaddock opts blocks
-  let num' = text $ writerIdentifierPrefix opts ++ show num
-  let marker = text "[" <> num' <> text "]"
-  let markerSize = 4 + offset num'
-  let spacer = case writerTabStop opts - markerSize of
-                     n | n > 0  -> text $ replicate n ' '
-                     _          -> text " "
-  return $ if isEnabled Ext_footnotes opts
-              then hang (writerTabStop opts) (marker <> spacer) contents
-              else marker <> spacer <> contents
+  if null notes
+     then return empty
+     else do
+       contents <- blockToHaddock opts $ OrderedList (1,DefaultStyle,DefaultDelim) notes
+       return $ text "#notes#" <> blankline <> contents
 
 -- | Escape special characters for Haddock.
 escapeString :: String -> String
@@ -354,4 +343,4 @@ inlineToHaddock opts (Note contents) = do
   modify (\st -> st{ stNotes = contents : stNotes st })
   st <- get
   let ref = text $ writerIdentifierPrefix opts ++ show (length $ stNotes st)
-  return $ "[" <> ref <> "]"
+  return $ "<#notes [" <> ref <> "]>"