diff options
Diffstat (limited to 'src/Text')
| -rw-r--r-- | src/Text/Pandoc/Writers/Markdown.hs | 142 |
1 files changed, 78 insertions, 64 deletions
diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs index addcdf6a1..18c4befd3 100644 --- a/src/Text/Pandoc/Writers/Markdown.hs +++ b/src/Text/Pandoc/Writers/Markdown.hs @@ -44,6 +44,7 @@ import Data.List ( group, stripPrefix, find, intersperse, transpose, sortBy ) import Data.Char ( isSpace, isPunctuation, ord, chr ) import Data.Ord ( comparing ) import Text.Pandoc.Pretty +import Control.Monad.Reader import Control.Monad.State import Text.Pandoc.Writers.HTML (writeHtmlString) import Text.Pandoc.Readers.TeXMath (texMathToInlines) @@ -60,30 +61,48 @@ import Network.HTTP ( urlEncode ) type Notes = [[Block]] type Ref = ([Inline], Target, Attr) type Refs = [Ref] -data WriterState = WriterState { stNotes :: Notes - , stRefs :: Refs - , stRefShortcutable :: Bool - , stInList :: Bool - , stIds :: Set.Set String - , stPlain :: Bool } + +type MD = ReaderT WriterEnv (State WriterState) + +evalMD :: MD a -> WriterEnv -> WriterState -> a +evalMD md env st = evalState (runReaderT md env) st + +data WriterEnv = WriterEnv { envInList :: Bool + , envPlain :: Bool + , envRefShortcutable :: Bool + } + +instance Default WriterEnv + where def = WriterEnv { envInList = False + , envPlain = False + , envRefShortcutable = True + } + +data WriterState = WriterState { stNotes :: Notes + , stRefs :: Refs + , stIds :: Set.Set String + } + instance Default WriterState - where def = WriterState{ stNotes = [], stRefs = [], stRefShortcutable = True, - stInList = False, stIds = Set.empty, stPlain = False } + where def = WriterState{ stNotes = [] + , stRefs = [] + , stIds = Set.empty + } -- | Convert Pandoc to Markdown. writeMarkdown :: WriterOptions -> Pandoc -> String writeMarkdown opts document = - evalState (pandocToMarkdown opts{ - writerWrapText = if isEnabled Ext_hard_line_breaks opts - then WrapNone - else writerWrapText opts } - document) def + evalMD (pandocToMarkdown opts{ + writerWrapText = if isEnabled Ext_hard_line_breaks opts + then WrapNone + else writerWrapText opts } + document) def def -- | Convert Pandoc to plain text (like markdown, but without links, -- pictures, or inline formatting). writePlain :: WriterOptions -> Pandoc -> String writePlain opts document = - evalState (pandocToMarkdown opts document) def{ stPlain = True } + evalMD (pandocToMarkdown opts document) def{ envPlain = True } def pandocTitleBlock :: Doc -> [Doc] -> Doc -> Doc pandocTitleBlock tit auths dat = @@ -146,12 +165,12 @@ jsonToYaml (Number n) = text $ show n jsonToYaml _ = empty -- | Return markdown representation of document. -pandocToMarkdown :: WriterOptions -> Pandoc -> State WriterState String +pandocToMarkdown :: WriterOptions -> Pandoc -> MD String pandocToMarkdown opts (Pandoc meta blocks) = do let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing - isPlain <- gets stPlain + isPlain <- asks envPlain metadata <- metaToJSON opts (fmap (render colwidth) . blockListToMarkdown opts) (fmap (render colwidth) . inlineListToMarkdown opts) @@ -201,13 +220,13 @@ pandocToMarkdown opts (Pandoc meta blocks) = do else return main -- | Return markdown representation of reference key table. -refsToMarkdown :: WriterOptions -> Refs -> State WriterState Doc +refsToMarkdown :: WriterOptions -> Refs -> MD Doc refsToMarkdown opts refs = mapM (keyToMarkdown opts) refs >>= return . vcat -- | Return markdown representation of a reference key. keyToMarkdown :: WriterOptions -> Ref - -> State WriterState Doc + -> MD Doc keyToMarkdown opts (label, (src, tit), attr) = do label' <- inlineListToMarkdown opts label let tit' = if null tit @@ -218,13 +237,13 @@ keyToMarkdown opts (label, (src, tit), attr) = do <> linkAttributes opts attr -- | Return markdown representation of notes. -notesToMarkdown :: WriterOptions -> [[Block]] -> State WriterState Doc +notesToMarkdown :: WriterOptions -> [[Block]] -> MD Doc notesToMarkdown opts notes = mapM (\(num, note) -> noteToMarkdown opts num note) (zip [1..] notes) >>= return . vsep -- | Return markdown representation of a note. -noteToMarkdown :: WriterOptions -> Int -> [Block] -> State WriterState Doc +noteToMarkdown :: WriterOptions -> Int -> [Block] -> MD Doc noteToMarkdown opts num blocks = do contents <- blockListToMarkdown opts blocks let num' = text $ writerIdentifierPrefix opts ++ show num @@ -261,7 +280,7 @@ tableOfContents :: WriterOptions -> [Block] -> Doc tableOfContents opts headers = let opts' = opts { writerIgnoreNotes = True } contents = BulletList $ map (elementToListItem opts) $ hierarchicalize headers - in evalState (blockToMarkdown opts' contents) def + in evalMD (blockToMarkdown opts' contents) def def -- | Converts an Element to a list item for a table of contents, elementToListItem :: WriterOptions -> Element -> [Block] @@ -315,7 +334,7 @@ beginsWithOrderedListMarker str = -- | Convert Pandoc block element to markdown. blockToMarkdown :: WriterOptions -- ^ Options -> Block -- ^ Block element - -> State WriterState Doc + -> MD Doc blockToMarkdown _ Null = return empty blockToMarkdown opts (Div attrs ils) = do contents <- blockListToMarkdown opts ils @@ -327,7 +346,7 @@ blockToMarkdown opts (Div attrs ils) = do blockToMarkdown opts (Plain inlines) = do contents <- inlineListToMarkdown opts inlines -- escape if para starts with ordered list marker - st <- get + isPlain <- asks envPlain let colwidth = if writerWrapText opts == WrapAuto then Just $ writerColumns opts else Nothing @@ -336,7 +355,7 @@ blockToMarkdown opts (Plain inlines) = do | otherwise = x : escapeDelimiter xs escapeDelimiter [] = [] let contents' = if isEnabled Ext_all_symbols_escapable opts && - not (stPlain st) && beginsWithOrderedListMarker rendered + not isPlain && beginsWithOrderedListMarker rendered then text $ escapeDelimiter rendered else contents return $ contents' <> cr @@ -348,14 +367,14 @@ blockToMarkdown opts (Para inlines) = blockToMarkdown opts (RawBlock f str) | f == "markdown" = return $ text str <> text "\n" | f == "html" && isEnabled Ext_raw_html opts = do - plain <- gets stPlain + plain <- asks envPlain return $ if plain then empty else if isEnabled Ext_markdown_attribute opts then text (addMarkdownAttribute str) <> text "\n" else text str <> text "\n" | f `elem` ["latex", "tex"] && isEnabled Ext_raw_tex opts = do - plain <- gets stPlain + plain <- asks envPlain return $ if plain then empty else text str <> text "\n" @@ -363,7 +382,7 @@ blockToMarkdown opts (RawBlock f str) blockToMarkdown opts HorizontalRule = do return $ blankline <> text (replicate (writerColumns opts) '-') <> blankline blockToMarkdown opts (Header level attr inlines) = do - plain <- gets stPlain + plain <- asks envPlain -- we calculate the id that would be used by auto_identifiers -- so we know whether to print an explicit identifier ids <- gets stIds @@ -424,7 +443,7 @@ blockToMarkdown opts (CodeBlock attribs str) = return $ (_,(cls:_),_) -> " " <> text cls _ -> empty blockToMarkdown opts (BlockQuote blocks) = do - plain <- gets stPlain + plain <- asks envPlain -- if we're writing literate haskell, put a space before the bird tracks -- so they won't be interpreted as lhs... let leader = if isEnabled Ext_literate_haskell opts @@ -486,13 +505,8 @@ blockToMarkdown opts (DefinitionList items) = do contents <- inList $ mapM (definitionListItemToMarkdown opts) items return $ cat contents <> blankline -inList :: State WriterState a -> State WriterState a -inList p = do - oldInList <- gets stInList - modify $ \st -> st{ stInList = True } - res <- p - modify $ \st -> st{ stInList = oldInList } - return res +inList :: MD a -> MD a +inList p = local (\env -> env {envInList = True}) p addMarkdownAttribute :: String -> String addMarkdownAttribute s = @@ -503,7 +517,7 @@ addMarkdownAttribute s = x /= "markdown"] _ -> s -pipeTable :: Bool -> [Alignment] -> [Doc] -> [[Doc]] -> State WriterState Doc +pipeTable :: Bool -> [Alignment] -> [Doc] -> [[Doc]] -> MD Doc pipeTable headless aligns rawHeaders rawRows = do let sp = text " " let blockFor AlignLeft x y = lblock (x + 2) (sp <> y) <> lblock 0 empty @@ -532,7 +546,7 @@ pipeTable headless aligns rawHeaders rawRows = do return $ header $$ border $$ body pandocTable :: WriterOptions -> Bool -> [Alignment] -> [Double] - -> [Doc] -> [[Doc]] -> State WriterState Doc + -> [Doc] -> [[Doc]] -> MD Doc pandocTable opts headless aligns widths rawHeaders rawRows = do let isSimple = all (==0) widths let alignHeader alignment = case alignment of @@ -572,7 +586,7 @@ pandocTable opts headless aligns widths rawHeaders rawRows = do return $ head'' $$ underline $$ body $$ bottom gridTable :: WriterOptions -> Bool -> [Alignment] -> [Double] - -> [Doc] -> [[Doc]] -> State WriterState Doc + -> [Doc] -> [[Doc]] -> MD Doc gridTable opts headless _aligns widths headers' rawRows = do let numcols = length headers' let widths' = if all (==0) widths @@ -599,7 +613,7 @@ gridTable opts headless _aligns widths headers' rawRows = do return $ border '-' $$ head'' $$ body $$ border '-' -- | Convert bullet list item (list of blocks) to markdown. -bulletListItemToMarkdown :: WriterOptions -> [Block] -> State WriterState Doc +bulletListItemToMarkdown :: WriterOptions -> [Block] -> MD Doc bulletListItemToMarkdown opts items = do contents <- blockListToMarkdown opts items let sps = replicate (writerTabStop opts - 2) ' ' @@ -617,7 +631,7 @@ bulletListItemToMarkdown opts items = do orderedListItemToMarkdown :: WriterOptions -- ^ options -> String -- ^ list item marker -> [Block] -- ^ list item (list of blocks) - -> State WriterState Doc + -> MD Doc orderedListItemToMarkdown opts marker items = do contents <- blockListToMarkdown opts items let sps = case length marker - writerTabStop opts of @@ -629,15 +643,15 @@ orderedListItemToMarkdown opts marker items = do -- | Convert definition list item (label, list of blocks) to markdown. definitionListItemToMarkdown :: WriterOptions -> ([Inline],[[Block]]) - -> State WriterState Doc + -> MD Doc definitionListItemToMarkdown opts (label, defs) = do labelText <- inlineListToMarkdown opts label defs' <- mapM (mapM (blockToMarkdown opts)) defs if isEnabled Ext_definition_lists opts then do let tabStop = writerTabStop opts - st <- get - let leader = if stPlain st then " " else ": " + isPlain <- asks envPlain + let leader = if isPlain then " " else ": " let sps = case writerTabStop opts - 3 of n | n > 0 -> text $ replicate n ' ' _ -> text " " @@ -661,7 +675,7 @@ definitionListItemToMarkdown opts (label, defs) = do -- | Convert list of Pandoc block elements to markdown. blockListToMarkdown :: WriterOptions -- ^ Options -> [Block] -- ^ List of block elements - -> State WriterState Doc + -> MD Doc blockListToMarkdown opts blocks = mapM (blockToMarkdown opts) (fixBlocks blocks) >>= return . cat -- insert comment between list and indented code block, or the @@ -688,7 +702,7 @@ blockListToMarkdown opts blocks = -- | Get reference for target; if none exists, create unique one and return. -- Prefer label if possible; otherwise, generate a unique key. -getReference :: Attr -> [Inline] -> Target -> State WriterState [Inline] +getReference :: Attr -> [Inline] -> Target -> MD [Inline] getReference attr label target = do st <- get case find (\(_,t,a) -> t == target && a == attr) (stRefs st) of @@ -706,9 +720,9 @@ getReference attr label target = do return label' -- | Convert list of Pandoc inline elements to markdown. -inlineListToMarkdown :: WriterOptions -> [Inline] -> State WriterState Doc +inlineListToMarkdown :: WriterOptions -> [Inline] -> MD Doc inlineListToMarkdown opts lst = do - inlist <- gets stInList + inlist <- asks envInList go (if inlist then avoidBadWrapsInList lst else lst) where go [] = return empty go (i:is) = case i of @@ -731,9 +745,9 @@ inlineListToMarkdown opts lst = do _ -> shortcutable where shortcutable = liftM2 (<>) (inlineToMarkdown opts i) (go is) unshortcutable = do - iMark <- withState (\s -> s { stRefShortcutable = False }) - (inlineToMarkdown opts i) - modify (\s -> s {stRefShortcutable = True }) + iMark <- local + (\env -> env { envRefShortcutable = False }) + (inlineToMarkdown opts i) fmap (iMark <>) (go is) isSp :: Inline -> Bool @@ -773,22 +787,22 @@ escapeSpaces SoftBreak = Str "\\ " escapeSpaces x = x -- | Convert Pandoc inline element to markdown. -inlineToMarkdown :: WriterOptions -> Inline -> State WriterState Doc +inlineToMarkdown :: WriterOptions -> Inline -> MD Doc inlineToMarkdown opts (Span attrs ils) = do - plain <- gets stPlain + plain <- asks envPlain contents <- inlineListToMarkdown opts ils return $ if not plain && (isEnabled Ext_raw_html opts || isEnabled Ext_native_spans opts) then tagWithAttrs "span" attrs <> contents <> text "</span>" else contents inlineToMarkdown opts (Emph lst) = do - plain <- gets stPlain + plain <- asks envPlain contents <- inlineListToMarkdown opts lst return $ if plain then "_" <> contents <> "_" else "*" <> contents <> "*" inlineToMarkdown opts (Strong lst) = do - plain <- gets stPlain + plain <- asks envPlain if plain then inlineListToMarkdown opts $ capitalize lst else do @@ -827,7 +841,7 @@ inlineToMarkdown opts (Subscript lst) = do _ -> contents where toSubscript c = chr (0x2080 + (ord c - 48)) inlineToMarkdown opts (SmallCaps lst) = do - plain <- gets stPlain + plain <- asks envPlain if not plain && (isEnabled Ext_raw_html opts || isEnabled Ext_native_spans opts) then do @@ -852,13 +866,13 @@ inlineToMarkdown opts (Code attr str) = do let attrs = if isEnabled Ext_inline_code_attributes opts && attr /= nullAttr then attrsToMarkdown attr else empty - plain <- gets stPlain + plain <- asks envPlain if plain then return $ text str else return $ text (marker ++ spacer ++ str ++ spacer ++ marker) <> attrs inlineToMarkdown opts (Str str) = do - st <- get - if stPlain st + isPlain <- asks envPlain + if isPlain then return $ text str else return $ text $ escapeString opts str inlineToMarkdown opts (Math InlineMath str) = @@ -873,7 +887,7 @@ inlineToMarkdown opts (Math InlineMath str) = | isEnabled Ext_tex_math_double_backslash opts -> return $ "\\\\(" <> text str <> "\\\\)" | otherwise -> do - plain <- gets stPlain + plain <- asks envPlain inlineListToMarkdown opts $ (if plain then makeMathPlainer else id) $ texMathToInlines InlineMath str @@ -887,7 +901,7 @@ inlineToMarkdown opts (Math DisplayMath str) | otherwise = (\x -> cr <> x <> cr) `fmap` inlineListToMarkdown opts (texMathToInlines DisplayMath str) inlineToMarkdown opts (RawInline f str) = do - plain <- gets stPlain + plain <- asks envPlain if not plain && ( f == "markdown" || (isEnabled Ext_raw_tex opts && (f == "latex" || f == "tex")) || @@ -895,7 +909,7 @@ inlineToMarkdown opts (RawInline f str) = do then return $ text str else return empty inlineToMarkdown opts (LineBreak) = do - plain <- gets stPlain + plain <- asks envPlain if plain || isEnabled Ext_hard_line_breaks opts then return cr else return $ @@ -944,7 +958,7 @@ inlineToMarkdown opts lnk@(Link attr txt (src, tit)) attr /= nullAttr = -- use raw HTML return $ text $ trim $ writeHtmlString def $ Pandoc nullMeta [Plain [lnk]] | otherwise = do - plain <- gets stPlain + plain <- asks envPlain linktext <- inlineListToMarkdown opts txt let linktitle = if null tit then empty @@ -955,7 +969,7 @@ inlineToMarkdown opts lnk@(Link attr txt (src, tit)) [Str s] | escapeURI s == srcSuffix -> True _ -> False let useRefLinks = writerReferenceLinks opts && not useAuto - shortcutable <- gets stRefShortcutable + shortcutable <- asks envRefShortcutable let useShortcutRefLinks = shortcutable && isEnabled Ext_shortcut_reference_links opts ref <- if useRefLinks then getReference attr txt (src, tit) else return [] @@ -983,7 +997,7 @@ inlineToMarkdown opts img@(Image attr alternate (source, tit)) attr /= nullAttr = -- use raw HTML return $ text $ trim $ writeHtmlString def $ Pandoc nullMeta [Plain [img]] | otherwise = do - plain <- gets stPlain + plain <- asks envPlain let txt = if null alternate || alternate == [Str source] -- to prevent autolinks then [Str ""] |