aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorChristian Despres <50160106+despresc@users.noreply.github.com>2020-09-12 11:50:36 -0400
committerGitHub <noreply@github.com>2020-09-12 08:50:36 -0700
commit22babd5382c21d32e9d73984c5d5ff3d83ba715b (patch)
tree6178f81b414e90158e68b864b227b1eb07a05bb7
parent6fda8cfa28fa07f94854ca47d27e0415a4499033 (diff)
downloadpandoc-22babd5382c21d32e9d73984c5d5ff3d83ba715b.tar.gz
[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.
-rw-r--r--pandoc.cabal4
-rw-r--r--src/Text/Pandoc/Writers/AnnotatedTable.hs300
-rw-r--r--src/Text/Pandoc/Writers/HTML.hs40
-rw-r--r--src/Text/Pandoc/Writers/Tables.hs291
-rw-r--r--test/Tests/Writers/AnnotatedTable.hs (renamed from test/Tests/Writers/Tables.hs)130
-rw-r--r--test/test-pandoc.hs4
6 files changed, 390 insertions, 379 deletions
diff --git a/pandoc.cabal b/pandoc.cabal
index 219e2a31a..e46149b5a 100644
--- a/pandoc.cabal
+++ b/pandoc.cabal
@@ -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
diff --git a/src/Text/Pandoc/Writers/AnnotatedTable.hs b/src/Text/Pandoc/Writers/AnnotatedTable.hs
new file mode 100644
index 000000000..48c9d61f2
--- /dev/null
+++ b/src/Text/Pandoc/Writers/AnnotatedTable.hs
@@ -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
diff --git a/src/Text/Pandoc/Writers/HTML.hs b/src/Text/Pandoc/Writers/HTML.hs
index eaf13b7da..4fd671da8 100644
--- a/src/Text/Pandoc/Writers/HTML.hs
+++ b/src/Text/Pandoc/Writers/HTML.hs
@@ -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
diff --git a/src/Text/Pandoc/Writers/Tables.hs b/src/Text/Pandoc/Writers/Tables.hs
deleted file mode 100644
index 757ac41c6..000000000
--- a/src/Text/Pandoc/Writers/Tables.hs
+++ /dev/null
@@ -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
diff --git a/test/Tests/Writers/Tables.hs b/test/Tests/Writers/AnnotatedTable.hs
index 6dab8f972..7e16cf8e0 100644
--- a/test/Tests/Writers/Tables.hs
+++ b/test/Tests/Writers/AnnotatedTable.hs
@@ -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
diff --git a/test/test-pandoc.hs b/test/test-pandoc.hs
index 50c7d5b09..bb4db90b9 100644
--- a/test/test-pandoc.hs
+++ b/test/test-pandoc.hs
@@ -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