diff options
| -rw-r--r-- | pandoc.cabal | 4 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/AnnotatedTable.hs | 300 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/HTML.hs | 40 | ||||
| -rw-r--r-- | src/Text/Pandoc/Writers/Tables.hs | 291 | ||||
| -rw-r--r-- | test/Tests/Writers/AnnotatedTable.hs (renamed from test/Tests/Writers/Tables.hs) | 130 | ||||
| -rw-r--r-- | test/test-pandoc.hs | 4 |
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 |