diff options
Diffstat (limited to 'src/Text/Pandoc/Writers/Haddock.hs')
| -rw-r--r-- | src/Text/Pandoc/Writers/Haddock.hs | 170 |
1 files changed, 79 insertions, 91 deletions
diff --git a/src/Text/Pandoc/Writers/Haddock.hs b/src/Text/Pandoc/Writers/Haddock.hs index 29fdafe15..688c1f390 100644 --- a/src/Text/Pandoc/Writers/Haddock.hs +++ b/src/Text/Pandoc/Writers/Haddock.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE OverloadedStrings, TupleSections, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {- -Copyright (C) 2014 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2014-2015, 2017-2018 John MacFarlane <jgm@berkeley.edu> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -19,7 +21,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA {- | Module : Text.Pandoc.Writers.Haddock - Copyright : Copyright (C) 2014 John MacFarlane + Copyright : Copyright (C) 2014-2015,2017 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -31,17 +33,19 @@ Conversion of 'Pandoc' documents to haddock markup. Haddock: <http://www.haskell.org/haddock/doc/html/> -} module Text.Pandoc.Writers.Haddock (writeHaddock) where +import Control.Monad.State.Strict +import Data.Default +import Data.List (intersperse, transpose) +import Data.Text (Text) +import Text.Pandoc.Class (PandocMonad, report) import Text.Pandoc.Definition -import Text.Pandoc.Templates (renderTemplate') -import Text.Pandoc.Shared -import Text.Pandoc.Writers.Shared +import Text.Pandoc.Logging import Text.Pandoc.Options -import Data.List ( intersperse, transpose ) import Text.Pandoc.Pretty -import Control.Monad.State -import Text.Pandoc.Readers.TeXMath (texMathToInlines) -import Network.URI (isURI) -import Data.Default +import Text.Pandoc.Shared +import Text.Pandoc.Templates (renderTemplate') +import Text.Pandoc.Writers.Math (texMathToInlines) +import Text.Pandoc.Writers.Shared type Notes = [[Block]] data WriterState = WriterState { stNotes :: Notes } @@ -49,13 +53,14 @@ instance Default WriterState where def = WriterState{ stNotes = [] } -- | Convert Pandoc to Haddock. -writeHaddock :: WriterOptions -> Pandoc -> String +writeHaddock :: PandocMonad m => WriterOptions -> Pandoc -> m Text writeHaddock opts document = - evalState (pandocToHaddock opts{ + evalStateT (pandocToHaddock opts{ writerWrapText = writerWrapText opts } document) def -- | Return haddock representation of document. -pandocToHaddock :: WriterOptions -> Pandoc -> State WriterState String +pandocToHaddock :: PandocMonad m + => WriterOptions -> Pandoc -> StateT WriterState m Text pandocToHaddock opts (Pandoc meta blocks) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts @@ -63,22 +68,22 @@ pandocToHaddock opts (Pandoc meta blocks) = do body <- blockListToHaddock opts blocks st <- get notes' <- notesToHaddock opts (reverse $ stNotes st) - let render' :: Doc -> String + let render' :: Doc -> Text render' = render colwidth let main = render' $ body <> (if isEmpty notes' then empty else blankline <> notes') metadata <- metaToJSON opts - (fmap (render colwidth) . blockListToHaddock opts) - (fmap (render colwidth) . inlineListToHaddock opts) + (fmap render' . blockListToHaddock opts) + (fmap render' . inlineListToHaddock opts) meta - let context = defField "body" main - $ metadata + let context = defField "body" main metadata case writerTemplate opts of Nothing -> return main - Just tpl -> return $ renderTemplate' tpl context + Just tpl -> renderTemplate' tpl context -- | Return haddock representation of notes. -notesToHaddock :: WriterOptions -> [[Block]] -> State WriterState Doc +notesToHaddock :: PandocMonad m + => WriterOptions -> [[Block]] -> StateT WriterState m Doc notesToHaddock opts notes = if null notes then return empty @@ -92,9 +97,10 @@ escapeString = escapeStringUsing haddockEscapes where haddockEscapes = backslashEscapes "\\/'`\"@<" -- | Convert Pandoc block element to haddock. -blockToHaddock :: WriterOptions -- ^ Options - -> Block -- ^ Block element - -> State WriterState Doc +blockToHaddock :: PandocMonad m + => WriterOptions -- ^ Options + -> Block -- ^ Block element + -> StateT WriterState m Doc blockToHaddock _ Null = return empty blockToHaddock opts (Div _ ils) = do contents <- blockListToHaddock opts ils @@ -110,10 +116,12 @@ blockToHaddock opts (Para inlines) = (<> blankline) `fmap` blockToHaddock opts (Plain inlines) blockToHaddock opts (LineBlock lns) = blockToHaddock opts $ linesToPara lns -blockToHaddock _ (RawBlock f str) - | f == "haddock" = do +blockToHaddock _ b@(RawBlock f str) + | f == "haddock" = return $ text str <> text "\n" - | otherwise = return empty + | otherwise = do + report $ BlockNotRendered b + return empty blockToHaddock opts HorizontalRule = return $ blankline <> text (replicate (writerColumns opts) '_') <> blankline blockToHaddock opts (Header level (ident,_,_) inlines) = do @@ -141,16 +149,16 @@ blockToHaddock opts (Table caption aligns widths headers rows) = do isPlainBlock _ = False let hasBlocks = not (all isPlainBlock $ concat . concat $ headers:rows) (nst,tbl) <- case True of - _ | isSimple -> fmap (nest 2,) $ + _ | isSimple -> (nest 2,) <$> pandocTable opts (all null headers) aligns widths rawHeaders rawRows - | not hasBlocks -> fmap (nest 2,) $ + | not hasBlocks -> (nest 2,) <$> pandocTable opts (all null headers) aligns widths rawHeaders rawRows - | otherwise -> fmap (id,) $ - gridTable opts (all null headers) aligns widths - rawHeaders rawRows - return $ (prefixed "> " $ nst $ tbl $$ blankline $$ caption'') $$ blankline + | otherwise -> (id,) <$> + gridTable opts blockListToHaddock + (all null headers) aligns widths headers rows + return $ prefixed "> " (nst $ tbl $$ blankline $$ caption'') $$ blankline blockToHaddock opts (BulletList items) = do contents <- mapM (bulletListItemToHaddock opts) items return $ cat contents <> blankline @@ -160,15 +168,15 @@ blockToHaddock opts (OrderedList (start,_,delim) items) = do let markers' = map (\m -> if length m < 3 then m ++ replicate (3 - length m) ' ' else m) markers - contents <- mapM (\(item, num) -> orderedListItemToHaddock opts item num) $ - zip markers' items + contents <- zipWithM (orderedListItemToHaddock opts) markers' items return $ cat contents <> blankline blockToHaddock opts (DefinitionList items) = do contents <- mapM (definitionListItemToHaddock opts) items return $ cat contents <> blankline -pandocTable :: WriterOptions -> Bool -> [Alignment] -> [Double] - -> [Doc] -> [[Doc]] -> State WriterState Doc +pandocTable :: PandocMonad m + => WriterOptions -> Bool -> [Alignment] -> [Double] + -> [Doc] -> [[Doc]] -> StateT WriterState m Doc pandocTable opts headless aligns widths rawHeaders rawRows = do let isSimple = all (==0) widths let alignHeader alignment = case alignment of @@ -184,18 +192,17 @@ pandocTable opts headless aligns widths rawHeaders rawRows = do (floor . (fromIntegral (writerColumns opts) *)) widths let makeRow = hcat . intersperse (lblock 1 (text " ")) . - (zipWith3 alignHeader aligns widthsInChars) + zipWith3 alignHeader aligns widthsInChars let rows' = map makeRow rawRows let head' = makeRow rawHeaders let maxRowHeight = maximum $ map height (head':rows') let underline = cat $ intersperse (text " ") $ map (\width -> text (replicate width '-')) widthsInChars - let border = if maxRowHeight > 1 - then text (replicate (sum widthsInChars + - length widthsInChars - 1) '-') - else if headless - then underline - else empty + let border + | maxRowHeight > 1 = text (replicate (sum widthsInChars + + length widthsInChars - 1) '-') + | headless = underline + | otherwise = empty let head'' = if headless then empty else border <> cr <> head' @@ -207,35 +214,9 @@ pandocTable opts headless aligns widths rawHeaders rawRows = do else border return $ head'' $$ underline $$ body $$ bottom -gridTable :: WriterOptions -> Bool -> [Alignment] -> [Double] - -> [Doc] -> [[Doc]] -> State WriterState Doc -gridTable opts headless _aligns widths headers' rawRows = do - let numcols = length headers' - let widths' = if all (==0) widths - then replicate numcols (1.0 / fromIntegral numcols) - else widths - let widthsInChars = map (floor . (fromIntegral (writerColumns opts) *)) widths' - let hpipeBlocks blocks = hcat [beg, middle, end] - where h = maximum (map height blocks) - sep' = lblock 3 $ vcat (map text $ replicate h " | ") - beg = lblock 2 $ vcat (map text $ replicate h "| ") - end = lblock 2 $ vcat (map text $ replicate h " |") - middle = chomp $ hcat $ intersperse sep' blocks - let makeRow = hpipeBlocks . zipWith lblock widthsInChars - let head' = makeRow headers' - let rows' = map (makeRow . map chomp) rawRows - let border ch = char '+' <> char ch <> - (hcat $ intersperse (char ch <> char '+' <> char ch) $ - map (\l -> text $ replicate l ch) widthsInChars) <> - char ch <> char '+' - let body = vcat $ intersperse (border '-') rows' - let head'' = if headless - then empty - else head' $$ border '=' - return $ border '-' $$ head'' $$ body $$ border '-' - -- | Convert bullet list item (list of blocks) to haddock -bulletListItemToHaddock :: WriterOptions -> [Block] -> State WriterState Doc +bulletListItemToHaddock :: PandocMonad m + => WriterOptions -> [Block] -> StateT WriterState m Doc bulletListItemToHaddock opts items = do contents <- blockListToHaddock opts items let sps = replicate (writerTabStop opts - 2) ' ' @@ -250,22 +231,24 @@ bulletListItemToHaddock opts items = do return $ hang (writerTabStop opts) start $ contents' <> cr -- | Convert ordered list item (a list of blocks) to haddock -orderedListItemToHaddock :: WriterOptions -- ^ options - -> String -- ^ list item marker - -> [Block] -- ^ list item (list of blocks) - -> State WriterState Doc +orderedListItemToHaddock :: PandocMonad m + => WriterOptions -- ^ options + -> String -- ^ list item marker + -> [Block] -- ^ list item (list of blocks) + -> StateT WriterState m Doc orderedListItemToHaddock opts marker items = do contents <- blockListToHaddock opts items let sps = case length marker - writerTabStop opts of n | n > 0 -> text $ replicate n ' ' - _ -> text " " + _ -> text " " let start = text marker <> sps return $ hang (writerTabStop opts) start $ contents <> cr -- | Convert definition list item (label, list of blocks) to haddock -definitionListItemToHaddock :: WriterOptions - -> ([Inline],[[Block]]) - -> State WriterState Doc +definitionListItemToHaddock :: PandocMonad m + => WriterOptions + -> ([Inline],[[Block]]) + -> StateT WriterState m Doc definitionListItemToHaddock opts (label, defs) = do labelText <- inlineListToHaddock opts label defs' <- mapM (mapM (blockToHaddock opts)) defs @@ -273,19 +256,22 @@ definitionListItemToHaddock opts (label, defs) = do return $ nowrap (brackets labelText) <> cr <> contents <> cr -- | Convert list of Pandoc block elements to haddock -blockListToHaddock :: WriterOptions -- ^ Options - -> [Block] -- ^ List of block elements - -> State WriterState Doc +blockListToHaddock :: PandocMonad m + => WriterOptions -- ^ Options + -> [Block] -- ^ List of block elements + -> StateT WriterState m Doc blockListToHaddock opts blocks = mapM (blockToHaddock opts) blocks >>= return . cat -- | Convert list of Pandoc inline elements to haddock. -inlineListToHaddock :: WriterOptions -> [Inline] -> State WriterState Doc +inlineListToHaddock :: PandocMonad m + => WriterOptions -> [Inline] -> StateT WriterState m Doc inlineListToHaddock opts lst = mapM (inlineToHaddock opts) lst >>= return . cat -- | Convert Pandoc inline element to haddock. -inlineToHaddock :: WriterOptions -> Inline -> State WriterState Doc +inlineToHaddock :: PandocMonad m + => WriterOptions -> Inline -> StateT WriterState m Doc inlineToHaddock opts (Span (ident,_,_) ils) = do contents <- inlineListToHaddock opts ils if not (null ident) && null ils @@ -315,18 +301,20 @@ inlineToHaddock opts (Quoted DoubleQuote lst) = do return $ "“" <> contents <> "”" inlineToHaddock _ (Code _ str) = return $ "@" <> text (escapeString str) <> "@" -inlineToHaddock _ (Str str) = do +inlineToHaddock _ (Str str) = return $ text $ escapeString str inlineToHaddock opts (Math mt str) = do let adjust x = case mt of DisplayMath -> cr <> x <> cr InlineMath -> x - adjust `fmap` (inlineListToHaddock opts $ texMathToInlines mt str) -inlineToHaddock _ (RawInline f str) + adjust <$> (lift (texMathToInlines mt str) >>= inlineListToHaddock opts) +inlineToHaddock _ il@(RawInline f str) | f == "haddock" = return $ text str - | otherwise = return empty + | otherwise = do + report $ InlineNotRendered il + return empty -- no line break in haddock (see above on CodeBlock) -inlineToHaddock _ (LineBreak) = return cr +inlineToHaddock _ LineBreak = return cr inlineToHaddock opts SoftBreak = case writerWrapText opts of WrapAuto -> return space @@ -339,7 +327,7 @@ inlineToHaddock _ (Link _ txt (src, _)) = do let useAuto = isURI src && case txt of [Str s] | escapeURI s == src -> True - _ -> False + _ -> False return $ nowrap $ "<" <> text src <> (if useAuto then empty else space <> linktext) <> ">" inlineToHaddock opts (Image attr alternate (source, tit)) = do |