module Text.Pandoc.Writers.CommonMark (writeCommonMark) where
import Text.Pandoc.Writers.HTML (writeHtmlString)
import Text.Pandoc.Definition
import Text.Pandoc.Shared (isTightList)
import Text.Pandoc.Templates (renderTemplate')
import Text.Pandoc.Writers.Shared
import Text.Pandoc.Options
import CMark
import qualified Data.Text as T
import Control.Monad.Identity (runIdentity, Identity)
import Control.Monad.State (runState, State, modify, get)
import Text.Pandoc.Walk (walkM)
writeCommonMark :: WriterOptions -> Pandoc -> String
writeCommonMark opts (Pandoc meta blocks) = rendered
where main = runIdentity $ blocksToCommonMark opts (blocks' ++ notes')
(blocks', notes) = runState (walkM processNotes blocks) []
notes' = if null notes
then []
else [OrderedList (1, Decimal, Period) $ reverse notes]
metadata = runIdentity $ metaToJSON opts
(blocksToCommonMark opts)
(inlinesToCommonMark opts)
meta
context = defField "body" main $ metadata
rendered = if writerStandalone opts
then renderTemplate' (writerTemplate opts) context
else main
processNotes :: Inline -> State [[Block]] Inline
processNotes (Note bs) = do
modify (bs :)
notes <- get
return $ Str $ "[" ++ show (length notes) ++ "]"
processNotes x = return x
node :: NodeType -> [Node] -> Node
node = Node Nothing
blocksToCommonMark :: WriterOptions -> [Block] -> Identity String
blocksToCommonMark opts bs = return $
T.unpack $ nodeToCommonmark cmarkOpts colwidth
$ node DOCUMENT (blocksToNodes bs)
where cmarkOpts = [optHardBreaks | isEnabled Ext_hard_line_breaks opts]
colwidth = if writerWrapText opts == WrapAuto
then Just $ writerColumns opts
else Nothing
inlinesToCommonMark :: WriterOptions -> [Inline] -> Identity String
inlinesToCommonMark opts ils = return $
T.unpack $ nodeToCommonmark cmarkOpts colwidth
$ node PARAGRAPH (inlinesToNodes ils)
where cmarkOpts = [optHardBreaks | isEnabled Ext_hard_line_breaks opts]
colwidth = if writerWrapText opts == WrapAuto
then Just $ writerColumns opts
else Nothing
blocksToNodes :: [Block] -> [Node]
blocksToNodes = foldr blockToNodes []
blockToNodes :: Block -> [Node] -> [Node]
blockToNodes (Plain xs) = (node PARAGRAPH (inlinesToNodes xs) :)
blockToNodes (Para xs) = (node PARAGRAPH (inlinesToNodes xs) :)
blockToNodes (CodeBlock (_,classes,_) xs) =
(node (CODE_BLOCK (T.pack (unwords classes)) (T.pack xs)) [] :)
blockToNodes (RawBlock fmt xs)
| fmt == Format "html" = (node (HTML_BLOCK (T.pack xs)) [] :)
| otherwise = (node (CUSTOM_BLOCK (T.pack xs) (T.empty)) [] :)
blockToNodes (BlockQuote bs) =
(node BLOCK_QUOTE (blocksToNodes bs) :)
blockToNodes (BulletList items) =
(node (LIST ListAttributes{
listType = BULLET_LIST,
listDelim = PERIOD_DELIM,
listTight = isTightList items,
listStart = 1 }) (map (node ITEM . blocksToNodes) items) :)
blockToNodes (OrderedList (start, _sty, delim) items) =
(node (LIST ListAttributes{
listType = ORDERED_LIST,
listDelim = case delim of
OneParen -> PAREN_DELIM
TwoParens -> PAREN_DELIM
_ -> PERIOD_DELIM,
listTight = isTightList items,
listStart = start }) (map (node ITEM . blocksToNodes) items) :)
blockToNodes HorizontalRule = (node THEMATIC_BREAK [] :)
blockToNodes (Header lev _ ils) = (node (HEADING lev) (inlinesToNodes ils) :)
blockToNodes (Div _ bs) = (blocksToNodes bs ++)
blockToNodes (DefinitionList items) = blockToNodes (BulletList items')
where items' = map dlToBullet items
dlToBullet (term, ((Para xs : ys) : zs)) =
Para (term ++ [LineBreak] ++ xs) : ys ++ concat zs
dlToBullet (term, ((Plain xs : ys) : zs)) =
Plain (term ++ [LineBreak] ++ xs) : ys ++ concat zs
dlToBullet (term, xs) =
Para term : concat xs
blockToNodes t@(Table _ _ _ _ _) =
(node (HTML_BLOCK (T.pack $! writeHtmlString def $! Pandoc nullMeta [t])) [] :)
blockToNodes Null = id
inlinesToNodes :: [Inline] -> [Node]
inlinesToNodes = foldr inlineToNodes []
inlineToNodes :: Inline -> [Node] -> [Node]
inlineToNodes (Str s) = (node (TEXT (T.pack s)) [] :)
inlineToNodes Space = (node (TEXT (T.pack " ")) [] :)
inlineToNodes LineBreak = (node LINEBREAK [] :)
inlineToNodes SoftBreak = (node SOFTBREAK [] :)
inlineToNodes (Emph xs) = (node EMPH (inlinesToNodes xs) :)
inlineToNodes (Strong xs) = (node STRONG (inlinesToNodes xs) :)
inlineToNodes (Strikeout xs) =
((node (HTML_INLINE (T.pack "<s>")) [] : inlinesToNodes xs ++
[node (HTML_INLINE (T.pack "</s>")) []]) ++ )
inlineToNodes (Superscript xs) =
((node (HTML_INLINE (T.pack "<sup>")) [] : inlinesToNodes xs ++
[node (HTML_INLINE (T.pack "</sup>")) []]) ++ )
inlineToNodes (Subscript xs) =
((node (HTML_INLINE (T.pack "<sub>")) [] : inlinesToNodes xs ++
[node (HTML_INLINE (T.pack "</sub>")) []]) ++ )
inlineToNodes (SmallCaps xs) =
((node (HTML_INLINE (T.pack "<span style=\"font-variant:small-caps;\">")) []
: inlinesToNodes xs ++
[node (HTML_INLINE (T.pack "</span>")) []]) ++ )
inlineToNodes (Link _ ils (url,tit)) =
(node (LINK (T.pack url) (T.pack tit)) (inlinesToNodes ils) :)
inlineToNodes (Image _ ils (url,tit)) =
(node (IMAGE (T.pack url) (T.pack tit)) (inlinesToNodes ils) :)
inlineToNodes (RawInline fmt xs)
| fmt == Format "html" = (node (HTML_INLINE (T.pack xs)) [] :)
| otherwise = (node (CUSTOM_INLINE (T.pack xs) (T.empty)) [] :)
inlineToNodes (Quoted qt ils) =
((node (TEXT start) [] : inlinesToNodes ils ++ [node (TEXT end) []]) ++)
where (start, end) = case qt of
SingleQuote -> (T.pack "‘", T.pack "’")
DoubleQuote -> (T.pack "“", T.pack "”")
inlineToNodes (Code _ str) = (node (CODE (T.pack str)) [] :)
inlineToNodes (Math mt str) =
case mt of
InlineMath ->
(node (HTML_INLINE (T.pack ("\\(" ++ str ++ "\\)"))) [] :)
DisplayMath ->
(node (HTML_INLINE (T.pack ("\\[" ++ str ++ "\\]"))) [] :)
inlineToNodes (Span _ ils) = (inlinesToNodes ils ++)
inlineToNodes (Cite _ ils) = (inlinesToNodes ils ++)
inlineToNodes (Note _) = id