diff options
| -rw-r--r-- | cabal.project | 5 | ||||
| -rw-r--r-- | pandoc.cabal | 2 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/Tables.hs | 291 | ||||
| -rw-r--r-- | stack.yaml | 3 | ||||
| -rw-r--r-- | test/Tests/Writers/Tables.hs | 252 | ||||
| -rw-r--r-- | test/test-pandoc.hs | 2 |
6 files changed, 554 insertions, 1 deletions
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 |