{-# LANGUAGE OverloadedStrings   #-}
{- |
   Module      : Text.Pandoc.Writers.Markdown
   Copyright   : © 2006-2023 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 :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions
-> Bool
-> [Alignment]
-> [Double]
-> [Doc Text]
-> [[Doc Text]]
-> MD m (Doc Text)
pipeTable WriterOptions
opts Bool
headless [Alignment]
aligns [Double]
widths [Doc Text]
rawHeaders [[Doc Text]]
rawRows = do
  let sp :: Doc Text
sp = forall a. HasChars a => a -> Doc a
literal Text
" "
  let blockFor :: Alignment -> Int -> Doc Text -> Doc Text
blockFor Alignment
AlignLeft   Int
x Doc Text
y = forall a. HasChars a => Int -> Doc a -> Doc a
lblock (Int
x forall a. Num a => a -> a -> a
+ Int
2) (Doc Text
sp forall a. Semigroup a => a -> a -> a
<> Doc Text
y) forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => Int -> Doc a -> Doc a
lblock Int
0 forall a. Doc a
empty
      blockFor Alignment
AlignCenter Int
x Doc Text
y = forall a. HasChars a => Int -> Doc a -> Doc a
cblock (Int
x forall a. Num a => a -> a -> a
+ Int
2) (Doc Text
sp forall a. Semigroup a => a -> a -> a
<> Doc Text
y forall a. Semigroup a => a -> a -> a
<> Doc Text
sp) forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => Int -> Doc a -> Doc a
lblock Int
0 forall a. Doc a
empty
      blockFor Alignment
AlignRight  Int
x Doc Text
y = forall a. HasChars a => Int -> Doc a -> Doc a
rblock (Int
x forall a. Num a => a -> a -> a
+ Int
2) (Doc Text
y forall a. Semigroup a => a -> a -> a
<> Doc Text
sp) forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => Int -> Doc a -> Doc a
lblock Int
0 forall a. Doc a
empty
      blockFor Alignment
_           Int
x Doc Text
y = forall a. HasChars a => Int -> Doc a -> Doc a
lblock (Int
x forall a. Num a => a -> a -> a
+ Int
2) (Doc Text
sp forall a. Semigroup a => a -> a -> a
<> Doc Text
y) forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => Int -> Doc a -> Doc a
lblock Int
0 forall a. Doc a
empty
  let contentWidths :: [Int]
contentWidths = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Ord a => a -> a -> a
max Int
3 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
3 forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. (IsString a, HasChars a) => Doc a -> Int
offset) forall a b. (a -> b) -> a -> b
$
                       forall a. [[a]] -> [[a]]
transpose ([Doc Text]
rawHeaders forall a. a -> [a] -> [a]
: [[Doc Text]]
rawRows)
  let colwidth :: Int
colwidth = WriterOptions -> Int
writerColumns WriterOptions
opts
  let numcols :: Int
numcols = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
contentWidths
  let maxwidth :: Int
maxwidth = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
contentWidths
  MarkdownVariant
variant <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks WriterEnv -> MarkdownVariant
envVariant
  let pipeWidths :: [Int]
pipeWidths = if MarkdownVariant
variant forall a. Eq a => a -> a -> Bool
== MarkdownVariant
Markdown Bool -> Bool -> Bool
&&
                      Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
== Double
0) [Double]
widths) Bool -> Bool -> Bool
&&
                      Int
maxwidth forall a. Num a => a -> a -> a
+ (Int
numcols forall a. Num a => a -> a -> a
+ Int
1) forall a. Ord a => a -> a -> Bool
> Int
colwidth
                      then forall a b. (a -> b) -> [a] -> [b]
map
                            (forall a b. (RealFrac a, Integral b) => a -> b
floor forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
* forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
colwidth forall a. Num a => a -> a -> a
- (Int
numcols forall a. Num a => a -> a -> a
+Int
1))))
                            [Double]
widths
                      else [Int]
contentWidths
  let torow :: [Doc Text] -> Doc Text
