Add new internal module Text.Pandoc.Writers.GridTable
This commit is contained in:
parent
56a0d874c7
commit
3da919e35d
2 changed files with 159 additions and 0 deletions
|
@ -438,6 +438,7 @@ library
|
|||
SHA >= 1.6 && < 1.7,
|
||||
aeson >= 0.7 && < 1.6,
|
||||
aeson-pretty >= 0.8.5 && < 0.9,
|
||||
array >= 0.5 && < 0.6,
|
||||
attoparsec >= 0.12 && < 0.15,
|
||||
base64-bytestring >= 0.1 && < 1.3,
|
||||
binary >= 0.7 && < 0.11,
|
||||
|
@ -659,6 +660,7 @@ library
|
|||
Text.Pandoc.Writers.Docx.StyleMap,
|
||||
Text.Pandoc.Writers.Docx.Table,
|
||||
Text.Pandoc.Writers.Docx.Types,
|
||||
Text.Pandoc.Writers.GridTable
|
||||
Text.Pandoc.Writers.JATS.References,
|
||||
Text.Pandoc.Writers.JATS.Table,
|
||||
Text.Pandoc.Writers.JATS.Types,
|
||||
|
|
157
src/Text/Pandoc/Writers/GridTable.hs
Normal file
157
src/Text/Pandoc/Writers/GridTable.hs
Normal file
|
@ -0,0 +1,157 @@
|
|||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
{- |
|
||||
Module : Text.Pandoc.Writers.GridTable
|
||||
Copyright : © 2020-2021 Albert Krewinkel
|
||||
License : GNU GPL, version 2 or above
|
||||
|
||||
Maintainer : Albert Krewinkel <albert@zeitkraut.de>
|
||||
|
||||
Grid representation of pandoc tables.
|
||||
-}
|
||||
module Text.Pandoc.Writers.GridTable
|
||||
( Table (..)
|
||||
, GridCell (..)
|
||||
, RowIndex (..)
|
||||
, ColIndex (..)
|
||||
, CellIndex
|
||||
, Part (..)
|
||||
, toTable
|
||||
, rowArray
|
||||
) where
|
||||
|
||||
import Control.Monad (forM_)
|
||||
import Control.Monad.ST
|
||||
import Data.Array
|
||||
import Data.Array.MArray
|
||||
import Data.Array.ST
|
||||
import Data.Maybe (listToMaybe)
|
||||
import Data.STRef
|
||||
import Text.Pandoc.Definition hiding (Table)
|
||||
import qualified Text.Pandoc.Builder as B
|
||||
|
||||
-- | A grid cell contains either a real table cell, or is the
|
||||
-- continuation of a column or row-spanning cell. In the latter case,
|
||||
-- the index of the continued cell is provided.
|
||||
data GridCell
|
||||
= ContentCell Attr Alignment RowSpan ColSpan [Block]
|
||||
| ContinuationCell CellIndex
|
||||
deriving (Show)
|
||||
|
||||
-- | Row index in a table part.
|
||||
newtype RowIndex = RowIndex Int deriving (Enum, Eq, Ix, Ord, Show)
|
||||
-- | Column index in a table part.
|
||||
newtype ColIndex = ColIndex Int deriving (Enum, Eq, Ix, Ord, Show)
|
||||
|
||||
-- | Index to a cell in a table part.
|
||||
type CellIndex = (RowIndex, ColIndex)
|
||||
|
||||
-- | Cells are placed on a grid. Row attributes are stored in a separate
|
||||
-- array.
|
||||
data Part = Part
|
||||
{ partAttr :: Attr
|
||||
, partCellArray :: Array (RowIndex,ColIndex) GridCell
|
||||
, partRowAttrs :: Array RowIndex Attr
|
||||
}
|
||||
|
||||
data Table = Table
|
||||
{ tableAttr :: Attr
|
||||
, tableCaption :: Caption
|
||||
, tableColSpecs :: Array ColIndex ColSpec
|
||||
, tableRowHeads :: RowHeadColumns
|
||||
, tableHead :: Part
|
||||
, tableBodies :: [Part]
|
||||
, tableFoot :: Part
|
||||
}
|
||||
|
||||
toTable
|
||||
:: B.Attr
|
||||
-> B.Caption
|
||||
-> [B.ColSpec]
|
||||
-> B.TableHead
|
||||
-> [B.TableBody]
|
||||
-> B.TableFoot
|
||||
-> Table
|
||||
toTable attr caption colSpecs thead tbodies tfoot =
|
||||
Table attr caption colSpecs' rowHeads thGrid tbGrids tfGrid
|
||||
where
|
||||
colSpecs' = listArray (ColIndex 1, ColIndex $ length colSpecs) colSpecs
|
||||
rowHeads = case listToMaybe tbodies of
|
||||
Nothing -> RowHeadColumns 0
|
||||
Just (TableBody _attr rowHeadCols _headerRows _rows) -> rowHeadCols
|
||||
thGrid = let (TableHead headAttr rows) = thead
|
||||
in rowsToPart headAttr rows
|
||||
tbGrids = map bodyToGrid tbodies
|
||||
tfGrid = let (TableFoot footAttr rows) = tfoot
|
||||
in rowsToPart footAttr rows
|
||||
bodyToGrid (TableBody bodyAttr _rowHeadCols _headRows rows) =
|
||||
rowsToPart bodyAttr rows
|
||||
|
||||
data BuilderCell
|
||||
= FilledCell GridCell
|
||||
| FreeCell
|
||||
|
||||
fromBuilderCell :: BuilderCell -> GridCell
|
||||
fromBuilderCell = \case
|
||||
FilledCell c -> c
|
||||
FreeCell -> error "Found an unassigned cell."
|
||||
|
||||
rowsToPart :: Attr -> [B.Row] -> Part
|
||||
rowsToPart attr = \case
|
||||
[] -> Part
|
||||
attr
|
||||
(listArray ((RowIndex 1, ColIndex 1), (RowIndex 0, ColIndex 0)) [])
|
||||
(listArray (RowIndex 1, RowIndex 0) [])
|
||||
rows@(Row _attr firstRow:_) ->
|
||||
let nrows = length rows
|
||||
ncols = sum $ map (\(Cell _ _ _ (ColSpan cs) _) -> cs) firstRow
|
||||
gbounds = ((RowIndex 1, ColIndex 1), (RowIndex nrows, ColIndex ncols))
|
||||
mutableGrid :: ST s (STArray s CellIndex GridCell)
|
||||
mutableGrid = do
|
||||
grid <- newArray gbounds FreeCell
|
||||
ridx <- newSTRef (RowIndex 1)
|
||||
forM_ rows $ \(Row _attr cells) -> do
|
||||
cidx <- newSTRef (ColIndex 1)
|
||||
forM_ cells $ \(Cell cellAttr align rs cs blks) -> do
|
||||
ridx' <- readSTRef ridx
|
||||
let nextFreeInRow colindex@(ColIndex c) = do
|
||||
readArray grid (ridx', colindex) >>= \case
|
||||
FreeCell -> pure colindex
|
||||
_ -> nextFreeInRow $ ColIndex (c + 1)
|
||||
cidx' <- readSTRef cidx >>= nextFreeInRow
|
||||
writeArray grid (ridx', cidx') . FilledCell $
|
||||
ContentCell cellAttr align rs cs blks
|
||||
forM_ (continuationIndices ridx' cidx' rs cs) $ \idx -> do
|
||||
writeArray grid idx . FilledCell $
|
||||
ContinuationCell (ridx', cidx')
|
||||
-- go to new column
|
||||
writeSTRef cidx cidx'
|
||||
-- go to next row
|
||||
modifySTRef ridx (incrRowIndex 1)
|
||||
-- Swap BuilderCells with normal GridCells.
|
||||
mapArray fromBuilderCell grid
|
||||
in Part
|
||||
{ partCellArray = runSTArray mutableGrid
|
||||
, partRowAttrs = listArray (RowIndex 1, RowIndex nrows) $
|
||||
map (\(Row rowAttr _) -> rowAttr) rows
|
||||
, partAttr = attr
|
||||
}
|
||||
|
||||
continuationIndices :: RowIndex -> ColIndex -> RowSpan -> ColSpan -> [CellIndex]
|
||||
continuationIndices (RowIndex ridx) (ColIndex cidx) rowspan colspan =
|
||||
let (RowSpan rs) = rowspan
|
||||
(ColSpan cs) = colspan
|
||||
in [ (RowIndex r, ColIndex c) | r <- [ridx..(ridx + rs - 1)]
|
||||
, c <- [cidx..(cidx + cs - 1)]
|
||||
, (r, c) /= (ridx, cidx)]
|
||||
|
||||
rowArray :: RowIndex -> Array CellIndex GridCell -> Array ColIndex GridCell
|
||||
rowArray ridx grid =
|
||||
let ((_minRidx, minCidx), (_maxRidx, maxCidx)) = bounds grid
|
||||
in ixmap (minCidx, maxCidx) (ridx,) grid
|
||||
|
||||
incrRowIndex :: RowSpan -> RowIndex -> RowIndex
|
||||
incrRowIndex (RowSpan n) (RowIndex r) = RowIndex $ r + n
|
Loading…
Reference in a new issue