pandoc-3.2: src/Text/Pandoc/Writers/Markdown/Table.hs

{-# LANGUAGE OverloadedStrings   #-}
{- |
   Module      : Text.Pandoc.Writers.Markdown
   Copyright   : © 2006-2024 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 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
  -- if cell contents are > COLUMNS, adding padding looks bad
  let pad = maxwidth <= writerColumns opts
  let blockFor _ _ y | not pad = sp <> y <> sp <> lblock 0 empty
      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 AlignDefault x y = lblock (x + 2) (sp <> y) <> lblock 0 empty
  variant <- asks envVariant
  let pipeWidths = if variant == Markdown &&
                      not (all (== 0) widths) &&
                      maxwidth + (numcols + 1) > colwidth
                      then map
                            (max 0 .
                              floor .
                                (* fromIntegral (colwidth - (numcols +1))))
                            widths
                      else if pad
                              then contentWidths
                              else map (const 2) widths
  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