torow [Doc Text]
cs = forall a. IsString a => Doc a -> Doc a
nowrap forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => a -> Doc a
literal Text
"|" forall a. Semigroup a => a -> a -> a
<>
                    forall a. [Doc a] -> Doc a
hcat (forall a. a -> [a] -> [a]
intersperse (forall a. HasChars a => a -> Doc a
literal Text
"|") forall a b. (a -> b) -> a -> b
$
                          forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Alignment -> Int -> Doc Text -> Doc Text
blockFor [Alignment]
aligns [Int]
contentWidths (forall a b. (a -> b) -> [a] -> [b]
map forall a. Doc a -> Doc a
chomp [Doc Text]
cs))
                    forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => a -> Doc a
literal Text
"|"
  let toborder :: Alignment -> Int -> Doc Text
toborder Alignment
a Int
w = forall a. HasChars a => a -> Doc a
literal forall a b. (a -> b) -> a -> b
$ case Alignment
a of
                          Alignment
AlignLeft    -> Text
":" forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int
w forall a. Num a => a -> a -> a
+ Int
1) Text
"-"
                          Alignment
AlignCenter  -> Text
":" forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate Int
w Text
"-" forall a. Semigroup a => a -> a -> a
<> Text
":"
                          Alignment
AlignRight   -> Int -> Text -> Text
T.replicate (Int
w forall a. Num a => a -> a -> a
+ Int
1) Text
"-" forall a. Semigroup a => a -> a -> a
<> Text
":"
                          Alignment
AlignDefault -> Int -> Text -> Text
T.replicate (Int
w forall a. Num a => a -> a -> a
+ Int
2) Text
"-"
  -- 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 :: Doc Text
header = if Bool
headless
                  then [Doc Text] -> Doc Text
torow (forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Alignment]
aligns) forall a. Doc a
empty)
                  else [Doc Text] -> Doc Text
torow [Doc Text]
rawHeaders
  let border :: Doc Text
border = forall a. IsString a => Doc a -> Doc a
nowrap forall a b. (a -> b) -> a -> b
$ forall a. HasChars a => a -> Doc a
literal Text
"|" forall a. Semigroup a => a -> a -> a
<> forall a. [Doc a] -> Doc a
hcat (forall a. a -> [a] -> [a]
intersperse (forall a. HasChars a => a -> Doc a
literal Text
"|") forall a b. (a -> b) -> a -> b
$
                        forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Alignment -> Int -> Doc Text
toborder [Alignment]
aligns [Int]
pipeWidths) forall a. Semigroup a => a -> a -> a
<> forall a. HasChars a => a -> Doc a
literal Text
"|"
  let body :: Doc Text
body   = forall a. [Doc a] -> Doc a
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [Doc Text] -> Doc Text
torow [[Doc Text]]
rawRows
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Text
header forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
border forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
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 :: forall (m :: * -> *).
PandocMonad m =>
WriterOptions
-> Bool
-> Bool
-> [Alignment]
-> [Double]
-> [Doc Text]
-> [[Doc Text]]
-> MD m (Doc Text)
pandocTable WriterOptions
opts Bool
multiline Bool
headless [Alignment]
aligns [Double]
widths [Doc Text]
rawHeaders [[Doc Text]]
rawRows = do
  let isSimple :: Bool
isSimple = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Eq a => a -> a -> Bool
==Double
0) [Double]
widths
  let alignHeader :: Alignment -> Int -> Doc a -> Doc a
alignHeader Alignment
alignment = case Alignment
alignment of
                                Alignment
AlignLeft    -> forall a. HasChars a => Int -> Doc a -> Doc a
lblock
                                Alignment
AlignCenter  -> forall a. HasChars a => Int -> Doc a -> Doc a
cblock
                                Alignment
AlignRight   -> forall a. HasChars a => Int -> Doc a -> Doc a
rblock
                                Alignment
AlignDefault -> forall a. HasChars a => Int -> Doc a -> Doc a
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 :: [Doc Text] -> Int
numChars    = (forall a. Num a => a -> a -> a
+ Int
2) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. (IsString a, HasChars a) => Doc a -> Int
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 :: [Doc Text] -> Int
minNumChars = (forall a. Num a => a -> a -> a
+ Int
2) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. HasChars a => Doc a -> Int
minOffset
  let columns :: [[Doc Text]]
