pandoc-2.18: src/Text/Pandoc/Parsing/GridTable.hs
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Text.Pandoc.Parsing.GridTable
Copyright : Copyright (C) 2006-2022 John MacFarlane
License : GPL-2.0-or-later
Maintainer : John MacFarlane <jgm@berkeley.edu>
Shared parsers for plaintext tables.
-}
module Text.Pandoc.Parsing.GridTable
( gridTableWith
, gridTableWith'
, tableWith
, tableWith'
, widthsFromIndices
-- * Components of a plain-text table
, TableComponents (..)
, TableNormalization (..)
, toTableComponents
, toTableComponents'
)
where
import Control.Monad (guard)
import Data.List (transpose)
import Data.Text (Text)
import Text.Pandoc.Options (ReaderOptions (readerColumns))
import Text.Pandoc.Builder (Blocks)
import Text.Pandoc.Definition
import Text.Pandoc.Parsing.Capabilities
import Text.Pandoc.Parsing.General
import Text.Pandoc.Parsing.Types
import Text.Pandoc.Shared (compactify, splitTextByIndices, trim, trimr)
import Text.Pandoc.Sources
import Text.Parsec
( Stream (..), many1, notFollowedBy, option, optional, sepEndBy1, try )
import qualified Data.Text as T
import qualified Text.Pandoc.Builder as B
-- | Collection of components making up a Table block.
data TableComponents = TableComponents
{ tableAttr :: Attr
, tableCaption :: Caption
, tableColSpecs :: [ColSpec]
, tableHead :: TableHead
, tableBodies :: [TableBody]
, tableFoot :: TableFoot
}
-- | Creates a table block from the collection of table parts.
tableFromComponents :: TableComponents -> Blocks
tableFromComponents (TableComponents attr capt colspecs th tb tf) =
B.tableWith attr capt colspecs th tb tf
-- | Bundles basic table components into a single value.
toTableComponents :: [Alignment] -> [Double] -> [Blocks] -> [[Blocks]]
-> TableComponents
toTableComponents = toTableComponents' NoNormalization
-- | Bundles basic table components into a single value, performing
-- normalizations as necessary.
toTableComponents' :: TableNormalization
-> [Alignment] -> [Double] -> [Blocks] -> [[Blocks]]
-> TableComponents
toTableComponents' normalization aligns widths heads rows =
let th = TableHead nullAttr (toHeaderRow normalization heads)
tb = TableBody nullAttr 0 [] (map toRow rows)
tf = TableFoot nullAttr []
colspecs = toColSpecs aligns widths
in TableComponents nullAttr B.emptyCaption colspecs th [tb] tf
-- | Combine a list of column alignments and column widths into a list
-- of column specifiers. Both input lists should have the same length.
toColSpecs :: [Alignment] -- ^ column alignments
-> [Double] -- ^ column widths
-> [ColSpec]
toColSpecs aligns widths = zip aligns (map fromWidth widths')
where
fromWidth n
| n > 0 = ColWidth n
| otherwise = ColWidthDefault
-- renormalize widths if greater than 100%:
totalWidth = sum widths
widths' = if totalWidth < 1
then widths
else map (/ totalWidth) widths
-- | Whether the table header should be normalized, i.e., whether an header row
-- with only empty cells should be omitted.
data TableNormalization
= NoNormalization
| NormalizeHeader
--
-- Grid Tables
--
-- | Parse a grid table: starts with row of '-' on top, then header
-- (which may be grid), then the rows, which may be grid, separated by
-- blank lines, and ending with a footer (dashed line followed by blank
-- line).
gridTableWith :: (Monad m, Monad mf, HasLastStrPosition st, HasReaderOptions st)
=> ParserT Sources st m (mf Blocks) -- ^ Block list parser
-> Bool -- ^ Headerless table
-> ParserT Sources st m (mf Blocks)
gridTableWith blocks headless =
tableWith (gridTableHeader headless blocks) (gridTableRow blocks)
(gridTableSep '-') gridTableFooter
-- | Like @'gridTableWith'@, but returns 'TableComponents' instead of a
-- Table.
gridTableWith' :: (Monad m, Monad mf,
HasReaderOptions st, HasLastStrPosition st)
=> TableNormalization
-> ParserT Sources st m (mf Blocks) -- ^ Block list parser
-> Bool -- ^ Headerless table
-> ParserT Sources st m (mf TableComponents)
gridTableWith' normalization blocks headless =
tableWith' normalization
(gridTableHeader headless blocks) (gridTableRow blocks)
(gridTableSep '-') gridTableFooter
gridTableSplitLine :: [Int] -> Text -> [Text]
gridTableSplitLine indices line = map removeFinalBar $ tail $
splitTextByIndices (init indices) $ trimr line
-- | Parses a grid segment, where the grid line is made up from the
-- given char and terminated with a plus (@+@). The grid line may begin
-- and/or end with a colon, signaling column alignment. Returns the size
-- of the grid part and column alignment
gridPart :: Monad m => Char -> ParserT Sources st m (Int, Alignment)
gridPart ch = do
leftColon <- option False (True <$ char ':')
dashes <- many1 (char ch)
rightColon <- option False (True <$ char ':')
char '+'
let lengthDashes = length dashes + (if leftColon then 1 else 0) +
(if rightColon then 1 else 0)
let alignment = case (leftColon, rightColon) of
(True, True) -> AlignCenter
(True, False) -> AlignLeft
(False, True) -> AlignRight
(False, False) -> AlignDefault
return (lengthDashes + 1, alignment)
gridDashedLines :: Monad m
=> Char -> ParserT Sources st m [(Int, Alignment)]
gridDashedLines ch = try $ char '+' >> many1 (gridPart ch) <* blankline
removeFinalBar :: Text -> Text
removeFinalBar = T.dropWhileEnd go . T.dropWhileEnd (=='|')
where
go c = T.any (== c) " \t"
-- | Separator between rows of grid table.
gridTableSep :: Monad m => Char -> ParserT Sources st m Char
gridTableSep ch = try $ gridDashedLines ch >> return '\n'
-- | Parse header for a grid table.
gridTableHeader :: (Monad m, Monad mf, HasLastStrPosition st)
=> Bool -- ^ Headerless table
-> ParserT Sources st m (mf Blocks)
-> ParserT Sources st m (mf [Blocks], [Alignment], [Int])
gridTableHeader True _ = do
optional blanklines
dashes <- gridDashedLines '-'
let aligns = map snd dashes
let lines' = map fst dashes
let indices = scanl (+) 0 lines'
return (return [], aligns, indices)
gridTableHeader False blocks = try $ do
optional blanklines
dashes <- gridDashedLines '-'
rawContent <- many1 (notFollowedBy (gridTableSep '=') >> char '|' >>
T.pack <$> many1Till anyChar newline)
underDashes <- gridDashedLines '='
guard $ length dashes == length underDashes
let lines' = map fst underDashes
let indices = scanl (+) 0 lines'
let aligns = map snd underDashes
let rawHeads = map (T.unlines . map trim) $ transpose
$ map (gridTableSplitLine indices) rawContent
heads <- sequence <$> mapM (parseFromString' blocks . trim) rawHeads
return (heads, aligns, indices)
gridTableRawLine :: (Stream s m Char, UpdateSourcePos s Char)
=> [Int] -> ParserT s st m [Text]
gridTableRawLine indices = do
char '|'
line <- many1Till anyChar newline
return (gridTableSplitLine indices $ T.pack line)
-- | Parse row of grid table.
gridTableRow :: (Monad m, Monad mf, HasLastStrPosition st)
=> ParserT Sources st m (mf Blocks)
-> [Int]
-> ParserT Sources st m (mf [Blocks])
gridTableRow blocks indices = do
colLines <- many1 (gridTableRawLine indices)
let cols = map ((<> "\n") . T.unlines . removeOneLeadingSpace) $
transpose colLines
compactifyCell bs = case compactify [bs] of
[] -> mempty
x:_ -> x
cells <- sequence <$> mapM (parseFromString' blocks) cols
return $ fmap (map compactifyCell) cells
removeOneLeadingSpace :: [Text] -> [Text]
removeOneLeadingSpace xs =
if all startsWithSpace xs
then map (T.drop 1) xs
else xs
where startsWithSpace t = case T.uncons t of
Nothing -> True
Just (c, _) -> c == ' '
-- | Parse footer for a grid table.
gridTableFooter :: (Stream s m Char, UpdateSourcePos s Char)
=> ParserT s st m ()
gridTableFooter = optional blanklines
---
-- | Parse a table using 'headerParser', 'rowParser',
-- 'lineParser', and 'footerParser'.
tableWith :: (Stream s m Char, UpdateSourcePos s Char,
HasReaderOptions st, Monad mf)
=> ParserT s st m (mf [Blocks], [Alignment], [Int]) -- ^ header parser
-> ([Int] -> ParserT s st m (mf [Blocks])) -- ^ row parser
-> ParserT s st m sep -- ^ line parser
-> ParserT s st m end -- ^ footer parser
-> ParserT s st m (mf Blocks)
tableWith hp rp lp fp = fmap tableFromComponents <$>
tableWith' NoNormalization hp rp lp fp
tableWith' :: (Stream s m Char, UpdateSourcePos s Char,
HasReaderOptions st, Monad mf)
=> TableNormalization
-> ParserT s st m (mf [Blocks], [Alignment], [Int]) -- ^ header parser
-> ([Int] -> ParserT s st m (mf [Blocks])) -- ^ row parser
-> ParserT s st m sep -- ^ line parser
-> ParserT s st m end -- ^ footer parser
-> ParserT s st m (mf TableComponents)
tableWith' n11n headerParser rowParser lineParser footerParser = try $ do
(heads, aligns, indices) <- headerParser
lines' <- sequence <$> rowParser indices `sepEndBy1` lineParser
footerParser
numColumns <- getOption readerColumns
let widths = if null indices
then replicate (length aligns) 0.0
else widthsFromIndices numColumns indices
return $ toTableComponents' n11n aligns widths <$> heads <*> lines'
toRow :: [Blocks] -> Row
toRow = Row nullAttr . map B.simpleCell
toHeaderRow :: TableNormalization -> [Blocks] -> [Row]
toHeaderRow = \case
NoNormalization -> \l -> [toRow l | not (null l)]
NormalizeHeader -> \l -> [toRow l | not (null l) && not (all null l)]
-- Calculate relative widths of table columns, based on indices
widthsFromIndices :: Int -- Number of columns on terminal
-> [Int] -- Indices
-> [Double] -- Fractional relative sizes of columns
widthsFromIndices _ [] = []
widthsFromIndices numColumns' indices =
let numColumns = max numColumns' (if null indices then 0 else last indices)
lengths' = zipWith (-) indices (0:indices)
lengths = reverse $
case reverse lengths' of
[] -> []
[x] -> [x]
-- compensate for the fact that intercolumn
-- spaces are counted in widths of all columns
-- but the last...
(x:y:zs) -> if x < y && y - x <= 2
then y:y:zs
else x:y:zs
totLength = sum lengths
quotient = if totLength > numColumns
then fromIntegral totLength
else fromIntegral numColumns
fracs = map (\l -> fromIntegral l / quotient) lengths in
tail fracs