module Text.Pandoc.Writers.CommonMark (writeCommonMark) where
import CMarkGFM
import Control.Monad.State.Strict (State, get, modify, runState)
import Data.Foldable (foldrM)
import Data.List (transpose)
import Data.Monoid (Any (..), (<>))
import Data.Text (Text)
import qualified Data.Text as T
import Text.Pandoc.Class (PandocMonad)
import Text.Pandoc.Definition
import Text.Pandoc.Options
import Text.Pandoc.Shared (isTightList, linesToPara, substitute)
import Text.Pandoc.Templates (renderTemplate')
import Text.Pandoc.Walk (query, walk, walkM)
import Text.Pandoc.Writers.HTML (writeHtml5String)
import Text.Pandoc.Writers.Shared
writeCommonMark :: PandocMonad m => WriterOptions -> Pandoc -> m Text
writeCommonMark opts (Pandoc meta blocks) = do
let (blocks', notes) = runState (walkM processNotes blocks) []
notes' = if null notes
then []
else [OrderedList (1, Decimal, Period) $ reverse notes]
main <- blocksToCommonMark opts (blocks' ++ notes')
metadata <- metaToJSON opts
(blocksToCommonMark opts)
(inlinesToCommonMark opts)
meta
let context = defField "body" main metadata
case writerTemplate opts of
Nothing -> return main
Just tpl -> renderTemplate' tpl context
softBreakToSpace :: Inline -> Inline
softBreakToSpace SoftBreak = Space
softBreakToSpace x = x
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 :: PandocMonad m => WriterOptions -> [Block] -> m Text
blocksToCommonMark opts bs = do
let cmarkOpts = [optHardBreaks | isEnabled Ext_hard_line_breaks opts]
colwidth = if writerWrapText opts == WrapAuto
then Just $ writerColumns opts
else Nothing
nodes <- blocksToNodes opts bs
return $ T.stripEnd $
nodeToCommonmark cmarkOpts colwidth $
node DOCUMENT nodes
inlinesToCommonMark :: PandocMonad m => WriterOptions -> [Inline] -> m Text
inlinesToCommonMark opts ils = return $
nodeToCommonmark cmarkOpts colwidth $
node PARAGRAPH (inlinesToNodes opts ils)
where cmarkOpts = [optHardBreaks | isEnabled Ext_hard_line_breaks opts]
colwidth = if writerWrapText opts == WrapAuto
then Just $ writerColumns opts
else Nothing
blocksToNodes :: PandocMonad m => WriterOptions -> [Block] -> m [Node]
blocksToNodes opts = foldrM (blockToNodes opts) []
blockToNodes :: PandocMonad m => WriterOptions -> Block -> [Node] -> m [Node]
blockToNodes opts (Plain xs) ns =
return (node PARAGRAPH (inlinesToNodes opts xs) : ns)
blockToNodes opts (Para xs) ns =
return (node PARAGRAPH (inlinesToNodes opts xs) : ns)
blockToNodes opts (LineBlock lns) ns = blockToNodes opts (linesToPara lns) ns
blockToNodes _ (CodeBlock (_,classes,_) xs) ns = return
(node (CODE_BLOCK (T.pack (unwords classes)) (T.pack xs)) [] : ns)
blockToNodes _ (RawBlock fmt xs) ns
| fmt == Format "html" = return (node (HTML_BLOCK (T.pack xs)) [] : ns)
| otherwise = return (node (CUSTOM_BLOCK (T.pack xs) T.empty) [] : ns)
blockToNodes opts (BlockQuote bs) ns = do
nodes <- blocksToNodes opts bs
return (node BLOCK_QUOTE nodes : ns)
blockToNodes opts (BulletList items) ns = do
nodes <- mapM (blocksToNodes opts) items
return (node (LIST ListAttributes{
listType = BULLET_LIST,
listDelim = PERIOD_DELIM,
listTight = isTightList items,
listStart = 1 }) (map (node ITEM) nodes) : ns)
blockToNodes opts (OrderedList (start, _sty, delim) items) ns = do
nodes <- mapM (blocksToNodes opts) items
return (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) nodes) : ns)
blockToNodes _ HorizontalRule ns = return (node THEMATIC_BREAK [] : ns)
blockToNodes opts (Header lev _ ils) ns =
return (node (HEADING lev) (inlinesToNodes opts ils) : ns)
blockToNodes opts (Div _ bs) ns = do
nodes <- blocksToNodes opts bs
return (nodes ++ ns)
blockToNodes opts (DefinitionList items) ns =
blockToNodes opts (BulletList items') ns
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 opts t@(Table capt aligns _widths headers rows) ns = do
let allcells = concat (headers:rows)
let isLineBreak LineBreak = Any True
isLineBreak _ = Any False
let isPlainOrPara [Para _] = True
isPlainOrPara [Plain _] = True
isPlainOrPara [] = True
isPlainOrPara _ = False
let isSimple = all isPlainOrPara allcells &&
not ( getAny (query isLineBreak allcells) )
if isEnabled Ext_pipe_tables opts && isSimple
then do
let capt' = node PARAGRAPH (inlinesToNodes opts capt)
let fixPipe (Code attr xs) =
Code attr (substitute "|" "\\|" xs)
fixPipe (RawInline format xs) =
RawInline format (substitute "|" "\\|" xs)
fixPipe x = x
let toCell [Plain ils] = T.strip
$ nodeToCommonmark [] Nothing
$ node (CUSTOM_INLINE mempty mempty)
$ inlinesToNodes opts
$ walk (fixPipe . softBreakToSpace) ils
toCell [Para ils] = T.strip
$ nodeToCommonmark [] Nothing
$ node (CUSTOM_INLINE mempty mempty)
$ inlinesToNodes opts
$ walk (fixPipe . softBreakToSpace) ils
toCell [] = ""
toCell xs = error $ "toCell encountered " ++ show xs
let separator = " | "
let starter = "| "
let ender = " |"
let rawheaders = map toCell headers
let rawrows = map (map toCell) rows
let maximum' [] = 0
maximum' xs = maximum xs
let colwidths = map (maximum' . map T.length) $
transpose (rawheaders:rawrows)
let toHeaderLine len AlignDefault = T.replicate len "-"
toHeaderLine len AlignLeft = ":" <>
T.replicate (max (len 1) 1) "-"
toHeaderLine len AlignRight =
T.replicate (max (len 1) 1) "-" <> ":"
toHeaderLine len AlignCenter = ":" <>
T.replicate (max (len 2) 1) (T.pack "-") <> ":"
let rawheaderlines = zipWith toHeaderLine colwidths aligns
let headerlines = starter <> T.intercalate separator rawheaderlines <>
ender
let padContent (align, w) t' =
let padding = w T.length t'
halfpadding = padding `div` 2
in case align of
AlignRight -> T.replicate padding " " <> t'
AlignCenter -> T.replicate halfpadding " " <> t' <>
T.replicate (padding halfpadding) " "
_ -> t' <> T.replicate padding " "
let toRow xs = starter <> T.intercalate separator
(zipWith padContent (zip aligns colwidths) xs) <>
ender
let table' = toRow rawheaders <> "\n" <> headerlines <> "\n" <>
T.intercalate "\n" (map toRow rawrows)
return (node (CUSTOM_BLOCK table' mempty) [] :
if null capt
then ns
else capt' : ns)
else do
s <- writeHtml5String def $! Pandoc nullMeta [t]
return (node (HTML_BLOCK s) [] : ns)
blockToNodes _ Null ns = return ns
inlinesToNodes :: WriterOptions -> [Inline] -> [Node]
inlinesToNodes opts = foldr (inlineToNodes opts) []
inlineToNodes :: WriterOptions -> Inline -> [Node] -> [Node]
inlineToNodes opts (Str s) = (node (TEXT (T.pack s')) [] :)
where s' = if isEnabled Ext_smart opts
then unsmartify opts s
else s
inlineToNodes _ Space = (node (TEXT (T.pack " ")) [] :)
inlineToNodes _ LineBreak = (node LINEBREAK [] :)
inlineToNodes opts SoftBreak
| isEnabled Ext_hard_line_breaks opts = (node LINEBREAK [] :)
| writerWrapText opts == WrapNone = (node (TEXT " ") [] :)
| otherwise = (node SOFTBREAK [] :)
inlineToNodes opts (Emph xs) = (node EMPH (inlinesToNodes opts xs) :)
inlineToNodes opts (Strong xs) = (node STRONG (inlinesToNodes opts xs) :)
inlineToNodes opts (Strikeout xs) =
if isEnabled Ext_strikeout opts
then (node STRIKETHROUGH (inlinesToNodes opts xs) :)
else ((node (HTML_INLINE (T.pack "<s>")) [] : inlinesToNodes opts xs ++
[node (HTML_INLINE (T.pack "</s>")) []]) ++ )
inlineToNodes opts (Superscript xs) =
((node (HTML_INLINE (T.pack "<sup>")) [] : inlinesToNodes opts xs ++
[node (HTML_INLINE (T.pack "</sup>")) []]) ++ )
inlineToNodes opts (Subscript xs) =
((node (HTML_INLINE (T.pack "<sub>")) [] : inlinesToNodes opts xs ++
[node (HTML_INLINE (T.pack "</sub>")) []]) ++ )
inlineToNodes opts (SmallCaps xs) =
((node (HTML_INLINE (T.pack "<span class=\"smallcaps\">")) []
: inlinesToNodes opts xs ++
[node (HTML_INLINE (T.pack "</span>")) []]) ++ )
inlineToNodes opts (Link _ ils (url,tit)) =
(node (LINK (T.pack url) (T.pack tit)) (inlinesToNodes opts ils) :)
inlineToNodes opts (Image alt ils (url,'f':'i':'g':':':tit)) =
inlineToNodes opts (Image alt ils (url,tit))
inlineToNodes opts (Image _ ils (url,tit)) =
(node (IMAGE (T.pack url) (T.pack tit)) (inlinesToNodes opts ils) :)
inlineToNodes _ (RawInline fmt xs)
| fmt == Format "html" = (node (HTML_INLINE (T.pack xs)) [] :)
| otherwise = (node (CUSTOM_INLINE (T.pack xs) T.empty) [] :)
inlineToNodes opts (Quoted qt ils) =
((node (TEXT start) [] :
inlinesToNodes opts ils ++ [node (TEXT end) []]) ++)
where (start, end) = case qt of
SingleQuote
| isEnabled Ext_smart opts -> ("'","'")
| otherwise -> ("‘", "’")
DoubleQuote
| isEnabled Ext_smart opts -> ("\"", "\"")
| otherwise -> ("“", "”")
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 opts (Span _ ils) = (inlinesToNodes opts ils ++)
inlineToNodes opts (Cite _ ils) = (inlinesToNodes opts ils ++)
inlineToNodes _ (Note _) = id