{-# LANGUAGE OverloadedStrings, TupleSections, ScopedTypeVariables #-} {- Copyright (C) 2006-2015 John MacFarlane 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 the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA -} {- | Module : Text.Pandoc.Writers.Markdown Copyright : Copyright (C) 2006-2015 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane Stability : alpha Portability : portable Conversion of 'Pandoc' documents to markdown-formatted plain text. Markdown: -} module Text.Pandoc.Writers.Markdown (writeMarkdown, writePlain) where import Text.Pandoc.Definition import Text.Pandoc.Walk import Text.Pandoc.Templates (renderTemplate') import Text.Pandoc.Shared import Text.Pandoc.Writers.Shared import Text.Pandoc.Options import Text.Pandoc.Parsing hiding (blankline, blanklines, char, space) import Data.Maybe (fromMaybe) import Data.List ( group, stripPrefix, find, intersperse, transpose, sortBy ) import Data.Char ( isSpace, isPunctuation ) import Data.Ord ( comparing ) import Text.Pandoc.Pretty import Control.Monad.State import Text.Pandoc.Writers.HTML (writeHtmlString) import Text.Pandoc.Readers.TeXMath (texMathToInlines) import Text.HTML.TagSoup (parseTags, isTagText, Tag(..)) import Network.URI (isURI) import Data.Default import Data.Yaml (Value(Object,String,Array,Bool,Number)) import qualified Data.HashMap.Strict as H import qualified Data.Vector as V import qualified Data.Text as T type Notes = [[Block]] type Ref = ([Inline], Target, Attr) type Refs = [Ref] data WriterState = WriterState { stNotes :: Notes , stRefs :: Refs , stRefShortcutable :: Bool , stInList :: Bool , stIds :: [String] , stPlain :: Bool } instance Default WriterState where def = WriterState{ stNotes = [], stRefs = [], stRefShortcutable = True, stInList = False, stIds = [], stPlain = False } -- | Convert Pandoc to Markdown. writeMarkdown :: WriterOptions -> Pandoc -> String writeMarkdown opts document = evalState (pandocToMarkdown opts{ writerWrapText = writerWrapText opts && not (isEnabled Ext_hard_line_breaks opts) } document) 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 } pandocTitleBlock :: Doc -> [Doc] -> Doc -> Doc pandocTitleBlock tit auths dat = hang 2 (text "% ") tit <> cr <> hang 2 (text "% ") (vcat $ map nowrap auths) <> cr <> hang 2 (text "% ") dat <> cr mmdTitleBlock :: Value -> Doc mmdTitleBlock (Object hashmap) = vcat $ map go $ sortBy (comparing fst) $ H.toList hashmap where go (k,v) = case (text (T.unpack k), v) of (k', Array vec) | V.null vec -> empty | otherwise -> k' <> ":" <> space <> hcat (intersperse "; " (map fromstr $ V.toList vec)) (_, String "") -> empty (k', x) -> k' <> ":" <> space <> nest 2 (fromstr x) fromstr (String s) = text (removeBlankLines $ T.unpack s) fromstr (Bool b) = text (show b) fromstr (Number n) = text (show n) fromstr _ = empty -- blank lines not allowed in MMD metadata - we replace with . removeBlankLines = trimr . unlines . map (\x -> if all isSpace x then "." else x) . lines mmdTitleBlock _ = empty plainTitleBlock :: Doc -> [Doc] -> Doc -> Doc plainTitleBlock tit auths dat = tit <> cr <> (hcat (intersperse (text "; ") auths)) <> cr <> dat <> cr yamlMetadataBlock :: Value -> Doc yamlMetadataBlock v = "---" $$ (jsonToYaml v) $$ "..." jsonToYaml :: Value -> Doc jsonToYaml (Object hashmap) = vcat $ map (\(k,v) -> case (text (T.unpack k), v, jsonToYaml v) of (k', Array vec, x) | V.null vec -> empty | otherwise -> (k' <> ":") $$ x (k', Object _, x) -> (k' <> ":") $$ nest 2 x (_, String "", _) -> empty (k', _, x) -> k' <> ":" <> space <> hang 2 "" x) $ sortBy (comparing fst) $ H.toList hashmap jsonToYaml (Array vec) = vcat $ map (\v -> hang 2 "- " (jsonToYaml v)) $ V.toList vec jsonToYaml (String "") = empty jsonToYaml (String s) = case T.unpack s of x | '\n' `elem` x -> hang 2 ("|" <> cr) $ text x | not (any isPunctuation x) -> text x | otherwise -> text $ "'" ++ substitute "'" "''" x ++ "'" jsonToYaml (Bool b) = text $ show b jsonToYaml (Number n) = text $ show n jsonToYaml _ = empty -- | Return markdown representation of document. pandocToMarkdown :: WriterOptions -> Pandoc -> State WriterState String pandocToMarkdown opts (Pandoc meta blocks) = do let colwidth = if writerWrapText opts then Just $ writerColumns opts else Nothing isPlain <- gets stPlain metadata <- metaToJSON opts (fmap (render colwidth) . blockListToMarkdown opts) (fmap (render colwidth) . inlineListToMarkdown opts) meta let title' = maybe empty text $ getField "title" metadata let authors' = maybe [] (map text) $ getField "author" metadata let date' = maybe empty text $ getField "date" metadata let titleblock = case writerStandalone opts of True | isPlain -> plainTitleBlock title' authors' date' | isEnabled Ext_yaml_metadata_block opts -> yamlMetadataBlock metadata | isEnabled Ext_pandoc_title_block opts -> pandocTitleBlock title' authors' date' | isEnabled Ext_mmd_title_block opts -> mmdTitleBlock metadata | otherwise -> empty False -> empty let headerBlocks = filter isHeaderBlock blocks let toc = if writerTableOfContents opts then tableOfContents opts headerBlocks else empty -- Strip off final 'references' header if markdown citations enabled let blocks' = if isEnabled Ext_citations opts then case reverse blocks of (Div (_,["references"],_) _):xs -> reverse xs _ -> blocks else blocks body <- blockListToMarkdown opts blocks' st <- get notes' <- notesToMarkdown opts (reverse $ stNotes st) st' <- get -- note that the notes may contain refs refs' <- refsToMarkdown opts (reverse $ stRefs st') let render' :: Doc -> String render' = render colwidth let main = render' $ body <> (if isEmpty notes' then empty else blankline <> notes') <> (if isEmpty refs' then empty else blankline <> refs') let context = defField "toc" (render' toc) $ defField "body" main $ (if isNullMeta meta then id else defField "titleblock" (render' titleblock)) $ metadata if writerStandalone opts then return $ renderTemplate' (writerTemplate opts) context else return main -- | Return markdown representation of reference key table. refsToMarkdown :: WriterOptions -> Refs -> State WriterState Doc refsToMarkdown opts refs = mapM (keyToMarkdown opts) refs >>= return . vcat -- | Return markdown representation of a reference key. keyToMarkdown :: WriterOptions -> Ref -> State WriterState Doc keyToMarkdown opts (label, (src, tit), attr) = do label' <- inlineListToMarkdown opts label let tit' = if null tit then empty else space <> "\"" <> text tit <> "\"" return $ nest 2 $ hang 2 ("[" <> label' <> "]:" <> space) (text src <> tit') <> linkAttributes opts attr -- | Return markdown representation of notes. notesToMarkdown :: WriterOptions -> [[Block]] -> State WriterState 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 opts num blocks = do contents <- blockListToMarkdown opts blocks let num' = text $ writerIdentifierPrefix opts ++ show num let marker = if isEnabled Ext_footnotes opts then text "[^" <> num' <> text "]:" else 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 -- | Escape special characters for Markdown. escapeString :: WriterOptions -> String -> String escapeString opts = escapeStringUsing markdownEscapes where markdownEscapes = ('<', "<") : ('>', ">") : backslashEscapes specialChars specialChars = (if isEnabled Ext_superscript opts then ('^':) else id) . (if isEnabled Ext_subscript opts then ('~':) else id) . (if isEnabled Ext_tex_math_dollars opts then ('$':) else id) $ "\\`*_[]#" -- | Construct table of contents from list of header blocks. 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 -- | Converts an Element to a list item for a table of contents, elementToListItem :: WriterOptions -> Element -> [Block] elementToListItem opts (Sec lev _ _ headerText subsecs) = Plain headerText : [ BulletList (map (elementToListItem opts) subsecs) | not (null subsecs) && lev < writerTOCDepth opts ] elementToListItem _ (Blk _) = [] attrsToMarkdown :: Attr -> Doc attrsToMarkdown attribs = braces $ hsep [attribId, attribClasses, attribKeys] where attribId = case attribs of ([],_,_) -> empty (i,_,_) -> "#" <> text i attribClasses = case attribs of (_,[],_) -> empty (_,cs,_) -> hsep $ map (text . ('.':)) cs attribKeys = case attribs of (_,_,[]) -> empty (_,_,ks) -> hsep $ map (\(k,v) -> text k <> "=\"" <> text v <> "\"") ks linkAttributes :: WriterOptions -> Attr -> Doc linkAttributes opts attr = if isEnabled Ext_common_link_attributes opts && attr /= nullAttr then attrsToMarkdown attr else empty -- | Ordered list start parser for use in Para below. olMarker :: Parser [Char] ParserState Char olMarker = do (start, style', delim) <- anyOrderedListMarker if delim == Period && (style' == UpperAlpha || (style' == UpperRoman && start `elem` [1, 5, 10, 50, 100, 500, 1000])) then spaceChar >> spaceChar else spaceChar -- | True if string begins with an ordered list marker beginsWithOrderedListMarker :: String -> Bool beginsWithOrderedListMarker str = case runParser olMarker defaultParserState "para start" (take 10 str) of Left _ -> False Right _ -> True -- | Convert Pandoc block element to markdown. blockToMarkdown :: WriterOptions -- ^ Options -> Block -- ^ Block element -> State WriterState Doc blockToMarkdown _ Null = return empty blockToMarkdown opts (Div attrs ils) = do contents <- blockListToMarkdown opts ils return $ if isEnabled Ext_raw_html opts && isEnabled Ext_markdown_in_html_blocks opts then tagWithAttrs "div" attrs <> blankline <> contents <> blankline <> "" <> blankline else contents <> blankline blockToMarkdown opts (Plain inlines) = do contents <- inlineListToMarkdown opts inlines -- escape if para starts with ordered list marker st <- get let colwidth = if writerWrapText opts then Just $ writerColumns opts else Nothing let rendered = render colwidth contents let escapeDelimiter (x:xs) | x `elem` (".()" :: String) = '\\':x:xs | otherwise = x : escapeDelimiter xs escapeDelimiter [] = [] let contents' = if isEnabled Ext_all_symbols_escapable opts && not (stPlain st) && beginsWithOrderedListMarker rendered then text $ escapeDelimiter rendered else contents return $ contents' <> cr -- title beginning with fig: indicates figure blockToMarkdown opts (Para [Image attr alt (src,'f':'i':'g':':':tit)]) = blockToMarkdown opts (Para [Image attr alt (src,tit)]) blockToMarkdown opts (Para inlines) = (<> blankline) `fmap` blockToMarkdown opts (Plain inlines) blockToMarkdown opts (RawBlock f str) | f == "html" = do plain <- gets stPlain 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", "markdown"] = do plain <- gets stPlain return $ if plain then empty else text str <> text "\n" blockToMarkdown _ (RawBlock _ _) = return empty blockToMarkdown opts HorizontalRule = do return $ blankline <> text (replicate (writerColumns opts) '-') <> blankline blockToMarkdown opts (Header level attr inlines) = do plain <- gets stPlain -- we calculate the id that would be used by auto_identifiers -- so we know whether to print an explicit identifier ids <- gets stIds let autoId = uniqueIdent inlines ids modify $ \st -> st{ stIds = autoId : ids } let attr' = case attr of ("",[],[]) -> empty (id',[],[]) | isEnabled Ext_auto_identifiers opts && id' == autoId -> empty (id',_,_) | isEnabled Ext_mmd_header_identifiers opts -> space <> brackets (text id') _ | isEnabled Ext_header_attributes opts -> space <> attrsToMarkdown attr | otherwise -> empty contents <- inlineListToMarkdown opts $ if level == 1 && plain then capitalize inlines else inlines let setext = writerSetextHeaders opts return $ nowrap $ case level of 1 | plain -> blanklines 3 <> contents <> blanklines 2 | setext -> contents <> attr' <> cr <> text (replicate (offset contents) '=') <> blankline 2 | plain -> blanklines 2 <> contents <> blankline | setext -> contents <> attr' <> cr <> text (replicate (offset contents) '-') <> blankline -- ghc interprets '#' characters in column 1 as linenum specifiers. _ | plain || isEnabled Ext_literate_haskell opts -> contents <> blankline _ -> text (replicate level '#') <> space <> contents <> attr' <> blankline blockToMarkdown opts (CodeBlock (_,classes,_) str) | "haskell" `elem` classes && "literate" `elem` classes && isEnabled Ext_literate_haskell opts = return $ prefixed "> " (text str) <> blankline blockToMarkdown opts (CodeBlock attribs str) = return $ case attribs == nullAttr of False | isEnabled Ext_backtick_code_blocks opts -> backticks <> attrs <> cr <> text str <> cr <> backticks <> blankline | isEnabled Ext_fenced_code_blocks opts -> tildes <> attrs <> cr <> text str <> cr <> tildes <> blankline _ -> nest (writerTabStop opts) (text str) <> blankline where tildes = text $ case [ln | ln <- lines str, all (=='~') ln] of [] -> "~~~~" xs -> case maximum $ map length xs of n | n < 3 -> "~~~~" | otherwise -> replicate (n+1) '~' backticks = text $ case [ln | ln <- lines str, all (=='`') ln] of [] -> "```" xs -> case maximum $ map length xs of n | n < 3 -> "```" | otherwise -> replicate (n+1) '`' attrs = if isEnabled Ext_fenced_code_attributes opts then nowrap $ " " <> attrsToMarkdown attribs else case attribs of (_,(cls:_),_) -> " " <> text cls _ -> empty blockToMarkdown opts (BlockQuote blocks) = do plain <- gets stPlain -- 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 then " > " else if plain then " " else "> " contents <- blockListToMarkdown opts blocks return $ (prefixed leader contents) <> blankline blockToMarkdown opts t@(Table caption aligns widths headers rows) = do caption' <- inlineListToMarkdown opts caption let caption'' = if null caption || not (isEnabled Ext_table_captions opts) then empty else blankline <> ": " <> caption' <> blankline rawHeaders <- mapM (blockListToMarkdown opts) headers rawRows <- mapM (mapM (blockListToMarkdown opts)) rows let isSimple = all (==0) widths let isPlainBlock (Plain _) = True isPlainBlock _ = False let hasBlocks = not (all isPlainBlock $ concat . concat $ headers:rows) (nst,tbl) <- case True of _ | isSimple && isEnabled Ext_simple_tables opts -> fmap (nest 2,) $ pandocTable opts (all null headers) aligns widths rawHeaders rawRows | isSimple && isEnabled Ext_pipe_tables opts -> fmap (id,) $ pipeTable (all null headers) aligns rawHeaders rawRows | not hasBlocks && isEnabled Ext_multiline_tables opts -> fmap (nest 2,) $ pandocTable opts (all null headers) aligns widths rawHeaders rawRows | isEnabled Ext_grid_tables opts -> fmap (id,) $ gridTable opts (all null headers) aligns widths rawHeaders rawRows | otherwise -> fmap (id,) $ return $ text $ writeHtmlString def $ Pandoc nullMeta [t] return $ nst $ tbl $$ blankline $$ caption'' $$ blankline blockToMarkdown opts (BulletList items) = do contents <- inList $ mapM (bulletListItemToMarkdown opts) items return $ cat contents <> blankline blockToMarkdown opts (OrderedList (start,sty,delim) items) = do let start' = if isEnabled Ext_startnum opts then start else 1 let sty' = if isEnabled Ext_fancy_lists opts then sty else DefaultStyle let delim' = if isEnabled Ext_fancy_lists opts then delim else DefaultDelim let attribs = (start', sty', delim') let markers = orderedListMarkers attribs let markers' = map (\m -> if length m < 3 then m ++ replicate (3 - length m) ' ' else m) markers contents <- inList $ mapM (\(item, num) -> orderedListItemToMarkdown opts item num) $ zip markers' items return $ cat contents <> blankline 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 addMarkdownAttribute :: String -> String addMarkdownAttribute s = case span isTagText $ reverse $ parseTags s of (xs,(TagOpen t attrs:rest)) -> renderTags' $ reverse rest ++ (TagOpen t attrs' : reverse xs) where attrs' = ("markdown","1"):[(x,y) | (x,y) <- attrs, x /= "markdown"] _ -> s pipeTable :: Bool -> [Alignment] -> [Doc] -> [[Doc]] -> State WriterState Doc pipeTable headless aligns rawHeaders rawRows = do let sp = text " " let blockFor AlignLeft x y = lblock (x + 2) (sp <> y) <> lblock 0 empty blockFor AlignCenter x y = cblock (x + 2) (sp <> y) <> lblock 0 empty blockFor AlignRight x y = rblock (x + 2) (sp <> y) <> lblock 0 empty blockFor _ x y = lblock (x + 2) (sp <> y) <> lblock 0 empty let widths = map (max 3 . maximum . map offset) $ transpose (rawHeaders : rawRows) let torow cs = nowrap $ text "|" <> hcat (intersperse (text "|") $ zipWith3 blockFor aligns widths (map chomp cs)) <> text "|" let toborder (a, w) = text $ case a of AlignLeft -> ':':replicate (w + 1) '-' AlignCenter -> ':':replicate w '-' ++ ":" AlignRight -> replicate (w + 1) '-' ++ ":" AlignDefault -> replicate (w + 2) '-' -- note: pipe tables can't completely lack a -- header; for a headerless table, we need a header of empty cells. -- see jgm/pandoc#1996. let header = if headless then torow (replicate (length aligns) empty) else torow rawHeaders let border = nowrap $ text "|" <> hcat (intersperse (text "|") $ map toborder $ zip aligns widths) <> text "|" let body = vcat $ map torow rawRows return $ header $$ border $$ body pandocTable :: WriterOptions -> Bool -> [Alignment] -> [Double] -> [Doc] -> [[Doc]] -> State WriterState Doc pandocTable opts headless aligns widths rawHeaders rawRows = do let isSimple = all (==0) widths let alignHeader alignment = case alignment of AlignLeft -> lblock AlignCenter -> cblock AlignRight -> rblock AlignDefault -> lblock let numChars = maximum . map offset let widthsInChars = if isSimple then map ((+2) . numChars) $ transpose (rawHeaders : rawRows) else map (floor . (fromIntegral (writerColumns opts) *)) widths let makeRow = hcat . intersperse (lblock 1 (text " ")) . (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 head'' = if headless then empty else border <> cr <> head' let body = if maxRowHeight > 1 then vsep rows' else vcat rows' let bottom = if headless then underline 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 markdown. bulletListItemToMarkdown :: WriterOptions -> [Block] -> State WriterState Doc bulletListItemToMarkdown opts items = do contents <- blockListToMarkdown opts items let sps = replicate (writerTabStop opts - 2) ' ' let start = text ('-' : ' ' : sps) -- remove trailing blank line if it is a tight list let contents' = case reverse items of (BulletList xs:_) | isTightList xs -> chomp contents <> cr (OrderedList _ xs:_) | isTightList xs -> chomp contents <> cr _ -> contents return $ hang (writerTabStop opts) start $ contents' <> cr -- | Convert ordered list item (a list of blocks) to markdown. orderedListItemToMarkdown :: WriterOptions -- ^ options -> String -- ^ list item marker -> [Block] -- ^ list item (list of blocks) -> State WriterState Doc orderedListItemToMarkdown opts marker items = do contents <- blockListToMarkdown opts items let sps = case length marker - writerTabStop opts of n | n > 0 -> text $ replicate n ' ' _ -> text " " let start = text marker <> sps return $ hang (writerTabStop opts) start $ contents <> cr -- | Convert definition list item (label, list of blocks) to markdown. definitionListItemToMarkdown :: WriterOptions -> ([Inline],[[Block]]) -> State WriterState 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 ": " let sps = case writerTabStop opts - 3 of n | n > 0 -> text $ replicate n ' ' _ -> text " " if isEnabled Ext_compact_definition_lists opts then do let contents = vcat $ map (\d -> hang tabStop (leader <> sps) $ vcat d <> cr) defs' return $ nowrap labelText <> cr <> contents <> cr else do let contents = vcat $ map (\d -> hang tabStop (leader <> sps) $ vcat d <> cr) defs' let isTight = case defs of ((Plain _ : _): _) -> True _ -> False return $ blankline <> nowrap labelText <> (if isTight then cr else blankline) <> contents <> blankline else do return $ nowrap labelText <> text " " <> cr <> vsep (map vsep defs') <> blankline -- | Convert list of Pandoc block elements to markdown. blockListToMarkdown :: WriterOptions -- ^ Options -> [Block] -- ^ List of block elements -> State WriterState Doc blockListToMarkdown opts blocks = mapM (blockToMarkdown opts) (fixBlocks blocks) >>= return . cat -- insert comment between list and indented code block, or the -- code block will be treated as a list continuation paragraph where fixBlocks (b : CodeBlock attr x : rest) | (not (isEnabled Ext_fenced_code_blocks opts) || attr == nullAttr) && isListBlock b = b : commentSep : CodeBlock attr x : fixBlocks rest fixBlocks (b1@(BulletList _) : b2@(BulletList _) : bs) = b1 : commentSep : fixBlocks (b2:bs) fixBlocks (b1@(OrderedList _ _) : b2@(OrderedList _ _) : bs) = b1 : commentSep : fixBlocks (b2:bs) fixBlocks (b1@(DefinitionList _) : b2@(DefinitionList _) : bs) = b1 : commentSep : fixBlocks (b2:bs) fixBlocks (x : xs) = x : fixBlocks xs fixBlocks [] = [] isListBlock (BulletList _) = True isListBlock (OrderedList _ _) = True isListBlock (DefinitionList _) = True isListBlock _ = False commentSep = RawBlock "html" "\n" -- | 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 label target = do st <- get case find (\(_,t,a) -> t == target && a == attr) (stRefs st) of Just (ref, _, _) -> return ref Nothing -> do let label' = case find (\(l,_,_) -> l == label) (stRefs st) of Just _ -> -- label is used; generate numerical label case find (\n -> notElem [Str (show n)] (map (\(l,_,_) -> l) (stRefs st))) [1..(10000 :: Integer)] of Just x -> [Str (show x)] Nothing -> error "no unique label" Nothing -> label modify (\s -> s{ stRefs = (label', target, attr) : stRefs st }) return label' -- | Convert list of Pandoc inline elements to markdown. inlineListToMarkdown :: WriterOptions -> [Inline] -> State WriterState Doc inlineListToMarkdown opts lst = do inlist <- gets stInList go (if inlist then avoidBadWrapsInList lst else lst) where go [] = return empty go (i:is) = case i of (Link _ _ _) -> case is of -- If a link is followed by another link or '[' we don't shortcut (Link _ _ _):_ -> unshortcutable Space:(Link _ _ _):_ -> unshortcutable Space:(Str('[':_)):_ -> unshortcutable Space:(RawInline _ ('[':_)):_ -> unshortcutable Space:(Cite _ _):_ -> unshortcutable (Cite _ _):_ -> unshortcutable Str ('[':_):_ -> unshortcutable (RawInline _ ('[':_)):_ -> unshortcutable (RawInline _ (' ':'[':_)):_ -> unshortcutable _ -> shortcutable _ -> 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 }) fmap (iMark <>) (go is) avoidBadWrapsInList :: [Inline] -> [Inline] avoidBadWrapsInList [] = [] avoidBadWrapsInList (Space:Str ('>':cs):xs) = Str (' ':'>':cs) : avoidBadWrapsInList xs avoidBadWrapsInList (Space:Str [c]:[]) | c `elem` ['-','*','+'] = Str [' ', c] : [] avoidBadWrapsInList (Space:Str [c]:Space:xs) | c `elem` ['-','*','+'] = Str [' ', c] : Space : avoidBadWrapsInList xs avoidBadWrapsInList (Space:Str cs:Space:xs) | isOrderedListMarker cs = Str (' ':cs) : Space : avoidBadWrapsInList xs avoidBadWrapsInList (Space:Str cs:[]) | isOrderedListMarker cs = Str (' ':cs) : [] avoidBadWrapsInList (x:xs) = x : avoidBadWrapsInList xs isOrderedListMarker :: String -> Bool isOrderedListMarker xs = (last xs `elem` ['.',')']) && isRight (runParserT (anyOrderedListMarker >> eof) defaultParserState "" xs) isRight :: Either a b -> Bool isRight (Right _) = True isRight (Left _) = False escapeSpaces :: Inline -> Inline escapeSpaces (Str s) = Str $ substitute " " "\\ " s escapeSpaces Space = Str "\\ " escapeSpaces x = x -- | Convert Pandoc inline element to markdown. inlineToMarkdown :: WriterOptions -> Inline -> State WriterState Doc inlineToMarkdown opts (Span attrs ils) = do plain <- gets stPlain contents <- inlineListToMarkdown opts ils return $ if not plain && (isEnabled Ext_raw_html opts || isEnabled Ext_native_spans opts) then tagWithAttrs "span" attrs <> contents <> text "" else contents inlineToMarkdown opts (Emph lst) = do plain <- gets stPlain contents <- inlineListToMarkdown opts lst return $ if plain then "_" <> contents <> "_" else "*" <> contents <> "*" inlineToMarkdown opts (Strong lst) = do plain <- gets stPlain if plain then inlineListToMarkdown opts $ capitalize lst else do contents <- inlineListToMarkdown opts lst return $ "**" <> contents <> "**" inlineToMarkdown opts (Strikeout lst) = do contents <- inlineListToMarkdown opts lst return $ if isEnabled Ext_strikeout opts then "~~" <> contents <> "~~" else if isEnabled Ext_raw_html opts then "" <> contents <> "" else contents inlineToMarkdown opts (Superscript lst) = do contents <- inlineListToMarkdown opts $ walk escapeSpaces lst return $ if isEnabled Ext_superscript opts then "^" <> contents <> "^" else if isEnabled Ext_raw_html opts then "" <> contents <> "" else contents inlineToMarkdown opts (Subscript lst) = do contents <- inlineListToMarkdown opts $ walk escapeSpaces lst return $ if isEnabled Ext_subscript opts then "~" <> contents <> "~" else if isEnabled Ext_raw_html opts then "" <> contents <> "" else contents inlineToMarkdown opts (SmallCaps lst) = do plain <- gets stPlain if not plain && (isEnabled Ext_raw_html opts || isEnabled Ext_native_spans opts) then do contents <- inlineListToMarkdown opts lst return $ tagWithAttrs "span" ("",[],[("style","font-variant:small-caps;")]) <> contents <> text "" else inlineListToMarkdown opts $ capitalize lst inlineToMarkdown opts (Quoted SingleQuote lst) = do contents <- inlineListToMarkdown opts lst return $ "‘" <> contents <> "’" inlineToMarkdown opts (Quoted DoubleQuote lst) = do contents <- inlineListToMarkdown opts lst return $ "“" <> contents <> "”" inlineToMarkdown opts (Code attr str) = do let tickGroups = filter (\s -> '`' `elem` s) $ group str let longest = if null tickGroups then 0 else maximum $ map length tickGroups let marker = replicate (longest + 1) '`' let spacer = if (longest == 0) then "" else " " let attrs = if isEnabled Ext_inline_code_attributes opts && attr /= nullAttr then attrsToMarkdown attr else empty plain <- gets stPlain 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 then return $ text str else return $ text $ escapeString opts str inlineToMarkdown opts (Math InlineMath str) | isEnabled Ext_tex_math_dollars opts = return $ "$" <> text str <> "$" | isEnabled Ext_tex_math_single_backslash opts = return $ "\\(" <> text str <> "\\)" | isEnabled Ext_tex_math_double_backslash opts = return $ "\\\\(" <> text str <> "\\\\)" | otherwise = do plain <- gets stPlain inlineListToMarkdown opts $ (if plain then makeMathPlainer else id) $ texMathToInlines InlineMath str inlineToMarkdown opts (Math DisplayMath str) | isEnabled Ext_tex_math_dollars opts = return $ "$$" <> text str <> "$$" | isEnabled Ext_tex_math_single_backslash opts = return $ "\\[" <> text str <> "\\]" | isEnabled Ext_tex_math_double_backslash opts = return $ "\\\\[" <> text str <> "\\\\]" | otherwise = (\x -> cr <> x <> cr) `fmap` inlineListToMarkdown opts (texMathToInlines DisplayMath str) inlineToMarkdown opts (RawInline f str) = do plain <- gets stPlain if not plain && ( f == "markdown" || (isEnabled Ext_raw_tex opts && (f == "latex" || f == "tex")) || (isEnabled Ext_raw_html opts && f == "html") ) then return $ text str else return empty inlineToMarkdown opts (LineBreak) = do plain <- gets stPlain if plain || isEnabled Ext_hard_line_breaks opts then return cr else return $ if isEnabled Ext_escaped_line_breaks opts then "\\" <> cr else " " <> cr inlineToMarkdown _ Space = return space inlineToMarkdown opts (Cite [] lst) = inlineListToMarkdown opts lst inlineToMarkdown opts (Cite (c:cs) lst) | not (isEnabled Ext_citations opts) = inlineListToMarkdown opts lst | otherwise = if citationMode c == AuthorInText then do suffs <- inlineListToMarkdown opts $ citationSuffix c rest <- mapM convertOne cs let inbr = suffs <+> joincits rest br = if isEmpty inbr then empty else char '[' <> inbr <> char ']' return $ text ("@" ++ citationId c) <+> br else do cits <- mapM convertOne (c:cs) return $ text "[" <> joincits cits <> text "]" where joincits = hcat . intersperse (text "; ") . filter (not . isEmpty) convertOne Citation { citationId = k , citationPrefix = pinlines , citationSuffix = sinlines , citationMode = m } = do pdoc <- inlineListToMarkdown opts pinlines sdoc <- inlineListToMarkdown opts sinlines let k' = text (modekey m ++ "@" ++ k) r = case sinlines of Str (y:_):_ | y `elem` (",;]@" :: String) -> k' <> sdoc _ -> k' <+> sdoc return $ pdoc <+> r modekey SuppressAuthor = "-" modekey _ = "" inlineToMarkdown opts (Link attr txt (src, tit)) = do plain <- gets stPlain linktext <- inlineListToMarkdown opts txt let linktitle = if null tit then empty else text $ " \"" ++ tit ++ "\"" let srcSuffix = fromMaybe src (stripPrefix "mailto:" src) let useAuto = isURI src && case txt of [Str s] | escapeURI s == srcSuffix -> True _ -> False let useRefLinks = writerReferenceLinks opts && not useAuto shortcutable <- gets stRefShortcutable let useShortcutRefLinks = shortcutable && isEnabled Ext_shortcut_reference_links opts ref <- if useRefLinks then getReference attr txt (src, tit) else return [] reftext <- inlineListToMarkdown opts ref return $ if useAuto then if plain then text srcSuffix else "<" <> text srcSuffix <> ">" else if useRefLinks then let first = "[" <> linktext <> "]" second = if txt == ref then if useShortcutRefLinks then "" else "[]" else "[" <> reftext <> "]" in first <> second else if plain then linktext else "[" <> linktext <> "](" <> text src <> linktitle <> ")" <> linkAttributes opts attr inlineToMarkdown opts (Image attr alternate (source, tit)) = do plain <- gets stPlain let txt = if null alternate || alternate == [Str source] -- to prevent autolinks then [Str ""] else alternate linkPart <- inlineToMarkdown opts (Link attr txt (source, tit)) return $ if plain then "[" <> linkPart <> "]" else "!" <> linkPart inlineToMarkdown opts (Note contents) = do modify (\st -> st{ stNotes = contents : stNotes st }) st <- get let ref = text $ writerIdentifierPrefix opts ++ show (length $ stNotes st) if isEnabled Ext_footnotes opts then return $ "[^" <> ref <> "]" else return $ "[" <> ref <> "]" makeMathPlainer :: [Inline] -> [Inline] makeMathPlainer = walk go where go (Emph xs) = Span nullAttr xs go x = x