@@ -0,0 +1,157 @@
1+{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE LambdaCase #-}
4+{-# LANGUAGE TupleSections #-}
5+
6+{- |
7+Module : Text.Pandoc.Writers.GridTable
8+Copyright : © 2020-2021 Albert Krewinkel
9+License : GNU GPL, version 2 or above
10+
11+Maintainer : Albert Krewinkel <albert@zeitkraut.de>
12+
13+Grid representation of pandoc tables.
14+-}
15+module Text.Pandoc.Writers.GridTable
16+ ( Table (..)
17+ , GridCell (..)
18+ , RowIndex (..)
19+ , ColIndex (..)
20+ , CellIndex
21+ , Part (..)
22+ , toTable
23+ , rowArray
24+ ) where
25+
26+import Control.Monad (forM_)
27+import Control.Monad.ST
28+import Data.Array
29+import Data.Array.MArray
30+import Data.Array.ST
31+import Data.Maybe (listToMaybe)
32+import Data.STRef
33+import Text.Pandoc.Definition hiding (Table)
34+import qualified Text.Pandoc.Builder as B
35+
36+-- | A grid cell contains either a real table cell, or is the
37+-- continuation of a column or row-spanning cell. In the latter case,
38+-- the index of the continued cell is provided.
39+data GridCell
40+ = ContentCell Attr Alignment RowSpan ColSpan [Block]
41+ | ContinuationCell CellIndex
42+ deriving (Show)
43+
44+-- | Row index in a table part.
45+newtype RowIndex = RowIndex Int deriving (Enum, Eq, Ix, Ord, Show)
46+-- | Column index in a table part.
47+newtype ColIndex = ColIndex Int deriving (Enum, Eq, Ix, Ord, Show)
48+
49+-- | Index to a cell in a table part.
50+type CellIndex = (RowIndex, ColIndex)
51+
52+-- | Cells are placed on a grid. Row attributes are stored in a separate
53+-- array.
54+data Part = Part
55+ { partAttr :: Attr
56+ , partCellArray :: Array (RowIndex,ColIndex) GridCell
57+ , partRowAttrs :: Array RowIndex Attr
58+ }
59+
60+data Table = Table
61+ { tableAttr :: Attr
62+ , tableCaption :: Caption
63+ , tableColSpecs :: Array ColIndex ColSpec
64+ , tableRowHeads :: RowHeadColumns
65+ , tableHead :: Part
66+ , tableBodies :: [Part]
67+ , tableFoot :: Part
68+ }
69+
70+toTable
71+ :: B.Attr
72+ -> B.Caption
73+ -> [B.ColSpec]
74+ -> B.TableHead
75+ -> [B.TableBody]
76+ -> B.TableFoot
77+ -> Table
78+toTable attr caption colSpecs thead tbodies tfoot =
79+ Table attr caption colSpecs' rowHeads thGrid tbGrids tfGrid
80+ where
81+ colSpecs' = listArray (ColIndex 1, ColIndex $ length colSpecs) colSpecs
82+ rowHeads = case listToMaybe tbodies of
83+ Nothing -> RowHeadColumns 0
84+ Just (TableBody _attr rowHeadCols _headerRows _rows) -> rowHeadCols
85+ thGrid = let (TableHead headAttr rows) = thead
86+ in rowsToPart headAttr rows
87+ tbGrids = map bodyToGrid tbodies
88+ tfGrid = let (TableFoot footAttr rows) = tfoot
89+ in rowsToPart footAttr rows
90+ bodyToGrid (TableBody bodyAttr _rowHeadCols _headRows rows) =
91+ rowsToPart bodyAttr rows
92+
93+data BuilderCell
94+ = FilledCell GridCell
95+ | FreeCell
96+
97+fromBuilderCell :: BuilderCell -> GridCell
98+fromBuilderCell = \case
99+ FilledCell c -> c
100+ FreeCell -> error "Found an unassigned cell."
101+
102+rowsToPart :: Attr -> [B.Row] -> Part
103+rowsToPart attr = \case
104+ [] -> Part
105+ attr
106+ (listArray ((RowIndex 1, ColIndex 1), (RowIndex 0, ColIndex 0)) [])
107+ (listArray (RowIndex 1, RowIndex 0) [])
108+ rows@(Row _attr firstRow:_) ->
109+ let nrows = length rows
110+ ncols = sum $ map (\(Cell _ _ _ (ColSpan cs) _) -> cs) firstRow
111+ gbounds = ((RowIndex 1, ColIndex 1), (RowIndex nrows, ColIndex ncols))
112+ mutableGrid :: ST s (STArray s CellIndex GridCell)
113+ mutableGrid = do
114+ grid <- newArray gbounds FreeCell
115+ ridx <- newSTRef (RowIndex 1)
116+ forM_ rows $ \(Row _attr cells) -> do
117+ cidx <- newSTRef (ColIndex 1)
118+ forM_ cells $ \(Cell cellAttr align rs cs blks) -> do
119+ ridx' <- readSTRef ridx
120+ let nextFreeInRow colindex@(ColIndex c) = do
121+ readArray grid (ridx', colindex) >>= \case
122+ FreeCell -> pure colindex
123+ _ -> nextFreeInRow $ ColIndex (c + 1)
124+ cidx' <- readSTRef cidx >>= nextFreeInRow
125+ writeArray grid (ridx', cidx') . FilledCell $
126+ ContentCell cellAttr align rs cs blks
127+ forM_ (continuationIndices ridx' cidx' rs cs) $ \idx -> do
128+ writeArray grid idx . FilledCell $
129+ ContinuationCell (ridx', cidx')
130+ -- go to new column
131+ writeSTRef cidx cidx'
132+ -- go to next row
133+ modifySTRef ridx (incrRowIndex 1)
134+ -- Swap BuilderCells with normal GridCells.
135+ mapArray fromBuilderCell grid
136+ in Part
137+ { partCellArray = runSTArray mutableGrid
138+ , partRowAttrs = listArray (RowIndex 1, RowIndex nrows) $
139+ map (\(Row rowAttr _) -> rowAttr) rows
140+ , partAttr = attr
141+ }
142+
143+continuationIndices :: RowIndex -> ColIndex -> RowSpan -> ColSpan -> [CellIndex]
144+continuationIndices (RowIndex ridx) (ColIndex cidx) rowspan colspan =
145+ let (RowSpan rs) = rowspan
146+ (ColSpan cs) = colspan
147+ in [ (RowIndex r, ColIndex c) | r <- [ridx..(ridx + rs - 1)]
148+ , c <- [cidx..(cidx + cs - 1)]
149+ , (r, c) /= (ridx, cidx)]
150+
151+rowArray :: RowIndex -> Array CellIndex GridCell -> Array ColIndex GridCell
152+rowArray ridx grid =
153+ let ((_minRidx, minCidx), (_maxRidx, maxCidx)) = bounds grid
154+ in ixmap (minCidx, maxCidx) (ridx,) grid
155+
156+incrRowIndex :: RowSpan -> RowIndex -> RowIndex
157+incrRowIndex (RowSpan n) (RowIndex r) = RowIndex $ r + n