[API change] Rename Writers.Tables and its contents (#6679)
Writers.Tables is now Writers.AnnotatedTable. All of the types and functions in it have had the "Ann" removed from them. Now it is expected that the module be imported qualified.
This commit is contained in:
Christian Despres
GitHub
parent
6fda8cfa28
commit
22babd5382
6 changed files with 390 additions and 379 deletions
|
|
@ -553,7 +553,7 @@ library
|
|||
Text.Pandoc.Writers.Math,
|
||||
Text.Pandoc.Writers.Shared,
|
||||
Text.Pandoc.Writers.OOXML,
|
||||
Text.Pandoc.Writers.Tables,
|
||||
Text.Pandoc.Writers.AnnotatedTable,
|
||||
Text.Pandoc.Lua,
|
||||
Text.Pandoc.PDF,
|
||||
Text.Pandoc.UTF8,
|
||||
|
|
@ -821,7 +821,7 @@ test-suite test-pandoc
|
|||
Tests.Writers.Powerpoint
|
||||
Tests.Writers.OOXML
|
||||
Tests.Writers.Ms
|
||||
Tests.Writers.Tables
|
||||
Tests.Writers.AnnotatedTable
|
||||
if os(windows)
|
||||
cpp-options: -D_WINDOWS
|
||||
default-language: Haskell2010
|
||||
|
|
|
|||
300
src/Text/Pandoc/Writers/AnnotatedTable.hs
Normal file
300
src/Text/Pandoc/Writers/AnnotatedTable.hs
Normal file
|
|
@ -0,0 +1,300 @@
|
|||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
{- |
|
||||
Module : Text.Pandoc.Writers.AnnotatedTable
|
||||
Copyright : Copyright 2020 Christian Despres
|
||||
License : GNU GPL, version 2 or above
|
||||
|
||||
Maintainer : Christian Despres <christian.j.j.despres@gmail.com>
|
||||
Stability : alpha
|
||||
Portability : portable
|
||||
|
||||
Definitions and conversion functions for an intermediate 'Table' and
|
||||
related types, which annotates the existing Pandoc 'B.Table' types
|
||||
with additional inferred information. For use in writers that need to
|
||||
know the details of columns that cells span, row numbers, and the
|
||||
cells that are in the row head.
|
||||
-}
|
||||
|
||||
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
|
||||
|
||||
-- | An annotated table type, corresponding to the Pandoc 'B.Table'
|
||||
-- constructor and the HTML @\<table\>@ element. It records the data
|
||||
-- of the columns that cells span, the cells in the row head, the row
|
||||
-- numbers of rows, and the column numbers of cells, in addition to
|
||||
-- the data in a 'B.Table'. The type itself does not enforce any
|
||||
-- guarantees about the consistency of this data. Use 'toTable' to
|
||||
-- produce a 'Table' from a Pandoc 'B.Table'.
|
||||
data Table = Table B.Attr B.Caption [B.ColSpec] TableHead [TableBody] TableFoot
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
|
||||
|
||||
-- | An annotated table head, corresponding to a Pandoc 'B.TableHead'
|
||||
-- and the HTML @\<thead\>@ element.
|
||||
data TableHead = TableHead B.Attr [HeaderRow]
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
|
||||
|
||||
-- | An annotated table body, with an intermediate head and body,
|
||||
-- corresponding to a Pandoc 'B.TableBody' and the HTML @\<tbody\>@
|
||||
-- element.
|
||||
data TableBody = TableBody B.Attr B.RowHeadColumns [HeaderRow] [BodyRow]
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
|
||||
|
||||
-- | An annotated table foot, corresponding to a Pandoc 'B.TableFoot'
|
||||
-- and the HTML @\<tfoot\>@ element.
|
||||
data TableFoot = TableFoot B.Attr [HeaderRow]
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
|
||||
|
||||
-- | An annotated header row, corresponding to a Pandoc 'B.Row' and
|
||||
-- the HTML @\<tr\>@ element, and also recording the row number of the
|
||||
-- row. All the cells in a 'HeaderRow' are header (@\<th\>@) cells.
|
||||
data HeaderRow = HeaderRow B.Attr RowNumber [Cell]
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
|
||||
|
||||
-- | An annotated body row, corresponding to a Pandoc 'B.Row' and the
|
||||
-- HTML @\<tr\>@ element, and also recording its row number and
|
||||
-- separating the row head cells from the row body cells.
|
||||
data BodyRow = BodyRow B.Attr RowNumber RowHead RowBody
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
|
||||
|
||||
-- | The row number of a row. Note that rows are numbered continuously
|
||||
-- from zero from the start of the table, so the first row in a table
|
||||
-- body, for instance, may have a large 'RowNumber'.
|
||||
newtype RowNumber = RowNumber Int
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Num, Enum)
|
||||
|
||||
-- | The head of a body row; the portion of the row lying in the stub
|
||||
-- of the 'TableBody'. Its cells correspond to HTML @\<th\>@ cells.
|
||||
type RowHead = [Cell]
|
||||
|
||||
-- | The body of a body row; the portion of the row lying after the
|
||||
-- stub of the 'TableBody'. Its cells correspond to HTML @\<td\>@
|
||||
-- cells.
|
||||
type RowBody = [Cell]
|
||||
|
||||
-- | An annotated table cell, wrapping a Pandoc 'B.Cell' with its
|
||||
-- 'ColNumber' and the 'B.ColSpec' data for the columns that the cell
|
||||
-- spans.
|
||||
data Cell = Cell (NonEmpty B.ColSpec) ColNumber B.Cell
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
|
||||
|
||||
-- | The column number of a cell, meaning the column number of the
|
||||
-- first column that the cell spans, if the table were laid on a
|
||||
-- grid. Columns are numbered starting from zero.
|
||||
newtype ColNumber = ColNumber Int
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Num, Enum)
|
||||
|
||||
-- | Convert a Pandoc 'B.Table' to an annotated 'Table'. This function
|
||||
-- also performs the same normalization that the 'B.table' builder
|
||||
-- does (fixing overlapping cells, cells that protrude out of their
|
||||
-- table section, and so on). If the input table happens to satisfy
|
||||
-- the conditions that 'B.table' guarantees, then the resulting
|
||||
-- 'Table' will be identical, save for the addition of the inferred
|
||||
-- table information.
|
||||
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
|
||||
|
||||
-- | Internal monad for annotating a table, passing in the 'B.ColSpec'
|
||||
-- data for the table, the grid width, and the current 'RowNumber' to
|
||||
-- be referenced or updated.
|
||||
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 []
|
||||
|
||||
-- | Lay out a section of a 'Table' row on a grid row, annotating the
|
||||
-- cells with the 'B.ColSpec' data for the columns that they
|
||||
-- span. Performs the same normalization as 'B.placeRowSection'.
|
||||
annotateRowSection
|
||||
:: ColNumber -- ^ The current column number
|
||||
-> [(B.RowSpan, B.ColSpec)] -- ^ The overhang of the previous grid row,
|
||||
-- with column data
|
||||
-> [B.Cell] -- ^ The cells to annotate
|
||||
-> (ColNumber, [(B.RowSpan, B.ColSpec)], [Cell], [B.Cell]) -- ^ The new
|
||||
-- column
|
||||
-- number,
|
||||
-- overhang,
|
||||
-- annotated
|
||||
-- cells,
|
||||
-- and
|
||||
-- remaining
|
||||
-- cells
|
||||
annotateRowSection !colnum oldHang cells
|
||||
-- If the grid has overhang at our position, try to re-lay in
|
||||
-- the next position.
|
||||
| (o, colspec) : os <- oldHang
|
||||
, o > 1
|
||||
= let (colnum', newHang, newCell, cells') =
|
||||
annotateRowSection (colnum + 1) os cells
|
||||
in (colnum', (o - 1, colspec) : newHang, newCell, cells')
|
||||
-- Otherwise if there is any available width, place the cell and
|
||||
-- continue.
|
||||
| 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 there is no room in the section
|
||||
| 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
|
||||
|
||||
-- | In @'splitCellHang' rs cs coldata@, with @rs@ the height of a
|
||||
-- cell that lies at the beginning of @coldata@, and @cs@ its width
|
||||
-- (which is not assumed to fit in the available space), return the
|
||||
-- actual width of the cell (what will fit in the available space),
|
||||
-- the data for the columns that the cell spans (including updating
|
||||
-- the overhang to equal @rs@), and the remaining column data.
|
||||
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)
|
||||
|
||||
-- | Convert an annotated 'Table' to a Pandoc
|
||||
-- 'B.Table'. This is the inverse of 'toTable' on
|
||||
-- well-formed tables (i.e. tables satisfying the guarantees of
|
||||
-- 'B.table').
|
||||
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
|
||||
|
|
@ -56,7 +56,7 @@ import Text.Pandoc.Templates (renderTemplate)
|
|||
import Text.Pandoc.Walk
|
||||
import Text.Pandoc.Writers.Math
|
||||
import Text.Pandoc.Writers.Shared
|
||||
import Text.Pandoc.Writers.Tables
|
||||
import qualified Text.Pandoc.Writers.AnnotatedTable as Ann
|
||||
import Text.Pandoc.XML (escapeStringForXML, fromEntities, toEntities,
|
||||
html5Attributes, html4Attributes, rdfaAttributes)
|
||||
import qualified Text.Blaze.XHtml5 as H5
|
||||
|
|
@ -904,13 +904,13 @@ blockToHtml opts (DefinitionList lst) = do
|
|||
intersperse (nl opts) defs') lst
|
||||
defList opts contents
|
||||
blockToHtml opts (Table attr caption colspecs thead tbody tfoot) =
|
||||
tableToHtml opts (toAnnTable attr caption colspecs thead tbody tfoot)
|
||||
tableToHtml opts (Ann.toTable attr caption colspecs thead tbody tfoot)
|
||||
|
||||
tableToHtml :: PandocMonad m
|
||||
=> WriterOptions
|
||||
-> AnnTable
|
||||
-> Ann.Table
|
||||
-> StateT WriterState m Html
|
||||
tableToHtml opts (AnnTable attr caption colspecs thead tbodies _tfoot) = do
|
||||
tableToHtml opts (Ann.Table attr caption colspecs thead tbodies _tfoot) = do
|
||||
captionDoc <- case caption of
|
||||
Caption _ [] -> return mempty
|
||||
Caption _ longCapt -> do
|
||||
|
|
@ -941,16 +941,16 @@ tableToHtml opts (AnnTable attr caption colspecs thead tbodies _tfoot) = do
|
|||
|
||||
tableBodyToHtml :: PandocMonad m
|
||||
=> WriterOptions
|
||||
-> AnnTableBody
|
||||
-> Ann.TableBody
|
||||
-> StateT WriterState m Html
|
||||
tableBodyToHtml opts (AnnTableBody _attr _rowHeadCols _intm rows) =
|
||||
tableBodyToHtml opts (Ann.TableBody _attr _rowHeadCols _intm rows) =
|
||||
H.tbody <$> bodyRowsToHtml opts rows
|
||||
|
||||
tableHeadToHtml :: PandocMonad m
|
||||
=> WriterOptions
|
||||
-> AnnTableHead
|
||||
-> Ann.TableHead
|
||||
-> StateT WriterState m Html
|
||||
tableHeadToHtml opts (AnnTableHead attr rows) =
|
||||
tableHeadToHtml opts (Ann.TableHead attr rows) =
|
||||
if null rows || all isEmptyRow rows
|
||||
then return mempty
|
||||
else do
|
||||
|
|
@ -960,8 +960,8 @@ tableHeadToHtml opts (AnnTableHead attr rows) =
|
|||
headElement
|
||||
nl opts
|
||||
where
|
||||
isEmptyRow (AnnHeaderRow _attr _rownum cells) = all isEmptyCell cells
|
||||
isEmptyCell (AnnCell _colspecs _colnum cell) =
|
||||
isEmptyRow (Ann.HeaderRow _attr _rownum cells) = all isEmptyCell cells
|
||||
isEmptyCell (Ann.Cell _colspecs _colnum cell) =
|
||||
cell == Cell nullAttr AlignDefault (RowSpan 1) (ColSpan 1) []
|
||||
|
||||
|
||||
|
|
@ -970,26 +970,26 @@ data RowType = HeaderRow | FooterRow | BodyRow
|
|||
|
||||
data CellType = HeaderCell | BodyCell
|
||||
|
||||
data TableRow = TableRow RowType Attr RowNumber AnnRowHead AnnRowBody
|
||||
data TableRow = TableRow RowType Attr Ann.RowNumber Ann.RowHead Ann.RowBody
|
||||
|
||||
headerRowsToHtml :: PandocMonad m
|
||||
=> WriterOptions
|
||||
-> [AnnHeaderRow]
|
||||
-> [Ann.HeaderRow]
|
||||
-> StateT WriterState m Html
|
||||
headerRowsToHtml opts =
|
||||
rowListToHtml opts . map toTableRow
|
||||
where
|
||||
toTableRow (AnnHeaderRow attr rownum rowbody) =
|
||||
toTableRow (Ann.HeaderRow attr rownum rowbody) =
|
||||
TableRow HeaderRow attr rownum [] rowbody
|
||||
|
||||
bodyRowsToHtml :: PandocMonad m
|
||||
=> WriterOptions
|
||||
-> [AnnBodyRow]
|
||||
-> [Ann.BodyRow]
|
||||
-> StateT WriterState m Html
|
||||
bodyRowsToHtml opts =
|
||||
rowListToHtml opts . zipWith toTableRow [1..]
|
||||
where
|
||||
toTableRow rownum (AnnBodyRow attr _rownum rowhead rowbody) =
|
||||
toTableRow rownum (Ann.BodyRow attr _rownum rowhead rowbody) =
|
||||
TableRow BodyRow attr rownum rowhead rowbody
|
||||
|
||||
|
||||
|
|
@ -1036,9 +1036,9 @@ tableRowToHtml :: PandocMonad m
|
|||
-> StateT WriterState m Html
|
||||
tableRowToHtml opts (TableRow rowtype _attr rownum rowhead rowbody) = do
|
||||
let rowclass = A.class_ $ case rownum of
|
||||
RowNumber x | x `rem` 2 == 1 -> "odd"
|
||||
_ | rowtype /= HeaderRow -> "even"
|
||||
_ -> "header"
|
||||
Ann.RowNumber x | x `rem` 2 == 1 -> "odd"
|
||||
_ | rowtype /= HeaderRow -> "even"
|
||||
_ -> "header"
|
||||
let celltype = case rowtype of
|
||||
HeaderRow -> HeaderCell
|
||||
_ -> BodyCell
|
||||
|
|
@ -1068,9 +1068,9 @@ rowspanAttrib = \case
|
|||
cellToHtml :: PandocMonad m
|
||||
=> WriterOptions
|
||||
-> CellType
|
||||
-> AnnCell
|
||||
-> Ann.Cell
|
||||
-> StateT WriterState m Html
|
||||
cellToHtml opts celltype (AnnCell (colspec :| _) _colNum cell) =
|
||||
cellToHtml opts celltype (Ann.Cell (colspec :| _) _colNum cell) =
|
||||
let align = fst colspec
|
||||
in tableCellToHtml opts celltype align cell
|
||||
|
||||
|
|
|
|||
|
|
@ -1,291 +0,0 @@
|
|||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
{- |
|
||||
Module : Text.Pandoc.Writers.Tables
|
||||
Copyright : Copyright 2020 Christian Despres
|
||||
License : GNU GPL, version 2 or above
|
||||
|
||||
Maintainer : Christian Despres <christian.j.j.despres@gmail.com>
|
||||
Stability : alpha
|
||||
Portability : portable
|
||||
|
||||
Definitions and helper functions for an intermediate 'AnnTable' type,
|
||||
which annotates the existing 'Table' types with additional inferred
|
||||
information. For use in writers that need to know the details of
|
||||
columns that cells span, row numbers, and the cells that are in the
|
||||
row head.
|
||||
-}
|
||||
|
||||
module Text.Pandoc.Writers.Tables
|
||||
( toAnnTable
|
||||
, fromAnnTable
|
||||
, AnnTable(..)
|
||||
, AnnTableHead(..)
|
||||
, AnnTableBody(..)
|
||||
, AnnTableFoot(..)
|
||||
, AnnHeaderRow(..)
|
||||
, AnnBodyRow(..)
|
||||
, RowNumber(..)
|
||||
, AnnRowHead
|
||||
, AnnRowBody
|
||||
, AnnCell(..)
|
||||
, ColNumber(..)
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.RWS.Strict
|
||||
hiding ( (<>) )
|
||||
import Data.Generics ( Data
|
||||
, Typeable
|
||||
)
|
||||
import Data.List.NonEmpty ( NonEmpty(..) )
|
||||
import GHC.Generics ( Generic )
|
||||
import Text.Pandoc.Builder
|
||||
|
||||
-- | An annotated table type, corresponding to the 'Table' constructor
|
||||
-- and the HTML @\<table\>@ element. It records the data of the
|
||||
-- columns that cells span, the cells in the row head, the row numbers
|
||||
-- of rows, and the column numbers of cells, in addition to the data
|
||||
-- in a 'Table'. The type itself does not enforce any guarantees about
|
||||
-- the consistency of this data. Use 'toAnnTable' to produce an
|
||||
-- 'AnnTable' from a pandoc 'Table'.
|
||||
data AnnTable = AnnTable Attr Caption [ColSpec] AnnTableHead [AnnTableBody] AnnTableFoot
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
|
||||
|
||||
-- | An annotated table head, corresponding to 'TableHead' and the
|
||||
-- HTML @\<thead\>@ element.
|
||||
data AnnTableHead = AnnTableHead Attr [AnnHeaderRow]
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
|
||||
|
||||
-- | An annotated table body, with an intermediate head and body,
|
||||
-- corresponding to 'TableBody' and the HTML @\<tbody\>@ element.
|
||||
data AnnTableBody = AnnTableBody Attr RowHeadColumns [AnnHeaderRow] [AnnBodyRow]
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
|
||||
|
||||
-- | An annotated table foot, corresponding to 'TableFoot' and the
|
||||
-- HTML @\<tfoot\>@ element.
|
||||
data AnnTableFoot = AnnTableFoot Attr [AnnHeaderRow]
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
|
||||
|
||||
-- | An annotated header row, corresponding to 'Row' and the HTML
|
||||
-- @\<tr\>@ element, and also recording the row number of the row. All
|
||||
-- the cells in an 'AnnHeaderRow' are header (@\<th\>@) cells.
|
||||
data AnnHeaderRow = AnnHeaderRow Attr RowNumber [AnnCell]
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
|
||||
|
||||
-- | An annotated body row, corresponding to 'Row' and the HTML
|
||||
-- @\<tr\>@ element, and also recording its row number and separating
|
||||
-- the row head cells from the row body cells.
|
||||
data AnnBodyRow = AnnBodyRow Attr RowNumber AnnRowHead AnnRowBody
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
|
||||
|
||||
-- | The row number of a row. Note that rows are numbered continuously
|
||||
-- from zero from the start of the table, so the first row in a table
|
||||
-- body, for instance, may have a large 'RowNumber'.
|
||||
newtype RowNumber = RowNumber Int
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Num, Enum)
|
||||
|
||||
-- | The head of a body row; the portion of the row lying in the stub
|
||||
-- of the 'TableBody'. Its cells correspond to HTML @\<th\>@ cells.
|
||||
type AnnRowHead = [AnnCell]
|
||||
|
||||
-- | The body of a body row; the portion of the row lying after the
|
||||
-- stub of the 'TableBody'. Its cells correspond to HTML @\<td\>@
|
||||
-- cells.
|
||||
type AnnRowBody = [AnnCell]
|
||||
|
||||
-- | An annotated table cell, wrapping a 'Cell' with its 'ColNumber'
|
||||
-- and the 'ColSpec' data for the columns that the cell spans.
|
||||
data AnnCell = AnnCell (NonEmpty ColSpec) ColNumber Cell
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
|
||||
|
||||
-- | The column number of a cell, meaning the column number of the
|
||||
-- first column that the cell spans, if the table were laid on a
|
||||
-- grid. Columns are numbered starting from zero.
|
||||
newtype ColNumber = ColNumber Int
|
||||
deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Num, Enum)
|
||||
|
||||
-- | Convert a 'Table' to an 'AnnTable'. This function also performs
|
||||
-- the same normalization that the 'table' builder does (fixing
|
||||
-- overlapping cells, cells that protrude out of their table section,
|
||||
-- and so on). If the input table happens to satisfy the conditions
|
||||
-- that 'table' guarantees, then the resulting 'AnnTable' will be
|
||||
-- identical, save for the addition of the inferred table information.
|
||||
toAnnTable
|
||||
:: Attr
|
||||
-> Caption
|
||||
-> [ColSpec]
|
||||
-> TableHead
|
||||
-> [TableBody]
|
||||
-> TableFoot
|
||||
-> AnnTable
|
||||
toAnnTable attr cap cs th tbs tf = AnnTable attr cap cs th' tbs' tf'
|
||||
where
|
||||
(th', tbs', tf') = fst $ evalRWS (annotateTable th tbs tf) (cs, length cs) 0
|
||||
|
||||
-- | Internal monad for annotating a table, passing in the 'ColSpec'
|
||||
-- data for the table, the grid width, and the current 'RowNumber' to
|
||||
-- be referenced or updated.
|
||||
type AnnM a = RWS ([ColSpec], Int) () RowNumber a
|
||||
|
||||
incRowNumber :: AnnM RowNumber
|
||||
incRowNumber = do
|
||||
rn <- get
|
||||
put $ rn + 1
|
||||
return rn
|
||||
|
||||
annotateTable
|
||||
:: TableHead
|
||||
-> [TableBody]
|
||||
-> TableFoot
|
||||
-> AnnM (AnnTableHead, [AnnTableBody], AnnTableFoot)
|
||||
annotateTable th tbs tf = do
|
||||
th' <- annotateTableHead th
|
||||
tbs' <- traverse annotateTableBody tbs
|
||||
tf' <- annotateTableFoot tf
|
||||
return (th', tbs', tf')
|
||||
|
||||
annotateTableHead :: TableHead -> AnnM AnnTableHead
|
||||
annotateTableHead (TableHead attr rows) =
|
||||
AnnTableHead attr <$> annotateHeaderSection rows
|
||||
|
||||
annotateTableBody :: TableBody -> AnnM AnnTableBody
|
||||
annotateTableBody (TableBody attr rhc th tb) = do
|
||||
twidth <- asks snd
|
||||
let rhc' = max 0 $ min (RowHeadColumns twidth) rhc
|
||||
th' <- annotateHeaderSection th
|
||||
tb' <- annotateBodySection rhc' tb
|
||||
return $ AnnTableBody attr rhc' th' tb'
|
||||
|
||||
annotateTableFoot :: TableFoot -> AnnM AnnTableFoot
|
||||
annotateTableFoot (TableFoot attr rows) =
|
||||
AnnTableFoot attr <$> annotateHeaderSection rows
|
||||
|
||||
annotateHeaderSection :: [Row] -> AnnM [AnnHeaderRow]
|
||||
annotateHeaderSection rows = do
|
||||
colspec <- asks fst
|
||||
let hangcolspec = (1, ) <$> colspec
|
||||
annotateHeaderSection' hangcolspec id $ clipRows rows
|
||||
where
|
||||
annotateHeaderSection' oldHang acc (Row attr cells : rs) = do
|
||||
let (_, newHang, cells', _) =
|
||||
annotateRowSection 0 oldHang $ cells <> repeat emptyCell
|
||||
n <- incRowNumber
|
||||
let annRow = AnnHeaderRow attr n cells'
|
||||
annotateHeaderSection' newHang (acc . (annRow :)) rs
|
||||
annotateHeaderSection' _ acc [] = return $ acc []
|
||||
|
||||
annotateBodySection :: RowHeadColumns -> [Row] -> AnnM [AnnBodyRow]
|
||||
annotateBodySection (RowHeadColumns rhc) rows = do
|
||||
colspec <- asks fst
|
||||
let colspec' = (1, ) <$> colspec
|
||||
let (stubspec, bodyspec) = splitAt rhc colspec'
|
||||
normalizeBodySection' stubspec bodyspec id $ clipRows rows
|
||||
where
|
||||
normalizeBodySection' headHang bodyHang acc (Row attr cells : rs) = do
|
||||
let (colnum, headHang', rowStub, cells') =
|
||||
annotateRowSection 0 headHang $ cells <> repeat emptyCell
|
||||
let (_, bodyHang', rowBody, _) = annotateRowSection colnum bodyHang cells'
|
||||
n <- incRowNumber
|
||||
let annRow = AnnBodyRow attr n rowStub rowBody
|
||||
normalizeBodySection' headHang' bodyHang' (acc . (annRow :)) rs
|
||||
normalizeBodySection' _ _ acc [] = return $ acc []
|
||||
|
||||
-- | Lay out a section of a 'Table' row on a grid row, annotating the
|
||||
-- cells with the 'ColSpec' data for the columns that they
|
||||
-- span. Performs the same normalization as 'placeRowSection'.
|
||||
annotateRowSection
|
||||
:: ColNumber -- ^ The current column number
|
||||
-> [(RowSpan, ColSpec)] -- ^ The overhang of the previous grid row,
|
||||
-- with column data
|
||||
-> [Cell] -- ^ The cells to annotate
|
||||
-> (ColNumber, [(RowSpan, ColSpec)], [AnnCell], [Cell]) -- ^ The new
|
||||
-- column
|
||||
-- number,
|
||||
-- overhang,
|
||||
-- annotated
|
||||
-- cells,
|
||||
-- and
|
||||
-- remaining
|
||||
-- cells
|
||||
annotateRowSection !colnum oldHang cells
|
||||
-- If the grid has overhang at our position, try to re-lay in
|
||||
-- the next position.
|
||||
| (o, colspec) : os <- oldHang
|
||||
, o > 1
|
||||
= let (colnum', newHang, newCell, cells') =
|
||||
annotateRowSection (colnum + 1) os cells
|
||||
in (colnum', (o - 1, colspec) : newHang, newCell, cells')
|
||||
-- Otherwise if there is any available width, place the cell and
|
||||
-- continue.
|
||||
| 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 = AnnCell (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 there is no room in the section
|
||||
| otherwise
|
||||
= (colnum, [], [], cells)
|
||||
where
|
||||
getColSpan (ColSpan x) = x
|
||||
getDim (Cell _ _ h w _) = (h, w)
|
||||
setW w (Cell a b h _ c) = Cell a b h w c
|
||||
|
||||
-- | In @'splitCellHang' rs cs coldata@, with @rs@ the height of a
|
||||
-- cell that lies at the beginning of @coldata@, and @cs@ its width
|
||||
-- (which is not assumed to fit in the available space), return the
|
||||
-- actual width of the cell (what will fit in the available space),
|
||||
-- the data for the columns that the cell spans (including updating
|
||||
-- the overhang to equal @rs@), and the remaining column data.
|
||||
splitCellHang
|
||||
:: RowSpan
|
||||
-> ColSpan
|
||||
-> [(RowSpan, ColSpec)]
|
||||
-> (ColSpan, [(RowSpan, ColSpec)], [(RowSpan, 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)
|
||||
|
||||
-- | Convert an 'AnnTable' to a 'Table'. This is the inverse of
|
||||
-- 'toAnnTable' on well-formed tables (i.e. tables satisfying the
|
||||
-- guarantees of 'table').
|
||||
fromAnnTable
|
||||
:: AnnTable -> (Attr, Caption, [ColSpec], TableHead, [TableBody], TableFoot)
|
||||
fromAnnTable (AnnTable attr cap cs th tbs tf) = (attr, cap, cs, th', tbs', tf')
|
||||
where
|
||||
th' = fromAnnTableHead th
|
||||
tbs' = map fromAnnTableBody tbs
|
||||
tf' = fromAnnTableFoot tf
|
||||
|
||||
fromAnnTableHead :: AnnTableHead -> TableHead
|
||||
fromAnnTableHead (AnnTableHead attr rows) =
|
||||
TableHead attr $ fromAnnHeaderRow <$> rows
|
||||
|
||||
fromAnnTableBody :: AnnTableBody -> TableBody
|
||||
fromAnnTableBody (AnnTableBody attr rhc th tb) =
|
||||
TableBody attr rhc (fromAnnHeaderRow <$> th) (fromAnnBodyRow <$> tb)
|
||||
|
||||
fromAnnTableFoot :: AnnTableFoot -> TableFoot
|
||||
fromAnnTableFoot (AnnTableFoot attr rows) =
|
||||
TableFoot attr $ fromAnnHeaderRow <$> rows
|
||||
|
||||
fromAnnHeaderRow :: AnnHeaderRow -> Row
|
||||
fromAnnHeaderRow (AnnHeaderRow attr _ cells) = Row attr $ fromAnnCell <$> cells
|
||||
|
||||
fromAnnBodyRow :: AnnBodyRow -> Row
|
||||
fromAnnBodyRow (AnnBodyRow attr _ rh rb) =
|
||||
Row attr ((fromAnnCell <$> rh) <> (fromAnnCell <$> rb))
|
||||
|
||||
fromAnnCell :: AnnCell -> Cell
|
||||
fromAnnCell (AnnCell _ _ c) = c
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{- |
|
||||
Module : Tests.Writers.Tables
|
||||
Module : Tests.Writers.AnnotatedTable
|
||||
Copyright : 2020 Christian Despres
|
||||
License : GNU GPL, version 2 or above
|
||||
|
||||
|
|
@ -11,7 +11,7 @@
|
|||
|
||||
Tests for the table helper functions.
|
||||
-}
|
||||
module Tests.Writers.Tables
|
||||
module Tests.Writers.AnnotatedTable
|
||||
( tests
|
||||
)
|
||||
where
|
||||
|
|
@ -37,19 +37,20 @@ import Test.Tasty.QuickCheck ( QuickCheckTests(..)
|
|||
)
|
||||
import Text.Pandoc.Arbitrary ( )
|
||||
import Text.Pandoc.Builder
|
||||
import Text.Pandoc.Writers.Tables
|
||||
import qualified Text.Pandoc.Writers.AnnotatedTable
|
||||
as Ann
|
||||
|
||||
tests :: [TestTree]
|
||||
tests = [testGroup "toAnnTable" $ testAnnTable <> annTableProps]
|
||||
tests = [testGroup "toTable" $ testAnnTable <> annTableProps]
|
||||
|
||||
getSpec :: AnnCell -> [ColSpec]
|
||||
getSpec (AnnCell colspec _ _) = F.toList colspec
|
||||
getSpec :: Ann.Cell -> [ColSpec]
|
||||
getSpec (Ann.Cell colspec _ _) = F.toList colspec
|
||||
|
||||
catHeaderSpec :: AnnHeaderRow -> [ColSpec]
|
||||
catHeaderSpec (AnnHeaderRow _ _ x) = concatMap getSpec x
|
||||
catHeaderSpec :: Ann.HeaderRow -> [ColSpec]
|
||||
catHeaderSpec (Ann.HeaderRow _ _ x) = concatMap getSpec x
|
||||
|
||||
catBodySpec :: AnnBodyRow -> [ColSpec]
|
||||
catBodySpec (AnnBodyRow _ _ x y) = concatMap getSpec x <> concatMap getSpec y
|
||||
catBodySpec :: Ann.BodyRow -> [ColSpec]
|
||||
catBodySpec (Ann.BodyRow _ _ x y) = concatMap getSpec x <> concatMap getSpec y
|
||||
|
||||
-- Test if the first list can be obtained from the second by deleting
|
||||
-- elements from it.
|
||||
|
|
@ -78,21 +79,21 @@ testAnnTable =
|
|||
[[], [cl "e" 5 1, cl "f" (-7) 0]]
|
||||
[[cl "g" 4 3, cl "h" 4 3], [], [emptyCell]]
|
||||
initialTB2 = tb 2 [] [[cl "i" 4 3, cl "j" 4 3]]
|
||||
generated = toAnnTable nullAttr
|
||||
emptyCaption
|
||||
spec
|
||||
(th initialHeads)
|
||||
[initialTB1, initialTB2]
|
||||
(tf initialHeads)
|
||||
generated = Ann.toTable nullAttr
|
||||
emptyCaption
|
||||
spec
|
||||
(th initialHeads)
|
||||
[initialTB1, initialTB2]
|
||||
(tf initialHeads)
|
||||
|
||||
acl al n a h w =
|
||||
AnnCell (NonEmpty.fromList al) n $ Cell (a, [], []) AlignDefault h w []
|
||||
Ann.Cell (NonEmpty.fromList al) n $ Cell (a, [], []) AlignDefault h w []
|
||||
emptyAnnCell al n = acl al n "" 1 1
|
||||
ahrw = AnnHeaderRow nullAttr
|
||||
abrw = AnnBodyRow nullAttr
|
||||
ath = AnnTableHead nullAttr
|
||||
atb = AnnTableBody nullAttr
|
||||
atf = AnnTableFoot nullAttr
|
||||
ahrw = Ann.HeaderRow nullAttr
|
||||
abrw = Ann.BodyRow nullAttr
|
||||
ath = Ann.TableHead nullAttr
|
||||
atb = Ann.TableBody nullAttr
|
||||
atf = Ann.TableFoot nullAttr
|
||||
|
||||
finalTH = ath
|
||||
[ ahrw 0 [acl [spec1] 0 "a" 1 1, acl [spec2, spec3] 1 "b" 2 2]
|
||||
|
|
@ -118,7 +119,7 @@ testAnnTable =
|
|||
, ahrw 9 [acl [spec1] 0 "c" 1 1]
|
||||
]
|
||||
expected =
|
||||
AnnTable nullAttr emptyCaption spec finalTH [finalTB1, finalTB2] finalTF
|
||||
Ann.Table nullAttr emptyCaption spec finalTH [finalTB1, finalTB2] finalTF
|
||||
|
||||
withColSpec :: Testable prop => ([ColSpec] -> prop) -> Property
|
||||
withColSpec = forAll arbColSpec
|
||||
|
|
@ -134,49 +135,48 @@ withColSpec = forAll arbColSpec
|
|||
annTableProps :: [TestTree]
|
||||
annTableProps =
|
||||
localOption (QuickCheckTests 50)
|
||||
<$> [ testProperty "normalizes like the table builder" propBuilderAnnTable
|
||||
, testProperty "has valid final cell columns" propColNumber
|
||||
, testProperty "has valid first row column data" propFirstRowCols
|
||||
, testProperty "has valid all row column data" propColSubsets
|
||||
, testProperty "has valid cell column data lengths"
|
||||
propCellColLengths
|
||||
<$> [ testProperty "normalizes like the table builder" propBuilderAnnTable
|
||||
, testProperty "has valid final cell columns" propColNumber
|
||||
, testProperty "has valid first row column data" propFirstRowCols
|
||||
, testProperty "has valid all row column data" propColSubsets
|
||||
, testProperty "has valid cell column data lengths" propCellColLengths
|
||||
]
|
||||
|
||||
-- The property that toAnnTable will normalize a table identically to
|
||||
-- the table builder. This should mean that toAnnTable is at least as
|
||||
-- The property that Ann.toTable will normalize a table identically to
|
||||
-- the table builder. This should mean that Ann.toTable is at least as
|
||||
-- rigorous as Builder.table in that respect without repeating those
|
||||
-- tests here (see the pandoc-types Table tests for examples).
|
||||
propBuilderAnnTable :: TableHead -> [TableBody] -> TableFoot -> Property
|
||||
propBuilderAnnTable th tbs tf = withColSpec $ \cs ->
|
||||
convertTable (table emptyCaption cs th tbs tf)
|
||||
=== convertAnnTable (toAnnTable nullAttr emptyCaption cs th tbs tf)
|
||||
=== convertAnnTable (Ann.toTable nullAttr emptyCaption cs th tbs tf)
|
||||
where
|
||||
convertTable blks = case toList blks of
|
||||
[Table _ _ colspec a b c] -> Right (colspec, a, b, c)
|
||||
x -> Left x
|
||||
convertAnnTable x = case fromAnnTable x of
|
||||
convertAnnTable x = case Ann.fromTable x of
|
||||
(_, _, colspec, a, b, c) -> Right (colspec, a, b, c)
|
||||
|
||||
-- The property of toAnnTable that if the last cell in the first row
|
||||
-- The property of Ann.toTable that if the last cell in the first row
|
||||
-- of a table section has ColSpan w and ColNumber n, then w + n is the
|
||||
-- width of the table.
|
||||
propColNumber :: TableHead -> [TableBody] -> TableFoot -> Property
|
||||
propColNumber th tbs tf = withColSpec $ \cs ->
|
||||
let twidth = length cs
|
||||
AnnTable _ _ _ ath atbs atf =
|
||||
toAnnTable nullAttr emptyCaption cs th tbs tf
|
||||
Ann.Table _ _ _ ath atbs atf =
|
||||
Ann.toTable nullAttr emptyCaption cs th tbs tf
|
||||
in conjoin
|
||||
$ [colNumTH twidth ath]
|
||||
<> (colNumTB twidth <$> atbs)
|
||||
<> [colNumTF twidth atf]
|
||||
where
|
||||
colNumTH n (AnnTableHead _ rs) = firstly (isHeaderValid n) rs
|
||||
colNumTB n (AnnTableBody _ _ rs ts) =
|
||||
colNumTH n (Ann.TableHead _ rs) = firstly (isHeaderValid n) rs
|
||||
colNumTB n (Ann.TableBody _ _ rs ts) =
|
||||
firstly (isHeaderValid n) rs && firstly (isBodyValid n) ts
|
||||
colNumTF n (AnnTableFoot _ rs) = firstly (isHeaderValid n) rs
|
||||
colNumTF n (Ann.TableFoot _ rs) = firstly (isHeaderValid n) rs
|
||||
|
||||
isHeaderValid n (AnnHeaderRow _ _ x) = isSegmentValid n x
|
||||
isBodyValid n (AnnBodyRow _ _ _ x) = isSegmentValid n x
|
||||
isHeaderValid n (Ann.HeaderRow _ _ x) = isSegmentValid n x
|
||||
isBodyValid n (Ann.BodyRow _ _ _ x) = isSegmentValid n x
|
||||
|
||||
firstly f (x : _) = f x
|
||||
firstly _ [] = True
|
||||
|
|
@ -184,17 +184,19 @@ propColNumber th tbs tf = withColSpec $ \cs ->
|
|||
lastly f (_ : xs) = lastly f xs
|
||||
lastly _ [] = True
|
||||
|
||||
isSegmentValid twidth cs = flip lastly cs
|
||||
$ \(AnnCell _ (ColNumber n) (Cell _ _ _ (ColSpan w) _)) -> n + w == twidth
|
||||
isSegmentValid twidth cs =
|
||||
flip lastly cs
|
||||
$ \(Ann.Cell _ (Ann.ColNumber n) (Cell _ _ _ (ColSpan w) _)) ->
|
||||
n + w == twidth
|
||||
|
||||
-- The property of an AnnTable from toAnnTable that if the NonEmpty
|
||||
-- The property of an Ann.Table from Ann.toTable that if the NonEmpty
|
||||
-- ColSpec data of the cells in the first row of a table section are
|
||||
-- concatenated, the result should equal the [ColSpec] of the entire
|
||||
-- table.
|
||||
propFirstRowCols :: TableHead -> [TableBody] -> TableFoot -> Property
|
||||
propFirstRowCols th tbs tf = withColSpec $ \cs ->
|
||||
let AnnTable _ _ _ ath atbs atf =
|
||||
toAnnTable nullAttr emptyCaption cs th tbs tf
|
||||
let Ann.Table _ _ _ ath atbs atf =
|
||||
Ann.toTable nullAttr emptyCaption cs th tbs tf
|
||||
in conjoin
|
||||
$ [firstRowTH cs ath]
|
||||
<> (firstRowTB cs <$> atbs)
|
||||
|
|
@ -206,47 +208,47 @@ propFirstRowCols th tbs tf = withColSpec $ \cs ->
|
|||
firstHeaderValid cs = firstly $ \r -> cs == catHeaderSpec r
|
||||
firstBodyValid cs = firstly $ \r -> cs == catBodySpec r
|
||||
|
||||
firstRowTH cs (AnnTableHead _ rs) = firstHeaderValid cs rs
|
||||
firstRowTB cs (AnnTableBody _ _ rs ts) =
|
||||
firstRowTH cs (Ann.TableHead _ rs) = firstHeaderValid cs rs
|
||||
firstRowTB cs (Ann.TableBody _ _ rs ts) =
|
||||
firstHeaderValid cs rs && firstBodyValid cs ts
|
||||
firstRowTF cs (AnnTableFoot _ rs) = firstHeaderValid cs rs
|
||||
firstRowTF cs (Ann.TableFoot _ rs) = firstHeaderValid cs rs
|
||||
|
||||
-- The property that in any row in an AnnTable from toAnnTable, the
|
||||
-- The property that in any row in an Ann.Table from Ann.toTable, the
|
||||
-- NonEmpty ColSpec annotations on cells, when concatenated, form a
|
||||
-- subset (really sublist) of the [ColSpec] of the entire table.
|
||||
propColSubsets :: TableHead -> [TableBody] -> TableFoot -> Property
|
||||
propColSubsets th tbs tf = withColSpec $ \cs ->
|
||||
let AnnTable _ _ _ ath atbs atf =
|
||||
toAnnTable nullAttr emptyCaption cs th tbs tf
|
||||
let Ann.Table _ _ _ ath atbs atf =
|
||||
Ann.toTable nullAttr emptyCaption cs th tbs tf
|
||||
in conjoin
|
||||
$ subsetTH cs ath
|
||||
<> concatMap (subsetTB cs) atbs
|
||||
<> subsetTF cs atf
|
||||
where
|
||||
subsetTH cs (AnnTableHead _ rs) = map (subsetHeader cs) rs
|
||||
subsetTB cs (AnnTableBody _ _ rs ts) =
|
||||
subsetTH cs (Ann.TableHead _ rs) = map (subsetHeader cs) rs
|
||||
subsetTB cs (Ann.TableBody _ _ rs ts) =
|
||||
map (subsetHeader cs) rs <> map (subsetBody cs) ts
|
||||
subsetTF cs (AnnTableFoot _ rs) = map (subsetHeader cs) rs
|
||||
subsetTF cs (Ann.TableFoot _ rs) = map (subsetHeader cs) rs
|
||||
|
||||
subsetHeader cs r = catHeaderSpec r `isSubsetOf` cs
|
||||
subsetBody cs r = catBodySpec r `isSubsetOf` cs
|
||||
|
||||
-- The property that in any cell in an AnnTable from toAnnTable, the
|
||||
-- The property that in any cell in an Ann.Table from Ann.toTable, the
|
||||
-- NonEmpty ColSpec annotation on a cell is equal in length to its
|
||||
-- ColSpan.
|
||||
propCellColLengths :: TableHead -> [TableBody] -> TableFoot -> Property
|
||||
propCellColLengths th tbs tf = withColSpec $ \cs ->
|
||||
let AnnTable _ _ _ ath atbs atf =
|
||||
toAnnTable nullAttr emptyCaption cs th tbs tf
|
||||
let Ann.Table _ _ _ ath atbs atf =
|
||||
Ann.toTable nullAttr emptyCaption cs th tbs tf
|
||||
in conjoin $ cellColTH ath <> concatMap cellColTB atbs <> cellColTF atf
|
||||
where
|
||||
cellColTH (AnnTableHead _ rs) = concatMap cellColHeader rs
|
||||
cellColTB (AnnTableBody _ _ rs ts) =
|
||||
cellColTH (Ann.TableHead _ rs) = concatMap cellColHeader rs
|
||||
cellColTB (Ann.TableBody _ _ rs ts) =
|
||||
concatMap cellColHeader rs <> concatMap cellColBody ts
|
||||
cellColTF (AnnTableFoot _ rs) = concatMap cellColHeader rs
|
||||
cellColTF (Ann.TableFoot _ rs) = concatMap cellColHeader rs
|
||||
|
||||
cellColHeader (AnnHeaderRow _ _ x) = fmap validLength x
|
||||
cellColBody (AnnBodyRow _ _ x y) = fmap validLength x <> fmap validLength y
|
||||
cellColHeader (Ann.HeaderRow _ _ x) = fmap validLength x
|
||||
cellColBody (Ann.BodyRow _ _ x y) = fmap validLength x <> fmap validLength y
|
||||
|
||||
validLength (AnnCell colspec _ (Cell _ _ _ (ColSpan w) _)) =
|
||||
validLength (Ann.Cell colspec _ (Cell _ _ _ (ColSpan w) _)) =
|
||||
length colspec == w
|
||||
|
|
@ -44,7 +44,7 @@ import qualified Tests.Writers.Org
|
|||
import qualified Tests.Writers.Plain
|
||||
import qualified Tests.Writers.Powerpoint
|
||||
import qualified Tests.Writers.RST
|
||||
import qualified Tests.Writers.Tables
|
||||
import qualified Tests.Writers.AnnotatedTable
|
||||
import qualified Tests.Writers.TEI
|
||||
import Tests.Helpers (findPandoc)
|
||||
import Text.Pandoc.Shared (inDirectory)
|
||||
|
|
@ -73,7 +73,7 @@ tests pandocPath = testGroup "pandoc tests"
|
|||
, testGroup "FB2" Tests.Writers.FB2.tests
|
||||
, testGroup "PowerPoint" Tests.Writers.Powerpoint.tests
|
||||
, testGroup "Ms" Tests.Writers.Ms.tests
|
||||
, testGroup "Tables" Tests.Writers.Tables.tests
|
||||
, testGroup "AnnotatedTable" Tests.Writers.AnnotatedTable.tests
|
||||
]
|
||||
, testGroup "Readers"
|
||||
[ testGroup "LaTeX" Tests.Readers.LaTeX.tests
|
||||
|
|
|
|||
Loading…
Reference in a new issue