{- Copyright (C) 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.CommonMark Copyright : Copyright (C) 2015 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 CMark import Control.Monad.State (State, get, modify, runState) import Data.Foldable (foldrM) 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) import Text.Pandoc.Templates (renderTemplate') import Text.Pandoc.Walk (walkM) import Text.Pandoc.Writers.HTML (writeHtml5String) import Text.Pandoc.Writers.Shared -- | Convert Pandoc to CommonMark. writeCommonMark :: PandocMonad m => WriterOptions -> Pandoc -> m String 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 return $ case writerTemplate opts of Nothing -> main Just tpl -> renderTemplate' tpl context 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 String 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 bs return $ T.unpack $ nodeToCommonmark cmarkOpts colwidth $ node DOCUMENT nodes inlinesToCommonMark :: PandocMonad m => WriterOptions -> [Inline] -> m 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 :: PandocMonad m => [Block] -> m [Node] blocksToNodes = foldrM blockToNodes [] blockToNodes :: PandocMonad m => Block -> [Node] -> m [Node] blockToNodes (Plain xs) ns = return (node PARAGRAPH (inlinesToNodes xs) : ns) blockToNodes (Para xs) ns = return (node PARAGRAPH (inlinesToNodes xs) : ns) blockToNodes (LineBlock lns) ns = blockToNodes (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 (BlockQuote bs) ns = do nodes <- blocksToNodes bs return (node BLOCK_QUOTE nodes : ns) blockToNodes (BulletList items) ns = do nodes <- mapM blocksToNodes items return (node (LIST ListAttributes{ listType = BULLET_LIST, listDelim = PERIOD_DELIM, listTight = isTightList items, listStart = 1 }) (map (node ITEM) nodes) : ns) blockToNodes (OrderedList (start, _sty, delim) items) ns = do nodes <- mapM blocksToNodes 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 (Header lev _ ils) ns = return (node (HEADING lev) (inlinesToNodes ils) : ns) blockToNodes (Div _ bs) ns = do nodes <- blocksToNodes bs return (nodes ++ ns) blockToNodes (DefinitionList items) ns = blockToNodes (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 t@(Table _ _ _ _ _) ns = do s <- writeHtml5String def $! Pandoc nullMeta [t] return (node (HTML_BLOCK (T.pack $! s)) [] : ns) blockToNodes Null ns = return ns 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 "")) [] : inlinesToNodes xs ++ [node (HTML_INLINE (T.pack "")) []]) ++ ) inlineToNodes (Superscript xs) = ((node (HTML_INLINE (T.pack "")) [] : inlinesToNodes xs ++ [node (HTML_INLINE (T.pack "")) []]) ++ ) inlineToNodes (Subscript xs) = ((node (HTML_INLINE (T.pack "")) [] : inlinesToNodes xs ++ [node (HTML_INLINE (T.pack "")) []]) ++ ) inlineToNodes (SmallCaps xs) = ((node (HTML_INLINE (T.pack "")) [] : inlinesToNodes xs ++ [node (HTML_INLINE (T.pack "")) []]) ++ ) 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 -- should not occur -- we remove Note elements in preprocessing