{-# LANGUAGE OverloadedStrings #-} {- Copyright (C) 2015-2017 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.CommonMark Copyright : Copyright (C) 2015-2017 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane Stability : alpha Portability : portable Conversion of 'Pandoc' documents to CommonMark. CommonMark: -} 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 Network.HTTP (urlEncode) 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, tagWithAttributes) import Text.Pandoc.Writers.Shared -- | Convert Pandoc to CommonMark. 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 opts (RawBlock fmt xs) ns | fmt == Format "html" && isEnabled Ext_raw_html opts = return (node (HTML_BLOCK (T.pack xs)) [] : ns) | fmt == Format "latex" || fmt == Format "tex" && isEnabled Ext_raw_tex opts = return (node (CUSTOM_BLOCK (T.pack xs) T.empty) [] : ns) | otherwise = return 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 attr bs) ns = do nodes <- blocksToNodes opts bs let op = tagWithAttributes opts True False "div" attr if isEnabled Ext_raw_html opts then return (node (HTML_BLOCK op) [] : nodes ++ [node (HTML_BLOCK (T.pack "")) []] ++ ns) else 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 -- We construct a table manually as a CUSTOM_BLOCK, for -- two reasons: (1) cmark-gfm currently doesn't support -- rendering TABLE nodes; (2) we can align the column sides; -- (3) we can render the caption as a regular paragraph. let capt' = node PARAGRAPH (inlinesToNodes opts capt) -- backslash | in code and raw: 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 -- fall back to raw HTML 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 (CUSTOM_INLINE "~~" "~~") (inlinesToNodes opts xs) :) else ((node (HTML_INLINE (T.pack "")) [] : inlinesToNodes opts xs ++ [node (HTML_INLINE (T.pack "")) []]) ++ ) inlineToNodes opts (Superscript xs) = ((node (HTML_INLINE (T.pack "")) [] : inlinesToNodes opts xs ++ [node (HTML_INLINE (T.pack "")) []]) ++ ) inlineToNodes opts (Subscript xs) = ((node (HTML_INLINE (T.pack "")) [] : inlinesToNodes opts xs ++ [node (HTML_INLINE (T.pack "")) []]) ++ ) inlineToNodes opts (SmallCaps xs) = ((node (HTML_INLINE (T.pack "")) [] : inlinesToNodes opts xs ++ [node (HTML_INLINE (T.pack "")) []]) ++ ) inlineToNodes opts (Link _ ils (url,tit)) = (node (LINK (T.pack url) (T.pack tit)) (inlinesToNodes opts ils) :) -- title beginning with fig: indicates implicit figure 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 opts (RawInline fmt xs) | fmt == Format "html" && isEnabled Ext_raw_html opts = (node (HTML_INLINE (T.pack xs)) [] :) | (fmt == Format "latex" || fmt == Format "tex") && isEnabled Ext_raw_tex opts = (node (CUSTOM_INLINE (T.pack xs) T.empty) [] :) | otherwise = id 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 opts (Math mt str) = case writerHTMLMathMethod opts of WebTeX url -> let core = inlineToNodes opts (Image nullAttr [Str str] (url ++ urlEncode str, str)) sep = if mt == DisplayMath then (node LINEBREAK [] :) else id in (sep . core . sep) _ -> case mt of InlineMath -> (node (HTML_INLINE (T.pack ("\\(" ++ str ++ "\\)"))) [] :) DisplayMath -> (node (HTML_INLINE (T.pack ("\\[" ++ str ++ "\\]"))) [] :) inlineToNodes opts (Span attr ils) = let nodes = inlinesToNodes opts ils op = tagWithAttributes opts True False "span" attr in if isEnabled Ext_raw_html opts then ((node (HTML_INLINE op) [] : nodes ++ [node (HTML_INLINE (T.pack "")) []]) ++) else (nodes ++) inlineToNodes opts (Cite _ ils) = (inlinesToNodes opts ils ++) inlineToNodes _ (Note _) = id -- should not occur -- we remove Note elements in preprocessing