{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TupleSections #-}
module Text.Pandoc.Writers.AnnotatedTable
( toTable
, fromTable
, Table(..)
, TableHead(..)
, TableBody(..)
, TableFoot(..)
, HeaderRow(..)
, BodyRow(..)
, RowNumber(..)
, RowHead
, RowBody
, Cell(..)
, ColNumber(..)
)
where
import Control.Monad.RWS.Strict
hiding ( (<>) )
import Data.Generics ( Data
, Typeable
)
import Data.List.NonEmpty ( NonEmpty(..) )
import GHC.Generics ( Generic )
import qualified Text.Pandoc.Builder as B
data Table = Table B.Attr B.Caption [B.ColSpec] TableHead [TableBody] TableFoot
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
data TableHead = TableHead B.Attr [HeaderRow]
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
data TableBody = TableBody B.Attr B.RowHeadColumns [HeaderRow] [BodyRow]
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
data TableFoot = TableFoot B.Attr [HeaderRow]
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
data HeaderRow = HeaderRow B.Attr RowNumber [Cell]
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
data BodyRow = BodyRow B.Attr RowNumber RowHead RowBody
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
newtype RowNumber = RowNumber Int
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Num, Enum)
type RowHead = [Cell]
type RowBody = [Cell]
data Cell = Cell (NonEmpty B.ColSpec) ColNumber B.Cell
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
newtype ColNumber = ColNumber Int
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Num, Enum)
toTable
:: B.Attr
-> B.Caption
-> [B.ColSpec]
-> B.TableHead
-> [B.TableBody]
-> B.TableFoot
-> Table
toTable attr cap cs th tbs tf = Table attr cap cs th' tbs' tf'
where
(th', tbs', tf') = fst $ evalRWS (annotateTable th tbs tf) (cs, length cs) 0
type AnnM a = RWS ([B.ColSpec], Int) () RowNumber a
incRowNumber :: AnnM RowNumber
incRowNumber = do
rn <- get
put $ rn + 1
return rn
annotateTable
:: B.TableHead
-> [B.TableBody]
-> B.TableFoot
-> AnnM (TableHead, [TableBody], TableFoot)
annotateTable th tbs tf = do
th' <- annotateTableHead th
tbs' <- traverse annotateTableBody tbs
tf' <- annotateTableFoot tf
return (th', tbs', tf')
annotateTableHead :: B.TableHead -> AnnM TableHead
annotateTableHead (B.TableHead attr rows) =
TableHead attr <$> annotateHeaderSection rows
annotateTableBody :: B.TableBody -> AnnM TableBody
annotateTableBody (B.TableBody attr rhc th tb) = do
twidth <- asks snd
let rhc' = max 0 $ min (B.RowHeadColumns twidth) rhc
th' <- annotateHeaderSection th
tb' <- annotateBodySection rhc' tb
return $ TableBody attr rhc' th' tb'
annotateTableFoot :: B.TableFoot -> AnnM TableFoot
annotateTableFoot (B.TableFoot attr rows) =
TableFoot attr <$> annotateHeaderSection rows
annotateHeaderSection :: [B.Row] -> AnnM [HeaderRow]
annotateHeaderSection rows = do
colspec <- asks fst
let hangcolspec = (1, ) <$> colspec
annotateHeaderSection' hangcolspec id $ B.clipRows rows
where
annotateHeaderSection' oldHang acc (B.Row attr cells : rs) = do
let (_, newHang, cells', _) =
annotateRowSection 0 oldHang $ cells <> repeat B.emptyCell
n <- incRowNumber
let annRow = HeaderRow attr n cells'
annotateHeaderSection' newHang (acc . (annRow :)) rs
annotateHeaderSection' _ acc [] = return $ acc []
annotateBodySection :: B.RowHeadColumns -> [B.Row] -> AnnM [BodyRow]
annotateBodySection (B.RowHeadColumns rhc) rows = do
colspec <- asks fst
let colspec' = (1, ) <$> colspec
let (stubspec, bodyspec) = splitAt rhc colspec'
normalizeBodySection' stubspec bodyspec id $ B.clipRows rows
where
normalizeBodySection' headHang bodyHang acc (B.Row attr cells : rs) = do
let (colnum, headHang', rowStub, cells') =
annotateRowSection 0 headHang $ cells <> repeat B.emptyCell
let (_, bodyHang', rowBody, _) = annotateRowSection colnum bodyHang cells'
n <- incRowNumber
let annRow = BodyRow attr n rowStub rowBody
normalizeBodySection' headHang' bodyHang' (acc . (annRow :)) rs
normalizeBodySection' _ _ acc [] = return $ acc []
annotateRowSection
:: ColNumber
-> [(B.RowSpan, B.ColSpec)]
-> [B.Cell]
-> (ColNumber, [(B.RowSpan, B.ColSpec)], [Cell], [B.Cell])
annotateRowSection !colnum oldHang cells
| (o, colspec) : os <- oldHang
, o > 1
= let (colnum', newHang, newCell, cells') =
annotateRowSection (colnum + 1) os cells
in (colnum', (o - 1, colspec) : newHang, newCell, cells')
| c : cells' <- cells
, (h, w) <- getDim c
, w' <- max 1 w
, (w'', cellHang@(chStart : chRest), oldHang') <- splitCellHang h w' oldHang
= let c' = setW w'' c
annCell = Cell (snd <$> chStart :| chRest) colnum c'
colnum' = colnum + ColNumber (getColSpan w'')
(colnum'', newHang, newCells, remainCells) =
annotateRowSection colnum' oldHang' cells'
in (colnum'', cellHang <> newHang, annCell : newCells, remainCells)
| otherwise
= (colnum, [], [], cells)
where
getColSpan (B.ColSpan x) = x
getDim (B.Cell _ _ h w _) = (h, w)
setW w (B.Cell a b h _ c) = B.Cell a b h w c
splitCellHang
:: B.RowSpan
-> B.ColSpan
-> [(B.RowSpan, B.ColSpec)]
-> (B.ColSpan, [(B.RowSpan, B.ColSpec)], [(B.RowSpan, B.ColSpec)])
splitCellHang h n = go 0
where
go acc ((1, spec) : ls) | acc < n =
let (acc', hang, ls') = go (acc + 1) ls in (acc', (h, spec) : hang, ls')
go acc l = (acc, [], l)
fromTable
:: Table
-> ( B.Attr
, B.Caption
, [B.ColSpec]
, B.TableHead
, [B.TableBody]
, B.TableFoot
)
fromTable (Table attr cap cs th tbs tf) = (attr, cap, cs, th', tbs', tf')
where
th' = fromTableHead th
tbs' = map fromTableBody tbs
tf' = fromTableFoot tf
fromTableHead :: TableHead -> B.TableHead
fromTableHead (TableHead attr rows) = B.TableHead attr $ fromHeaderRow <$> rows
fromTableBody :: TableBody -> B.TableBody
fromTableBody (TableBody attr rhc th tb) =
B.TableBody attr rhc (fromHeaderRow <$> th) (fromBodyRow <$> tb)
fromTableFoot :: TableFoot -> B.TableFoot
fromTableFoot (TableFoot attr rows) = B.TableFoot attr $ fromHeaderRow <$> rows
fromHeaderRow :: HeaderRow -> B.Row
fromHeaderRow (HeaderRow attr _ cells) = B.Row attr $ fromCell <$> cells
fromBodyRow :: BodyRow -> B.Row
fromBodyRow (BodyRow attr _ rh rb) =
B.Row attr ((fromCell <$> rh) <> (fromCell <$> rb))
fromCell :: Cell -> B.Cell
fromCell (Cell _ _ c) = c