columns = forall a. [[a]] -> [[a]]
transpose ([Doc Text]
rawHeaders forall a. a -> [a] -> [a]
: [[Doc Text]]
rawRows)
  -- minimal column width without wrapping a single word
  let relWidth :: a -> [Doc Text] -> Int
relWidth a
w [Doc Text]
col =
         forall a. Ord a => a -> a -> a
max (forall a b. (RealFrac a, Integral b) => a -> b
floor forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (WriterOptions -> Int
writerColumns WriterOptions
opts forall a. Num a => a -> a -> a
- Int
1) forall a. Num a => a -> a -> a
* a
w)
             (if WriterOptions -> WrapOption
writerWrapText WriterOptions
opts forall a. Eq a => a -> a -> Bool
== WrapOption
WrapAuto
                 then [Doc Text] -> Int
minNumChars [Doc Text]
col
                 else [Doc Text] -> Int
numChars [Doc Text]
col)
  let widthsInChars :: [Int]
widthsInChars
        | Bool
isSimple  = forall a b. (a -> b) -> [a] -> [b]
map [Doc Text] -> Int
numChars [[Doc Text]]
columns
        | Bool
otherwise = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a}. RealFrac a => a -> [Doc Text] -> Int
relWidth [Double]
widths [[Doc Text]]
columns
  let makeRow :: [Doc Text] -> Doc Text
makeRow = forall a. [Doc a] -> Doc a
hcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse (forall a. HasChars a => Int -> Doc a -> Doc a
lblock Int
1 (forall a. HasChars a => a -> Doc a
literal Text
" ")) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                   forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 forall {a}. HasChars a => Alignment -> Int -> Doc a -> Doc a
alignHeader [Alignment]
aligns [Int]
widthsInChars
  let rows' :: [Doc Text]
rows' = forall a b. (a -> b) -> [a] -> [b]
map [Doc Text] -> Doc Text
makeRow [[Doc Text]]
rawRows
  let head' :: Doc Text
head' = [Doc Text] -> Doc Text
makeRow [Doc Text]
rawHeaders
  let underline :: Doc Text
underline = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse (forall a. HasChars a => a -> Doc a
literal Text
" ") forall a b. (a -> b) -> a -> b
$
                  forall a b. (a -> b) -> [a] -> [b]
map (\Int
width -> forall a. HasChars a => a -> Doc a
literal (Int -> Text -> Text
T.replicate Int
width Text
"-")) [Int]
widthsInChars
  let border :: Doc Text
border
        | Bool
multiline = forall a. HasChars a => a -> Doc a
literal (Int -> Text -> Text
T.replicate (forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
widthsInChars forall a. Num a => a -> a -> a
+
                        forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
widthsInChars forall a. Num a => a -> a -> a
- Int
1) Text
"-")
        | Bool
headless  = Doc Text
underline
        | Bool
otherwise = forall a. Doc a
empty
  let head'' :: Doc Text
head'' = if Bool
headless
                  then forall a. Doc a
empty
                  else Doc Text
border forall a. Semigroup a => a -> a -> a
<> forall a. Doc a
cr forall a. Semigroup a => a -> a -> a
<> Doc Text
head'
  let body :: Doc Text
body = if Bool
multiline
                then forall a. [Doc a] -> Doc a
vsep [Doc Text]
rows' forall a. Doc a -> Doc a -> Doc a
$$
                     if forall (t :: * -> *) a. Foldable t => t a -> Int
length [Doc Text]
rows' forall a. Ord a => a -> a -> Bool
< Int
2
                        then forall a. Doc a
blankline -- #4578
                        else forall a. Doc a
empty
                else forall a. [Doc a] -> Doc a
vcat [Doc Text]
rows'
  let bottom :: Doc Text
bottom = if Bool
headless
                  then Doc Text
underline
                  else Doc Text
border
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Doc Text
head'' forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
underline forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
body forall a. Doc a -> Doc a -> Doc a
$$ Doc Text
bottom