CommonMark writer: support table, strikethrough extensions...

when enabled (as with gfm).  Note: because of limitations in
cmark-gfm, which will hopefully soon be corrected, this currently
gives an error on Tables.

Also properly support `--wrap=none`.

1 files changed, 90 insertions, 59 deletions

diff --git a/src/Text/Pandoc/Writers/CommonMark.hs b/src/Text/Pandoc/Writers/CommonMark.hs
index 75a18dcf4..fa838a503 100644
--- a/src/Text/Pandoc/Writers/CommonMark.hs
+++ b/src/Text/Pandoc/Writers/CommonMark.hs
@@ -34,6 +34,7 @@ module Text.Pandoc.Writers.CommonMark (writeCommonMark) where
 import CMarkGFM
 import Control.Monad.State.Strict (State, get, modify, runState)
 import Data.Foldable (foldrM)
+import Data.Monoid (Any (..))
 import Data.Text (Text)
 import qualified Data.Text as T
 import Text.Pandoc.Class (PandocMonad)
@@ -41,7 +42,7 @@ 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.Walk (walkM, walk, query)
 import Text.Pandoc.Writers.HTML (writeHtml5String)
 import Text.Pandoc.Writers.Shared
 
@@ -52,7 +53,12 @@ writeCommonMark opts (Pandoc meta blocks) = do
       notes' = if null notes
                then []
                else [OrderedList (1, Decimal, Period) $ reverse notes]
-  main <-  blocksToCommonMark opts (blocks' ++ notes')
+  let softBreakToSpace SoftBreak = Space
+      softBreakToSpace x = x
+  let blocks'' = if writerWrapText opts == WrapNone
+                    then walk softBreakToSpace blocks'
+                    else blocks'
+  main <-  blocksToCommonMark opts (blocks'' ++ notes')
   metadata <- metaToJSON opts
               (blocksToCommonMark opts)
               (inlinesToCommonMark opts)
@@ -78,43 +84,46 @@ blocksToCommonMark opts bs = do
       colwidth = if writerWrapText opts == WrapAuto
                  then Just $ writerColumns opts
                  else Nothing
-  nodes <- blocksToNodes bs
+  nodes <- blocksToNodes opts bs
   return $
     nodeToCommonmark cmarkOpts colwidth $
     node DOCUMENT nodes
 
 inlinesToCommonMark :: PandocMonad m => WriterOptions -> [Inline] -> m Text
 inlinesToCommonMark opts ils = return $
-  nodeToCommonmark cmarkOpts colwidth $ node PARAGRAPH (inlinesToNodes ils)
+  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 => [Block] -> m [Node]
-blocksToNodes = foldrM blockToNodes []
+blocksToNodes :: PandocMonad m => WriterOptions -> [Block] -> m [Node]
+blocksToNodes opts = foldrM (blockToNodes opts) []
 
-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 $
+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
+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
+blockToNodes opts (BlockQuote bs) ns = do
+  nodes <- blocksToNodes opts bs
   return (node BLOCK_QUOTE nodes : ns)
-blockToNodes (BulletList items) ns = do
-  nodes <- mapM blocksToNodes items
+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 (OrderedList (start, _sty, delim) items) ns = do
-  nodes <- mapM blocksToNodes items
+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
@@ -123,12 +132,14 @@ blockToNodes (OrderedList (start, _sty, delim) items) ns = do
                                  _         -> 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
+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 (DefinitionList items) ns = blockToNodes (BulletList items') 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
@@ -136,54 +147,74 @@ blockToNodes (DefinitionList items) ns = blockToNodes (BulletList items') ns
           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 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 "<s>")) [] : inlinesToNodes xs ++
-   [node (HTML_INLINE (T.pack "</s>")) []]) ++ )
-inlineToNodes (Superscript xs) =
-  ((node (HTML_INLINE (T.pack "<sup>")) [] : inlinesToNodes xs ++
+blockToNodes opts t@(Table _capt aligns widths headers rows) ns = do
+  let allrows = headers:rows
+  let isLineBreak LineBreak = Any True
+      isLineBreak _         = Any False
+  let isSimple = all (==0) widths &&
+                 not ( getAny (query isLineBreak allrows) )
+  if isEnabled Ext_pipe_tables opts && isSimple
+     then do
+       let toAlign AlignDefault = NoAlignment
+           toAlign AlignLeft    = LeftAligned
+           toAlign AlignCenter  = CenterAligned
+           toAlign AlignRight   = RightAligned
+       let aligns' = map toAlign aligns
+       let toCell bs   = node TABLE_CELL <$> blocksToNodes opts bs
+       let toRow cells = node TABLE_ROW <$> mapM toCell cells
+       cmrows <- mapM toRow allrows
+       return (node (TABLE aligns') cmrows : 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 _ (Str s) = (node (TEXT (T.pack s)) [] :)
+inlineToNodes _ Space   = (node (TEXT (T.pack " ")) [] :)
+inlineToNodes _ LineBreak = (node LINEBREAK [] :)
+inlineToNodes _ SoftBreak = (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 (Subscript xs) =
-  ((node (HTML_INLINE (T.pack "<sub>")) [] : inlinesToNodes xs ++
+inlineToNodes opts (Subscript xs) =
+  ((node (HTML_INLINE (T.pack "<sub>")) [] : inlinesToNodes opts xs ++
    [node (HTML_INLINE (T.pack "</sub>")) []]) ++ )
-inlineToNodes (SmallCaps xs) =
+inlineToNodes opts (SmallCaps xs) =
   ((node (HTML_INLINE (T.pack "<span class=\"smallcaps\">")) []
-    : inlinesToNodes xs ++
+    : inlinesToNodes opts 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)
+inlineToNodes opts (Link _ ils (url,tit)) =
+  (node (LINK (T.pack url) (T.pack tit)) (inlinesToNodes opts ils) :)
+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 (Quoted qt ils) =
-  ((node (TEXT start) [] : inlinesToNodes ils ++ [node (TEXT end) []]) ++)
+inlineToNodes opts (Quoted qt ils) =
+  ((node (TEXT start) [] :
+   inlinesToNodes opts 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) =
+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
+inlineToNodes opts (Span _ ils) = (inlinesToNodes opts ils ++)
+inlineToNodes opts (Cite _ ils) = (inlinesToNodes opts ils ++)
+inlineToNodes _ (Note _) = id -- should not occur
 -- we remove Note elements in preprocessing