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.Monoid (Any(..))
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)
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
import qualified Data.Set as Set
import Network.HTTP ( urlEncode )
type Notes = [[Block]]
type Ref = ([Inline], Target, Attr)
type Refs = [Ref]
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
, envBlockLevel :: Int
, envEscapeSpaces :: Bool
}
instance Default WriterEnv
where def = WriterEnv { envInList = False
, envPlain = False
, envRefShortcutable = True
, envBlockLevel = 0
, envEscapeSpaces = False
}
data WriterState = WriterState { stNotes :: Notes
, stRefs :: Refs
, stIds :: Set.Set String
, stNoteNum :: Int
}
instance Default WriterState
where def = WriterState{ stNotes = []
, stRefs = []
, stIds = Set.empty
, stNoteNum = 1
}
writeMarkdown :: WriterOptions -> Pandoc -> String
writeMarkdown opts document =
evalMD (pandocToMarkdown opts{
writerWrapText = if isEnabled Ext_hard_line_breaks opts
then WrapNone
else writerWrapText opts }
document) def def
writePlain :: WriterOptions -> Pandoc -> String
writePlain opts document =
evalMD (pandocToMarkdown opts document) def{ envPlain = True } def
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
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 == "meta-json" -> empty
| otherwise -> 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
pandocToMarkdown :: WriterOptions -> Pandoc -> MD String
pandocToMarkdown opts (Pandoc meta blocks) = do
let colwidth = if writerWrapText opts == WrapAuto
then Just $ writerColumns opts
else Nothing
isPlain <- asks envPlain
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 writerTemplate opts of
Just _ | 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
Nothing -> empty
let headerBlocks = filter isHeaderBlock blocks
let toc = if writerTableOfContents opts
then tableOfContents opts headerBlocks
else empty
let blocks' = if isEnabled Ext_citations opts
then case reverse blocks of
(Div (_,["references"],_) _):xs -> reverse xs
_ -> blocks
else blocks
body <- blockListToMarkdown opts blocks'
notesAndRefs' <- notesAndRefs opts
let render' :: Doc -> String
render' = render colwidth
let main = render' $ body <> notesAndRefs'
let context = defField "toc" (render' toc)
$ defField "body" main
$ (if isNullMeta meta
then id
else defField "titleblock" (render' titleblock))
$ metadata
case writerTemplate opts of
Nothing -> return main
Just tpl -> return $ renderTemplate' tpl context
refsToMarkdown :: WriterOptions -> Refs -> MD Doc
refsToMarkdown opts refs = mapM (keyToMarkdown opts) refs >>= return . vcat
keyToMarkdown :: WriterOptions
-> Ref
-> MD 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
notesToMarkdown :: WriterOptions -> [[Block]] -> MD Doc
notesToMarkdown opts notes = do
n <- gets stNoteNum
notes' <- mapM (\(num, note) -> noteToMarkdown opts num note) (zip [n..] notes)
modify $ \st -> st { stNoteNum = stNoteNum st + length notes }
return $ vsep notes'
noteToMarkdown :: WriterOptions -> Int -> [Block] -> MD 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
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) $
"\\`*_[]#"
tableOfContents :: WriterOptions -> [Block] -> Doc
tableOfContents opts headers =
let opts' = opts { writerIgnoreNotes = True }
contents = BulletList $ map (elementToListItem opts) $ hierarchicalize headers
in evalMD (blockToMarkdown opts' contents) def def
elementToListItem :: WriterOptions -> Element -> [Block]
elementToListItem opts (Sec lev _nums (ident,_,_) headerText subsecs)
= Plain headerLink :
[ BulletList (map (elementToListItem opts) subsecs) |
not (null subsecs) && lev < writerTOCDepth opts ]
where headerLink = if null ident
then headerText
else [Link nullAttr headerText ('#':ident, "")]
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_link_attributes opts && attr /= nullAttr
then attrsToMarkdown attr
else empty
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
beginsWithOrderedListMarker :: String -> Bool
beginsWithOrderedListMarker str =
case runParser olMarker defaultParserState "para start" (take 10 str) of
Left _ -> False
Right _ -> True
notesAndRefs :: WriterOptions -> MD Doc
notesAndRefs opts = do
notes' <- reverse <$> gets stNotes >>= notesToMarkdown opts
modify $ \s -> s { stNotes = [] }
refs' <- reverse <$> gets stRefs >>= refsToMarkdown opts
modify $ \s -> s { stRefs = [] }
let endSpacing =
if | writerReferenceLocation opts == EndOfDocument -> empty
| isEmpty notes' && isEmpty refs' -> empty
| otherwise -> blankline
return $
(if isEmpty notes' then empty else blankline <> notes') <>
(if isEmpty refs' then empty else blankline <> refs') <>
endSpacing
blockToMarkdown :: WriterOptions
-> Block
-> MD Doc
blockToMarkdown opts blk =
local (\env -> env {envBlockLevel = envBlockLevel env + 1}) $
do doc <- blockToMarkdown' opts blk
blkLevel <- asks envBlockLevel
if writerReferenceLocation opts == EndOfBlock && blkLevel == 1
then notesAndRefs opts >>= (\d -> return $ doc <> d)
else return doc
blockToMarkdown' :: WriterOptions
-> Block
-> MD 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 <> "</div>" <> blankline
else contents <> blankline
blockToMarkdown' opts (Plain inlines) = do
contents <- inlineListToMarkdown opts inlines
isPlain <- asks envPlain
let colwidth = if writerWrapText opts == WrapAuto
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 isPlain && beginsWithOrderedListMarker rendered
then text $ escapeDelimiter rendered
else contents
return $ contents' <> cr
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 (LineBlock lns) =
if isEnabled Ext_line_blocks opts
then do
mdLines <- mapM (inlineListToMarkdown opts) lns
return $ (vcat $ map (hang 2 (text "| ")) mdLines) <> blankline
else blockToMarkdown opts $ linesToPara lns
blockToMarkdown' opts (RawBlock f str)
| f == "markdown" = return $ text str <> text "\n"
| f == "html" && isEnabled Ext_raw_html opts = do
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 <- asks envPlain
return $ if plain
then empty
else text str <> text "\n"
| otherwise = return empty
blockToMarkdown' opts HorizontalRule = do
return $ blankline <> text (replicate (writerColumns opts) '-') <> blankline
blockToMarkdown' opts (Header level attr inlines) = do
blkLevel <- asks envBlockLevel
refs <- if writerReferenceLocation opts == EndOfSection && blkLevel == 1
then notesAndRefs opts
else return empty
plain <- asks envPlain
ids <- gets stIds
let autoId = uniqueIdent inlines ids
modify $ \st -> st{ stIds = Set.insert 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
hdr = 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
_ | plain || isEnabled Ext_literate_haskell opts ->
contents <> blankline
_ -> text (replicate level '#') <> space <> contents <> attr' <> blankline
return $ refs <> hdr
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 <- asks envPlain
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 isLineBreak LineBreak = Any True
isLineBreak _ = Any False
let isSimple = all (==0) widths &&
not ( getAny (query isLineBreak (headers:rows)) )
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
| isEnabled Ext_raw_html opts -> fmap (id,) $
return $ text $ writeHtmlString def
$ Pandoc nullMeta [t]
| otherwise -> return $ (id, text "[TABLE]")
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 :: MD a -> MD a
inList p = local (\env -> env {envInList = True}) p
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]] -> MD 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) '-'
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]] -> MD 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 = (+ 2) . maximum . map offset
let minNumChars = (+ 2) . maximum . map minOffset
let columns = transpose (rawHeaders : rawRows)
let noWordWrapWidth
| writerWrapText opts == WrapAuto
= fromIntegral $ maximum (map minNumChars columns)
| otherwise = fromIntegral $ maximum (map numChars columns)
let relWidth w = floor $ max (fromIntegral (writerColumns opts) * w)
(noWordWrapWidth * w / minimum widths)
let widthsInChars
| isSimple = map numChars columns
| otherwise = map relWidth 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]] -> MD 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
((\x -> x 3) . floor . (fromIntegral (writerColumns opts) *)) widths'
let hpipeBlocks blocks = hcat [beg, middle, end]
where h = maximum (1 : 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 borderpart ch align widthInChars =
let widthInChars' = if widthInChars < 1 then 1 else widthInChars
in (if (align == AlignLeft || align == AlignCenter)
then char ':'
else char ch) <>
text (replicate widthInChars' ch) <>
(if (align == AlignRight || align == AlignCenter)
then char ':'
else char ch)
let border ch aligns' widthsInChars' =
char '+' <>
hcat (intersperse (char '+') (zipWith (borderpart ch)
aligns' widthsInChars')) <> char '+'
let body = vcat $ intersperse (border '-' (repeat AlignDefault) widthsInChars)
rows'
let head'' = if headless
then empty
else head' $$ border '=' aligns widthsInChars
if headless
then return $
border '-' aligns widthsInChars $$
body $$
border '-' (repeat AlignDefault) widthsInChars
else return $
border '-' (repeat AlignDefault) widthsInChars $$
head'' $$
body $$
border '-' (repeat AlignDefault) widthsInChars
itemEndsWithTightList :: [Block] -> Bool
itemEndsWithTightList bs =
case bs of
[Plain _, BulletList xs] -> isTightList xs
[Plain _, OrderedList _ xs] -> isTightList xs
_ -> False
bulletListItemToMarkdown :: WriterOptions -> [Block] -> MD Doc
bulletListItemToMarkdown opts bs = do
contents <- blockListToMarkdown opts bs
let sps = replicate (writerTabStop opts 2) ' '
let start = text ('-' : ' ' : sps)
let contents' = if itemEndsWithTightList bs
then chomp contents <> cr
else contents
return $ hang (writerTabStop opts) start $ contents' <> cr
orderedListItemToMarkdown :: WriterOptions
-> String
-> [Block]
-> MD Doc
orderedListItemToMarkdown opts marker bs = do
contents <- blockListToMarkdown opts bs
let sps = case length marker writerTabStop opts of
n | n > 0 -> text $ replicate n ' '
_ -> text " "
let start = text marker <> sps
let contents' = if itemEndsWithTightList bs
then chomp contents <> cr
else contents
return $ hang (writerTabStop opts) start $ contents' <> cr
definitionListItemToMarkdown :: WriterOptions
-> ([Inline],[[Block]])
-> 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
isPlain <- asks envPlain
let leader = if isPlain 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
blockListToMarkdown :: WriterOptions
-> [Block]
-> MD Doc
blockListToMarkdown opts blocks =
mapM (blockToMarkdown opts) (fixBlocks blocks) >>= return . cat
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 = if isEnabled Ext_raw_html opts
then RawBlock "html" "<!-- -->\n"
else RawBlock "markdown" " "
getReference :: Attr -> [Inline] -> Target -> MD [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 _ ->
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'
inlineListToMarkdown :: WriterOptions -> [Inline] -> MD Doc
inlineListToMarkdown opts lst = do
inlist <- asks envInList
go (if inlist then avoidBadWrapsInList lst else lst)
where go [] = return empty
go (i:is) = case i of
(Link _ _ _) -> case is of
(Link _ _ _):_ -> unshortcutable
Space:(Link _ _ _):_ -> unshortcutable
Space:(Str('[':_)):_ -> unshortcutable
Space:(RawInline _ ('[':_)):_ -> unshortcutable
Space:(Cite _ _):_ -> unshortcutable
SoftBreak:(Link _ _ _):_ -> unshortcutable
SoftBreak:(Str('[':_)):_ -> unshortcutable
SoftBreak:(RawInline _ ('[':_)):_ -> unshortcutable
SoftBreak:(Cite _ _):_ -> unshortcutable
(Cite _ _):_ -> unshortcutable
Str ('[':_):_ -> unshortcutable
(RawInline _ ('[':_)):_ -> unshortcutable
(RawInline _ (' ':'[':_)):_ -> unshortcutable
_ -> shortcutable
_ -> shortcutable
where shortcutable = liftM2 (<>) (inlineToMarkdown opts i) (go is)
unshortcutable = do
iMark <- local
(\env -> env { envRefShortcutable = False })
(inlineToMarkdown opts i)
fmap (iMark <>) (go is)
isSp :: Inline -> Bool
isSp Space = True
isSp SoftBreak = True
isSp _ = False
avoidBadWrapsInList :: [Inline] -> [Inline]
avoidBadWrapsInList [] = []
avoidBadWrapsInList (s:Str ('>':cs):xs) | isSp s =
Str (' ':'>':cs) : avoidBadWrapsInList xs
avoidBadWrapsInList (s:Str [c]:[])
| isSp s && c `elem` ['-','*','+'] = Str [' ', c] : []
avoidBadWrapsInList (s:Str [c]:Space:xs)
| isSp s && c `elem` ['-','*','+'] =
Str [' ', c] : Space : avoidBadWrapsInList xs
avoidBadWrapsInList (s:Str cs:Space:xs)
| isSp s && isOrderedListMarker cs =
Str (' ':cs) : Space : avoidBadWrapsInList xs
avoidBadWrapsInList (s:Str cs:[])
| isSp s && isOrderedListMarker cs = Str (' ':cs) : []
avoidBadWrapsInList (x:xs) = x : avoidBadWrapsInList xs
isOrderedListMarker :: String -> Bool
isOrderedListMarker xs = (last xs `elem` ['.',')']) &&
isRight (runParser (anyOrderedListMarker >> eof)
defaultParserState "" xs)
isRight :: Either a b -> Bool
isRight (Right _) = True
isRight (Left _) = False
inlineToMarkdown :: WriterOptions -> Inline -> MD Doc
inlineToMarkdown opts (Span attrs ils) = do
plain <- asks envPlain
contents <- inlineListToMarkdown opts ils
return $ case plain of
True -> contents
False | isEnabled Ext_bracketed_spans opts ->
"[" <> contents <> "]" <>
if attrs == nullAttr
then "{}"
else linkAttributes opts attrs
| isEnabled Ext_raw_html opts ||
isEnabled Ext_native_spans opts ->
tagWithAttrs "span" attrs <> contents <> text "</span>"
| otherwise -> contents
inlineToMarkdown opts (Emph lst) = do
plain <- asks envPlain
contents <- inlineListToMarkdown opts lst
return $ if plain
then "_" <> contents <> "_"
else "*" <> contents <> "*"
inlineToMarkdown opts (Strong lst) = do
plain <- asks envPlain
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 "<s>" <> contents <> "</s>"
else contents
inlineToMarkdown opts (Superscript lst) =
local (\env -> env {envEscapeSpaces = True}) $ do
contents <- inlineListToMarkdown opts lst
return $ if isEnabled Ext_superscript opts
then "^" <> contents <> "^"
else if isEnabled Ext_raw_html opts
then "<sup>" <> contents <> "</sup>"
else case (render Nothing contents) of
ds | all (\d -> d >= '0' && d <= '9') ds
-> text (map toSuperscript ds)
_ -> contents
where toSuperscript '1' = '\x00B9'
toSuperscript '2' = '\x00B2'
toSuperscript '3' = '\x00B3'
toSuperscript c = chr (0x2070 + (ord c 48))
inlineToMarkdown opts (Subscript lst) =
local (\env -> env {envEscapeSpaces = True}) $ do
contents <- inlineListToMarkdown opts lst
return $ if isEnabled Ext_subscript opts
then "~" <> contents <> "~"
else if isEnabled Ext_raw_html opts
then "<sub>" <> contents <> "</sub>"
else case (render Nothing contents) of
ds | all (\d -> d >= '0' && d <= '9') ds
-> text (map toSubscript ds)
_ -> contents
where toSubscript c = chr (0x2080 + (ord c 48))
inlineToMarkdown opts (SmallCaps lst) = do
plain <- asks envPlain
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 "</span>"
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 <- asks envPlain
if plain
then return $ text str
else return $ text (marker ++ spacer ++ str ++ spacer ++ marker) <> attrs
inlineToMarkdown opts (Str str) = do
isPlain <- asks envPlain
if isPlain
then return $ text str
else return $ text $ escapeString opts str
inlineToMarkdown opts (Math InlineMath str) =
case writerHTMLMathMethod opts of
WebTeX url ->
inlineToMarkdown opts (Image nullAttr [Str str]
(url ++ urlEncode str, 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 <- asks envPlain
inlineListToMarkdown opts $
(if plain then makeMathPlainer else id) $
texMathToInlines InlineMath str
inlineToMarkdown opts (Math DisplayMath str) =
case writerHTMLMathMethod opts of
WebTeX url -> (\x -> blankline <> x <> blankline) `fmap`
inlineToMarkdown opts (Image nullAttr [Str str]
(url ++ urlEncode str, 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 <- asks envPlain
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 <- asks envPlain
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 = do
escapeSpaces <- asks envEscapeSpaces
return $ if escapeSpaces then "\\ " else space
inlineToMarkdown opts SoftBreak = do
escapeSpaces <- asks envEscapeSpaces
let space' = if escapeSpaces then "\\ " else space
return $ case writerWrapText opts of
WrapNone -> space'
WrapAuto -> space'
WrapPreserve -> cr
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 lnk@(Link attr txt (src, tit))
| isEnabled Ext_raw_html opts &&
not (isEnabled Ext_link_attributes opts) &&
attr /= nullAttr =
return $ text $ trim $ writeHtmlString def $ Pandoc nullMeta [Plain [lnk]]
| otherwise = do
plain <- asks envPlain
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 <- asks envRefShortcutable
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 img@(Image attr alternate (source, tit))
| isEnabled Ext_raw_html opts &&
not (isEnabled Ext_link_attributes opts) &&
attr /= nullAttr =
return $ text $ trim $ writeHtmlString def $ Pandoc nullMeta [Plain [img]]
| otherwise = do
plain <- asks envPlain
let txt = if null alternate || alternate == [Str source]
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 (stNoteNum st + (length $ stNotes st) 1)
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