Markdown writer: move table-related code into submodule.

2 files changed, 136 insertions, 97 deletions

diff --git a/src/Text/Pandoc/Writers/Markdown.hs b/src/Text/Pandoc/Writers/Markdown.hs
index 2d9532dd3..222a2dd4a 100644
--- a/src/Text/Pandoc/Writers/Markdown.hs
+++ b/src/Text/Pandoc/Writers/Markdown.hs
@@ -23,7 +23,7 @@ module Text.Pandoc.Writers.Markdown (
 import Control.Monad.Reader
 import Control.Monad.State.Strict
 import Data.Default
-import Data.List (intersperse, sortOn, transpose)
+import Data.List (intersperse, sortOn)
 import Data.List.NonEmpty (nonEmpty, NonEmpty(..))
 import qualified Data.Map as M
 import Data.Maybe (fromMaybe, mapMaybe, isNothing)
@@ -47,6 +47,7 @@ import Text.Pandoc.Writers.Markdown.Inline (inlineListToMarkdown,
                                             linkAttributes,
                                             attrsToMarkdown,
                                             attrsToMarkua)
+import Text.Pandoc.Writers.Markdown.Table (pipeTable, pandocTable)
 import Text.Pandoc.Writers.Markdown.Types (MarkdownVariant(..),
                                            WriterState(..),
                                            WriterEnv(..),
@@ -670,102 +671,6 @@ addMarkdownAttribute s =
                                  x /= "markdown"]
        _ -> s
 
-pipeTable :: PandocMonad m
-          => WriterOptions
-          -> Bool -> [Alignment] -> [Double] -> [Doc Text] -> [[Doc Text]]
-          -> MD m (Doc Text)
-pipeTable opts headless aligns widths rawHeaders rawRows = do
-  let sp = literal " "
-  let blockFor AlignLeft   x y = lblock (x + 2) (sp <> y) <> lblock 0 empty
-      blockFor AlignCenter x y = cblock (x + 2) (sp <> y <> sp) <> lblock 0 empty
-      blockFor AlignRight  x y = rblock (x + 2) (y <> sp) <> lblock 0 empty
-      blockFor _           x y = lblock (x + 2) (sp <> y) <> lblock 0 empty
-  let contentWidths = map (max 3 . maybe 3 maximum . nonEmpty . map offset) $
-                       transpose (rawHeaders : rawRows)
-  let colwidth = writerColumns opts
-  let numcols = length contentWidths
-  let maxwidth = sum contentWidths
-  variant <- asks envVariant
-  let pipeWidths = if variant == Markdown &&
-                      not (all (== 0) widths) &&
-                      maxwidth + (numcols + 1) > colwidth
-                      then map
-                            (floor . (* fromIntegral (colwidth - (numcols +1))))
-                            widths
-                      else contentWidths
-  let torow cs = nowrap $ literal "|" <>
-                    hcat (intersperse (literal "|") $
-                          zipWith3 blockFor aligns contentWidths (map chomp cs))
-                    <> literal "|"
-  let toborder a w = literal $ case a of
-                          AlignLeft    -> ":" <> T.replicate (w + 1) "-"
-                          AlignCenter  -> ":" <> T.replicate w "-" <> ":"
-                          AlignRight   -> T.replicate (w + 1) "-" <> ":"
-                          AlignDefault -> T.replicate (w + 2) "-"
-  -- note:  pipe tables can't completely lack a
-  -- header; for a headerless table, we need a header of empty cells.
-  -- see jgm/pandoc#1996.
-  let header = if headless
-                  then torow (replicate (length aligns) empty)
-                  else torow rawHeaders
-  let border = nowrap $ literal "|" <> hcat (intersperse (literal "|") $
-                        zipWith toborder aligns pipeWidths) <> literal "|"
-  let body   = vcat $ map torow rawRows
-  return $ header $$ border $$ body
-
-pandocTable :: PandocMonad m
-            => WriterOptions -> Bool -> Bool -> [Alignment] -> [Double]
-            -> [Doc Text] -> [[Doc Text]] -> MD m (Doc Text)
-pandocTable opts multiline headless aligns widths rawHeaders rawRows = do
-  let isSimple = all (==0) widths
-  let alignHeader alignment = case alignment of
-                                AlignLeft    -> lblock
-                                AlignCenter  -> cblock
-                                AlignRight   -> rblock
-                                AlignDefault -> lblock
-  -- Number of characters per column necessary to output every cell
-  -- without requiring a line break.
-  -- The @+2@ is needed for specifying the alignment.
-  let numChars    = (+ 2) . maybe 0 maximum . nonEmpty . map offset
-  -- Number of characters per column necessary to output every cell
-  -- without requiring a line break *inside a word*.
-  -- The @+2@ is needed for specifying the alignment.
-  let minNumChars = (+ 2) . maybe 0 maximum . nonEmpty . map minOffset
-  let columns = transpose (rawHeaders : rawRows)
-  -- minimal column width without wrapping a single word
-  let relWidth w col =
-         max (floor $ fromIntegral (writerColumns opts - 1) * w)
-             (if writerWrapText opts == WrapAuto
-                 then minNumChars col
-                 else numChars col)
-  let widthsInChars
-        | isSimple  = map numChars columns
-        | otherwise = zipWith relWidth widths columns
-  let makeRow = hcat . intersperse (lblock 1 (literal " ")) .
-                   zipWith3 alignHeader aligns widthsInChars
-  let rows' = map makeRow rawRows
-  let head' = makeRow rawHeaders
-  let underline = mconcat $ intersperse (literal " ") $
-                  map (\width -> literal (T.replicate width "-")) widthsInChars
-  let border
-        | multiline = literal (T.replicate (sum widthsInChars +
-                        length widthsInChars - 1) "-")
-        | headless  = underline
-        | otherwise = empty
-  let head'' = if headless
-                  then empty
-                  else border <> cr <> head'
-  let body = if multiline
-                then vsep rows' $$
-                     if length rows' < 2
-                        then blankline -- #4578
-                        else empty
-                else vcat rows'
-  let bottom = if headless
-                  then underline
-                  else border
-  return $ head'' $$ underline $$ body $$ bottom
-
 itemEndsWithTightList :: [Block] -> Bool
 itemEndsWithTightList bs =
   case bs of
diff --git a/src/Text/Pandoc/Writers/Markdown/Table.hs b/src/Text/Pandoc/Writers/Markdown/Table.hs
new file mode 100644
index 000000000..6458c5a0d
--- /dev/null
+++ b/src/Text/Pandoc/Writers/Markdown/Table.hs
@@ -0,0 +1,134 @@
+{-# LANGUAGE OverloadedStrings   #-}
+{- |
+   Module      : Text.Pandoc.Writers.Markdown
+   Copyright   : © 2006-2022 John MacFarlane
+   License     : GPL-2.0-or-later
+   Maintainer  : John MacFarlane <jgm@berkeley.edu>
+
+Create Markdown pipe-tables and pandoc-style tables.
+-}
+module Text.Pandoc.Writers.Markdown.Table
+  ( pipeTable
+  , pandocTable
+  ) where
+
+import Control.Monad.Reader (asks)
+import Data.List (intersperse, transpose)
+import Data.List.NonEmpty (nonEmpty)
+import Data.Text (Text)
+import qualified Data.Text as T
+import Text.DocLayout
+import Text.Pandoc.Class.PandocMonad (PandocMonad)
+import Text.Pandoc.Definition (Alignment (..))
+import Text.Pandoc.Options (WriterOptions (writerColumns, writerWrapText),
+                            WrapOption(WrapAuto))
+import Text.Pandoc.Writers.Markdown.Types (MarkdownVariant(Markdown),
+                                           WriterEnv(..), MD)
+
+-- | Creates a Markdown pipe table.
+pipeTable :: PandocMonad m
+          => WriterOptions
+          -> Bool            -- ^ headless?
+          -> [Alignment]     -- ^ column alignments
+          -> [Double]        -- ^ column widhts
+          -> [Doc Text]      -- ^ table header cells
+          -> [[Doc Text]]    -- ^ table body rows
+          -> MD m (Doc Text)
+pipeTable opts headless aligns widths rawHeaders rawRows = do
+  let sp = literal " "
+  let blockFor AlignLeft   x y = lblock (x + 2) (sp <> y) <> lblock 0 empty
+      blockFor AlignCenter x y = cblock (x + 2) (sp <> y <> sp) <> lblock 0 empty
+      blockFor AlignRight  x y = rblock (x + 2) (y <> sp) <> lblock 0 empty
+      blockFor _           x y = lblock (x + 2) (sp <> y) <> lblock 0 empty
+  let contentWidths = map (max 3 . maybe 3 maximum . nonEmpty . map offset) $
+                       transpose (rawHeaders : rawRows)
+  let colwidth = writerColumns opts
+  let numcols = length contentWidths
+  let maxwidth = sum contentWidths
+  variant <- asks envVariant
+  let pipeWidths = if variant == Markdown &&
+                      not (all (== 0) widths) &&
+                      maxwidth + (numcols + 1) > colwidth
+                      then map
+                            (floor . (* fromIntegral (colwidth - (numcols +1))))
+                            widths
+                      else contentWidths
+  let torow cs = nowrap $ literal "|" <>
+                    hcat (intersperse (literal "|") $
+                          zipWith3 blockFor aligns contentWidths (map chomp cs))
+                    <> literal "|"
+  let toborder a w = literal $ case a of
+                          AlignLeft    -> ":" <> T.replicate (w + 1) "-"
+                          AlignCenter  -> ":" <> T.replicate w "-" <> ":"
+                          AlignRight   -> T.replicate (w + 1) "-" <> ":"
+                          AlignDefault -> T.replicate (w + 2) "-"
+  -- note:  pipe tables can't completely lack a
+  -- header; for a headerless table, we need a header of empty cells.
+  -- see jgm/pandoc#1996.
+  let header = if headless
+                  then torow (replicate (length aligns) empty)
+                  else torow rawHeaders
+  let border = nowrap $ literal "|" <> hcat (intersperse (literal "|") $
+                        zipWith toborder aligns pipeWidths) <> literal "|"
+  let body   = vcat $ map torow rawRows
+  return $ header $$ border $$ body
+
+-- | Write a pandoc-style Markdown table.
+pandocTable :: PandocMonad m
+            => WriterOptions
+            -> Bool            -- ^ whether this is a multiline table
+            -> Bool            -- ^ whether the table has a header
+            -> [Alignment]     -- ^ column alignments
+            -> [Double]        -- ^ column widths
+            -> [Doc Text]      -- ^ table header cells
+            -> [[Doc Text]]    -- ^ table body rows
+            -> MD m (Doc Text)
+pandocTable opts multiline headless aligns widths rawHeaders rawRows = do
+  let isSimple = all (==0) widths
+  let alignHeader alignment = case alignment of
+                                AlignLeft    -> lblock
+                                AlignCenter  -> cblock
+                                AlignRight   -> rblock
+                                AlignDefault -> lblock
+  -- Number of characters per column necessary to output every cell
+  -- without requiring a line break.
+  -- The @+2@ is needed for specifying the alignment.
+  let numChars    = (+ 2) . maybe 0 maximum . nonEmpty . map offset
+  -- Number of characters per column necessary to output every cell
+  -- without requiring a line break *inside a word*.
+  -- The @+2@ is needed for specifying the alignment.
+  let minNumChars = (+ 2) . maybe 0 maximum . nonEmpty . map minOffset
+  let columns = transpose (rawHeaders : rawRows)
+  -- minimal column width without wrapping a single word
+  let relWidth w col =
+         max (floor $ fromIntegral (writerColumns opts - 1) * w)
+             (if writerWrapText opts == WrapAuto
+                 then minNumChars col
+                 else numChars col)
+  let widthsInChars
+        | isSimple  = map numChars columns
+        | otherwise = zipWith relWidth widths columns
+  let makeRow = hcat . intersperse (lblock 1 (literal " ")) .
+                   zipWith3 alignHeader aligns widthsInChars
+  let rows' = map makeRow rawRows
+  let head' = makeRow rawHeaders
+  let underline = mconcat $ intersperse (literal " ") $
+                  map (\width -> literal (T.replicate width "-")) widthsInChars
+  let border
+        | multiline = literal (T.replicate (sum widthsInChars +
+                        length widthsInChars - 1) "-")
+        | headless  = underline
+        | otherwise = empty
+  let head'' = if headless
+                  then empty
+                  else border <> cr <> head'
+  let body = if multiline
+                then vsep rows' $$
+                     if length rows' < 2
+                        then blankline -- #4578
+                        else empty
+                else vcat rows'
+  let bottom = if headless
+                  then underline
+                  else border
+  return $ head'' $$ underline $$ body $$ bottom