diff --git a/cabal.project b/cabal.project
index 7ce2b2d68..52c85d222 100644
--- a/cabal.project
+++ b/cabal.project
@@ -12,3 +12,8 @@ source-repository-package
type: git
location: https://github.com/jgm/pandoc-citeproc
tag: 0.17.0.2
+
+source-repository-package
+ type: git
+ location: https://github.com/jgm/pandoc-types
+ tag: 8e9ca37802120f32ececac752d73463e2fc86811
diff --git a/pandoc.cabal b/pandoc.cabal
index 76e93d2e6..4c27c037d 100644
--- a/pandoc.cabal
+++ b/pandoc.cabal
@@ -553,6 +553,7 @@ library
Text.Pandoc.Writers.Math,
Text.Pandoc.Writers.Shared,
Text.Pandoc.Writers.OOXML,
+ Text.Pandoc.Writers.Tables,
Text.Pandoc.Lua,
Text.Pandoc.PDF,
Text.Pandoc.UTF8,
@@ -820,6 +821,7 @@ test-suite test-pandoc
Tests.Writers.Powerpoint
Tests.Writers.OOXML
Tests.Writers.Ms
+ Tests.Writers.Tables
if os(windows)
cpp-options: -D_WINDOWS
default-language: Haskell2010
diff --git a/src/Text/Pandoc/Writers/Tables.hs b/src/Text/Pandoc/Writers/Tables.hs
new file mode 100644
index 000000000..757ac41c6
--- /dev/null
+++ b/src/Text/Pandoc/Writers/Tables.hs
@@ -0,0 +1,291 @@
+{-# 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/stack.yaml b/stack.yaml
index 8e34f3399..15c0e7566 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -12,7 +12,8 @@ flags:
packages:
- '.'
extra-deps:
-- pandoc-types-1.21
+- git: https://github.com/jgm/pandoc-types
+ commit: 8e9ca37802120f32ececac752d73463e2fc86811
- pandoc-citeproc-0.17.0.2
- rfc5051-0.2
- texmath-0.12.0.2
diff --git a/test/Tests/Writers/Tables.hs b/test/Tests/Writers/Tables.hs
new file mode 100644
index 000000000..6dab8f972
--- /dev/null
+++ b/test/Tests/Writers/Tables.hs
@@ -0,0 +1,252 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{- |
+ Module : Tests.Writers.Tables
+ Copyright : 2020 Christian Despres
+ License : GNU GPL, version 2 or above
+
+ Maintainer : Christian Despres <christian.j.j.despres@gmail.com>
+ Stability : alpha
+ Portability : portable
+
+Tests for the table helper functions.
+-}
+module Tests.Writers.Tables
+ ( tests
+ )
+where
+
+import Prelude
+import qualified Data.Foldable as F
+import qualified Data.List.NonEmpty as NonEmpty
+import Test.Tasty
+import Test.Tasty.HUnit ( testCase
+ , (@?=)
+ )
+import Test.Tasty.QuickCheck ( QuickCheckTests(..)
+ , Property
+ , Testable
+ , conjoin
+ , forAll
+ , testProperty
+ , (===)
+ , vectorOf
+ , choose
+ , arbitrary
+ , elements
+ )
+import Text.Pandoc.Arbitrary ( )
+import Text.Pandoc.Builder
+import Text.Pandoc.Writers.Tables
+
+tests :: [TestTree]
+tests = [testGroup "toAnnTable" $ testAnnTable <> annTableProps]
+
+getSpec :: AnnCell -> [ColSpec]
+getSpec (AnnCell colspec _ _) = F.toList colspec
+
+catHeaderSpec :: AnnHeaderRow -> [ColSpec]
+catHeaderSpec (AnnHeaderRow _ _ x) = concatMap getSpec x
+
+catBodySpec :: AnnBodyRow -> [ColSpec]
+catBodySpec (AnnBodyRow _ _ x y) = concatMap getSpec x <> concatMap getSpec y
+
+-- Test if the first list can be obtained from the second by deleting
+-- elements from it.
+isSubsetOf :: Eq a => [a] -> [a] -> Bool
+isSubsetOf (x : xs) (y : ys) | x == y = isSubsetOf xs ys
+ | otherwise = isSubsetOf (x : xs) ys
+isSubsetOf [] _ = True
+isSubsetOf _ [] = False
+
+testAnnTable :: [TestTree]
+testAnnTable =
+ [testCase "annotates a sample table properly" $ generated @?= expected]
+ where
+ spec1 = (AlignRight, ColWidthDefault)
+ spec2 = (AlignLeft, ColWidthDefault)
+ spec3 = (AlignCenter, ColWidthDefault)
+ spec = [spec1, spec2, spec3]
+
+ cl a h w = Cell (a, [], []) AlignDefault h w []
+ rws = map $ Row nullAttr
+ th = TableHead nullAttr . rws
+ tb n x y = TableBody nullAttr n (rws x) (rws y)
+ tf = TableFoot nullAttr . rws
+ initialHeads = [[cl "a" 1 1, cl "b" 3 2], [cl "c" 2 2, cl "d" 1 1]]
+ initialTB1 = tb 1
+ [[], [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)
+
+ acl al n a h w =
+ AnnCell (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
+
+ finalTH = ath
+ [ ahrw 0 [acl [spec1] 0 "a" 1 1, acl [spec2, spec3] 1 "b" 2 2]
+ , ahrw 1 [acl [spec1] 0 "c" 1 1]
+ ]
+ finalTB1 = atb
+ 1
+ [ ahrw
+ 2
+ [emptyAnnCell [spec1] 0, emptyAnnCell [spec2] 1, emptyAnnCell [spec3] 2]
+ , ahrw
+ 3
+ [acl [spec1] 0 "e" 1 1, acl [spec2] 1 "f" 1 1, emptyAnnCell [spec3] 2]
+ ]
+ [ abrw 4 [acl [spec1] 0 "g" 3 1] [acl [spec2, spec3] 1 "h" 3 2]
+ , abrw 5 [] []
+ , abrw 6 [] []
+ ]
+ finalTB2 =
+ atb 2 [] [abrw 7 [acl [spec1, spec2] 0 "i" 1 2] [acl [spec3] 2 "j" 1 1]]
+ finalTF = atf
+ [ ahrw 8 [acl [spec1] 0 "a" 1 1, acl [spec2, spec3] 1 "b" 2 2]
+ , ahrw 9 [acl [spec1] 0 "c" 1 1]
+ ]
+ expected =
+ AnnTable nullAttr emptyCaption spec finalTH [finalTB1, finalTB2] finalTF
+
+withColSpec :: Testable prop => ([ColSpec] -> prop) -> Property
+withColSpec = forAll arbColSpec
+ where
+ arbColSpec = do
+ cs <- choose (1 :: Int, 6)
+ vectorOf
+ cs
+ ((,) <$> arbitrary <*> elements
+ [ColWidthDefault, ColWidth (1 / 3), ColWidth 0.25]
+ )
+
+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
+ ]
+
+-- The property that toAnnTable will normalize a table identically to
+-- the table builder. This should mean that toAnnTable 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)
+ 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
+ (_, _, colspec, a, b, c) -> Right (colspec, a, b, c)
+
+-- The property of toAnnTable 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
+ 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) =
+ firstly (isHeaderValid n) rs && firstly (isBodyValid n) ts
+ colNumTF n (AnnTableFoot _ rs) = firstly (isHeaderValid n) rs
+
+ isHeaderValid n (AnnHeaderRow _ _ x) = isSegmentValid n x
+ isBodyValid n (AnnBodyRow _ _ _ x) = isSegmentValid n x
+
+ firstly f (x : _) = f x
+ firstly _ [] = True
+ lastly f [x ] = f x
+ lastly f (_ : xs) = lastly f xs
+ lastly _ [] = True
+
+ isSegmentValid twidth cs = flip lastly cs
+ $ \(AnnCell _ (ColNumber n) (Cell _ _ _ (ColSpan w) _)) -> n + w == twidth
+
+-- The property of an AnnTable from toAnnTable 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
+ in conjoin
+ $ [firstRowTH cs ath]
+ <> (firstRowTB cs <$> atbs)
+ <> [firstRowTF cs atf]
+ where
+ firstly f (x : _) = f x
+ firstly _ [] = True
+
+ 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) =
+ firstHeaderValid cs rs && firstBodyValid cs ts
+ firstRowTF cs (AnnTableFoot _ rs) = firstHeaderValid cs rs
+
+-- The property that in any row in an AnnTable from toAnnTable, 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
+ 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) =
+ map (subsetHeader cs) rs <> map (subsetBody cs) ts
+ subsetTF cs (AnnTableFoot _ 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
+-- 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
+ in conjoin $ cellColTH ath <> concatMap cellColTB atbs <> cellColTF atf
+ where
+ cellColTH (AnnTableHead _ rs) = concatMap cellColHeader rs
+ cellColTB (AnnTableBody _ _ rs ts) =
+ concatMap cellColHeader rs <> concatMap cellColBody ts
+ cellColTF (AnnTableFoot _ rs) = concatMap cellColHeader rs
+
+ cellColHeader (AnnHeaderRow _ _ x) = fmap validLength x
+ cellColBody (AnnBodyRow _ _ x y) = fmap validLength x <> fmap validLength y
+
+ validLength (AnnCell colspec _ (Cell _ _ _ (ColSpan w) _)) =
+ length colspec == w
diff --git a/test/test-pandoc.hs b/test/test-pandoc.hs
index d0a1a6f18..50c7d5b09 100644
--- a/test/test-pandoc.hs
+++ b/test/test-pandoc.hs
@@ -44,6 +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.TEI
import Tests.Helpers (findPandoc)
import Text.Pandoc.Shared (inDirectory)
@@ -72,6 +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 "Readers"
[ testGroup "LaTeX" Tests.Readers.LaTeX.tests