@@ -1,291 +0,0 @@
1−{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE DeriveDataTypeable #-}
3−{-# LANGUAGE DeriveGeneric #-}
4−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5−{-# LANGUAGE TupleSections #-}
6−
7−{- |
8− Module : Text.Pandoc.Writers.Tables
9− Copyright : Copyright 2020 Christian Despres
10− License : GNU GPL, version 2 or above
11−
12− Maintainer : Christian Despres <christian.j.j.despres@gmail.com>
13− Stability : alpha
14− Portability : portable
15−
16−Definitions and helper functions for an intermediate 'AnnTable' type,
17−which annotates the existing 'Table' types with additional inferred
18−information. For use in writers that need to know the details of
19−columns that cells span, row numbers, and the cells that are in the
20−row head.
21−-}
22−
23−module Text.Pandoc.Writers.Tables
24− ( toAnnTable
25− , fromAnnTable
26− , AnnTable(..)
27− , AnnTableHead(..)
28− , AnnTableBody(..)
29− , AnnTableFoot(..)
30− , AnnHeaderRow(..)
31− , AnnBodyRow(..)
32− , RowNumber(..)
33− , AnnRowHead
34− , AnnRowBody
35− , AnnCell(..)
36− , ColNumber(..)
37− )
38−where
39−
40−import Control.Monad.RWS.Strict
41− hiding ( (<>) )
42−import Data.Generics ( Data
43− , Typeable
44− )
45−import Data.List.NonEmpty ( NonEmpty(..) )
46−import GHC.Generics ( Generic )
47−import Text.Pandoc.Builder
48−
49−-- | An annotated table type, corresponding to the 'Table' constructor
50−-- and the HTML @\<table\>@ element. It records the data of the
51−-- columns that cells span, the cells in the row head, the row numbers
52−-- of rows, and the column numbers of cells, in addition to the data
53−-- in a 'Table'. The type itself does not enforce any guarantees about
54−-- the consistency of this data. Use 'toAnnTable' to produce an
55−-- 'AnnTable' from a pandoc 'Table'.
56−data AnnTable = AnnTable Attr Caption [ColSpec] AnnTableHead [AnnTableBody] AnnTableFoot
57− deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
58−
59−-- | An annotated table head, corresponding to 'TableHead' and the
60−-- HTML @\<thead\>@ element.
61−data AnnTableHead = AnnTableHead Attr [AnnHeaderRow]
62− deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
63−
64−-- | An annotated table body, with an intermediate head and body,
65−-- corresponding to 'TableBody' and the HTML @\<tbody\>@ element.
66−data AnnTableBody = AnnTableBody Attr RowHeadColumns [AnnHeaderRow] [AnnBodyRow]
67− deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
68−
69−-- | An annotated table foot, corresponding to 'TableFoot' and the
70−-- HTML @\<tfoot\>@ element.
71−data AnnTableFoot = AnnTableFoot Attr [AnnHeaderRow]
72− deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
73−
74−-- | An annotated header row, corresponding to 'Row' and the HTML
75−-- @\<tr\>@ element, and also recording the row number of the row. All
76−-- the cells in an 'AnnHeaderRow' are header (@\<th\>@) cells.
77−data AnnHeaderRow = AnnHeaderRow Attr RowNumber [AnnCell]
78− deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
79−
80−-- | An annotated body row, corresponding to 'Row' and the HTML
81−-- @\<tr\>@ element, and also recording its row number and separating
82−-- the row head cells from the row body cells.
83−data AnnBodyRow = AnnBodyRow Attr RowNumber AnnRowHead AnnRowBody
84− deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
85−
86−-- | The row number of a row. Note that rows are numbered continuously
87−-- from zero from the start of the table, so the first row in a table
88−-- body, for instance, may have a large 'RowNumber'.
89−newtype RowNumber = RowNumber Int
90− deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Num, Enum)
91−
92−-- | The head of a body row; the portion of the row lying in the stub
93−-- of the 'TableBody'. Its cells correspond to HTML @\<th\>@ cells.
94−type AnnRowHead = [AnnCell]
95−
96−-- | The body of a body row; the portion of the row lying after the
97−-- stub of the 'TableBody'. Its cells correspond to HTML @\<td\>@
98−-- cells.
99−type AnnRowBody = [AnnCell]
100−
101−-- | An annotated table cell, wrapping a 'Cell' with its 'ColNumber'
102−-- and the 'ColSpec' data for the columns that the cell spans.
103−data AnnCell = AnnCell (NonEmpty ColSpec) ColNumber Cell
104− deriving (Eq, Ord, Read, Show, Typeable, Data, Generic)
105−
106−-- | The column number of a cell, meaning the column number of the
107−-- first column that the cell spans, if the table were laid on a
108−-- grid. Columns are numbered starting from zero.
109−newtype ColNumber = ColNumber Int
110− deriving (Eq, Ord, Read, Show, Typeable, Data, Generic, Num, Enum)
111−
112−-- | Convert a 'Table' to an 'AnnTable'. This function also performs
113−-- the same normalization that the 'table' builder does (fixing
114−-- overlapping cells, cells that protrude out of their table section,
115−-- and so on). If the input table happens to satisfy the conditions
116−-- that 'table' guarantees, then the resulting 'AnnTable' will be
117−-- identical, save for the addition of the inferred table information.
118−toAnnTable
119− :: Attr
120− -> Caption
121− -> [ColSpec]
122− -> TableHead
123− -> [TableBody]
124− -> TableFoot
125− -> AnnTable
126−toAnnTable attr cap cs th tbs tf = AnnTable attr cap cs th' tbs' tf'
127− where
128− (th', tbs', tf') = fst $ evalRWS (annotateTable th tbs tf) (cs, length cs) 0
129−
130−-- | Internal monad for annotating a table, passing in the 'ColSpec'
131−-- data for the table, the grid width, and the current 'RowNumber' to
132−-- be referenced or updated.
133−type AnnM a = RWS ([ColSpec], Int) () RowNumber a
134−
135−incRowNumber :: AnnM RowNumber
136−incRowNumber = do
137− rn <- get
138− put $ rn + 1
139− return rn
140−
141−annotateTable
142− :: TableHead
143− -> [TableBody]
144− -> TableFoot
145− -> AnnM (AnnTableHead, [AnnTableBody], AnnTableFoot)
146−annotateTable th tbs tf = do
147− th' <- annotateTableHead th
148− tbs' <- traverse annotateTableBody tbs
149− tf' <- annotateTableFoot tf
150− return (th', tbs', tf')
151−
152−annotateTableHead :: TableHead -> AnnM AnnTableHead
153−annotateTableHead (TableHead attr rows) =
154− AnnTableHead attr <$> annotateHeaderSection rows
155−
156−annotateTableBody :: TableBody -> AnnM AnnTableBody
157−annotateTableBody (TableBody attr rhc th tb) = do
158− twidth <- asks snd
159− let rhc' = max 0 $ min (RowHeadColumns twidth) rhc
160− th' <- annotateHeaderSection th
161− tb' <- annotateBodySection rhc' tb
162− return $ AnnTableBody attr rhc' th' tb'
163−
164−annotateTableFoot :: TableFoot -> AnnM AnnTableFoot
165−annotateTableFoot (TableFoot attr rows) =
166− AnnTableFoot attr <$> annotateHeaderSection rows
167−
168−annotateHeaderSection :: [Row] -> AnnM [AnnHeaderRow]
169−annotateHeaderSection rows = do
170− colspec <- asks fst
171− let hangcolspec = (1, ) <$> colspec
172− annotateHeaderSection' hangcolspec id $ clipRows rows
173− where
174− annotateHeaderSection' oldHang acc (Row attr cells : rs) = do
175− let (_, newHang, cells', _) =
176− annotateRowSection 0 oldHang $ cells <> repeat emptyCell
177− n <- incRowNumber
178− let annRow = AnnHeaderRow attr n cells'
179− annotateHeaderSection' newHang (acc . (annRow :)) rs
180− annotateHeaderSection' _ acc [] = return $ acc []
181−
182−annotateBodySection :: RowHeadColumns -> [Row] -> AnnM [AnnBodyRow]
183−annotateBodySection (RowHeadColumns rhc) rows = do
184− colspec <- asks fst
185− let colspec' = (1, ) <$> colspec
186− let (stubspec, bodyspec) = splitAt rhc colspec'
187− normalizeBodySection' stubspec bodyspec id $ clipRows rows
188− where
189− normalizeBodySection' headHang bodyHang acc (Row attr cells : rs) = do
190− let (colnum, headHang', rowStub, cells') =
191− annotateRowSection 0 headHang $ cells <> repeat emptyCell
192− let (_, bodyHang', rowBody, _) = annotateRowSection colnum bodyHang cells'
193− n <- incRowNumber
194− let annRow = AnnBodyRow attr n rowStub rowBody
195− normalizeBodySection' headHang' bodyHang' (acc . (annRow :)) rs
196− normalizeBodySection' _ _ acc [] = return $ acc []
197−
198−-- | Lay out a section of a 'Table' row on a grid row, annotating the
199−-- cells with the 'ColSpec' data for the columns that they
200−-- span. Performs the same normalization as 'placeRowSection'.
201−annotateRowSection
202− :: ColNumber -- ^ The current column number
203− -> [(RowSpan, ColSpec)] -- ^ The overhang of the previous grid row,
204− -- with column data
205− -> [Cell] -- ^ The cells to annotate
206− -> (ColNumber, [(RowSpan, ColSpec)], [AnnCell], [Cell]) -- ^ The new
207− -- column
208− -- number,
209− -- overhang,
210− -- annotated
211− -- cells,
212− -- and
213− -- remaining
214− -- cells
215−annotateRowSection !colnum oldHang cells
216− -- If the grid has overhang at our position, try to re-lay in
217− -- the next position.
218− | (o, colspec) : os <- oldHang
219− , o > 1
220− = let (colnum', newHang, newCell, cells') =
221− annotateRowSection (colnum + 1) os cells
222− in (colnum', (o - 1, colspec) : newHang, newCell, cells')
223− -- Otherwise if there is any available width, place the cell and
224− -- continue.
225− | c : cells' <- cells
226− , (h, w) <- getDim c
227− , w' <- max 1 w
228− , (w'', cellHang@(chStart : chRest), oldHang') <- splitCellHang h w' oldHang
229− = let c' = setW w'' c
230− annCell = AnnCell (snd <$> chStart :| chRest) colnum c'
231− colnum' = colnum + ColNumber (getColSpan w'')
232− (colnum'', newHang, newCells, remainCells) =
233− annotateRowSection colnum' oldHang' cells'
234− in (colnum'', cellHang <> newHang, annCell : newCells, remainCells)
235− -- Otherwise there is no room in the section
236− | otherwise
237− = (colnum, [], [], cells)
238− where
239− getColSpan (ColSpan x) = x
240− getDim (Cell _ _ h w _) = (h, w)
241− setW w (Cell a b h _ c) = Cell a b h w c
242−
243−-- | In @'splitCellHang' rs cs coldata@, with @rs@ the height of a
244−-- cell that lies at the beginning of @coldata@, and @cs@ its width
245−-- (which is not assumed to fit in the available space), return the
246−-- actual width of the cell (what will fit in the available space),
247−-- the data for the columns that the cell spans (including updating
248−-- the overhang to equal @rs@), and the remaining column data.
249−splitCellHang
250− :: RowSpan
251− -> ColSpan
252− -> [(RowSpan, ColSpec)]
253− -> (ColSpan, [(RowSpan, ColSpec)], [(RowSpan, ColSpec)])
254−splitCellHang h n = go 0
255− where
256− go acc ((1, spec) : ls) | acc < n =
257− let (acc', hang, ls') = go (acc + 1) ls in (acc', (h, spec) : hang, ls')
258− go acc l = (acc, [], l)
259−
260−-- | Convert an 'AnnTable' to a 'Table'. This is the inverse of
261−-- 'toAnnTable' on well-formed tables (i.e. tables satisfying the
262−-- guarantees of 'table').
263−fromAnnTable
264− :: AnnTable -> (Attr, Caption, [ColSpec], TableHead, [TableBody], TableFoot)
265−fromAnnTable (AnnTable attr cap cs th tbs tf) = (attr, cap, cs, th', tbs', tf')
266− where
267− th' = fromAnnTableHead th
268− tbs' = map fromAnnTableBody tbs
269− tf' = fromAnnTableFoot tf
270−
271−fromAnnTableHead :: AnnTableHead -> TableHead
272−fromAnnTableHead (AnnTableHead attr rows) =
273− TableHead attr $ fromAnnHeaderRow <$> rows
274−
275−fromAnnTableBody :: AnnTableBody -> TableBody
276−fromAnnTableBody (AnnTableBody attr rhc th tb) =
277− TableBody attr rhc (fromAnnHeaderRow <$> th) (fromAnnBodyRow <$> tb)
278−
279−fromAnnTableFoot :: AnnTableFoot -> TableFoot
280−fromAnnTableFoot (AnnTableFoot attr rows) =
281− TableFoot attr $ fromAnnHeaderRow <$> rows
282−
283−fromAnnHeaderRow :: AnnHeaderRow -> Row
284−fromAnnHeaderRow (AnnHeaderRow attr _ cells) = Row attr $ fromAnnCell <$> cells
285−
286−fromAnnBodyRow :: AnnBodyRow -> Row
287−fromAnnBodyRow (AnnBodyRow attr _ rh rb) =
288− Row attr ((fromAnnCell <$> rh) <> (fromAnnCell <$> rb))
289−
290−fromAnnCell :: AnnCell -> Cell
291−fromAnnCell (AnnCell _ _ c) = c