From 43e549b2fb305519b773d44e7036a71361a36f4e Mon Sep 17 00:00:00 2001 From: Albert Krewinkel Date: Tue, 15 Mar 2022 15:34:29 +0100 Subject: [PATCH] Markdown writer: move table-related code into submodule. --- pandoc.cabal | 1 + src/Text/Pandoc/Writers/Markdown.hs | 99 +--------------- src/Text/Pandoc/Writers/Markdown/Table.hs | 134 ++++++++++++++++++++++ 3 files changed, 137 insertions(+), 97 deletions(-) create mode 100644 src/Text/Pandoc/Writers/Markdown/Table.hs diff --git a/pandoc.cabal b/pandoc.cabal index 25858d3f4..bee47055b 100644 --- a/pandoc.cabal +++ b/pandoc.cabal @@ -713,6 +713,7 @@ library Text.Pandoc.Writers.LaTeX.Types, Text.Pandoc.Writers.LaTeX.Citation, Text.Pandoc.Writers.LaTeX.Util, + Text.Pandoc.Writers.Markdown.Table, Text.Pandoc.Writers.Markdown.Types, Text.Pandoc.Writers.Markdown.Inline, Text.Pandoc.Writers.Roff, 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 + +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