gridtables (empty) → 0.0.1.0
raw patch · 9 files changed
+1106/−0 lines, 9 filesdep +arraydep +basedep +containers
Dependencies added: array, base, containers, doclayout, gridtables, parsec, tasty, tasty-hunit, text
Files
- CHANGELOG.md +11/−0
- LICENSE +21/−0
- README.md +74/−0
- gridtables.cabal +79/−0
- src/Text/GridTable.hs +54/−0
- src/Text/GridTable/ArrayTable.hs +87/−0
- src/Text/GridTable/Parse.hs +56/−0
- src/Text/GridTable/Trace.hs +427/−0
- test/test-gridtables.hs +297/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+# Changelog++`gridtables` uses [PVP Versioning][].++## gridtables-0.0.1++Release pending.++- Boldly going where no Haskell library has gone before.++ [PVP Versioning]: https://pvp.haskell.org
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2022 Albert Krewinkel++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,74 @@+# gridtables++Parser for reStructuredText-style grid tables.++This package provides a parser for plain-text representations of+tables, like the one given below.++```++---------------------+-----------------------++| Location | Temperature 1961-1990 |+| | in degree Celsius |+| +-------+-------+-------++| | min | mean | max |++=====================+=======+=======+=======++| Antarctica | -89.2 | N/A | 19.8 |++---------------------+-------+-------+-------++| Earth | -89.2 | 14 | 56.7 |++---------------------+-------+-------+-------++```++## Character widths++The tables are intended to look good when viewed in a monospace+font. Therefore, wide and full-width characters, as those in East+Asian scripts, are counted as two characters.++## Column alignments++The parser re-implements a table extensions from John MacFarlane's+pandoc, namely support for column-wide cell alignments. The+alignment of cells is determined by placing colons in the row that+separates the table head from the body, like so:++ +------+--------+-------++ | left | center | right |+ +:=====+:======:+======:++ | 1 | 2 | 3 |+ +------+--------+-------+++The first line must be used for headless tables:++ +:-----+:------:+------:++ | left | center | right |+ +------+--------+-------++ | a 1 | b 2 | c 3 |+ +------+--------+-------++++## Algorithm++The cell tracing algorithm used in this package has been+translated from the original Python implementation for+reStructuredText. The parser has been placed in the public domain.++## Usage++The usual way to use this package will be to use it as part of a+parsec parser:++``` haskell+main :: IO ()+main = do+ let gt = T.unlines+ [ "+------+--------+-------+"+ , "| left | center | right |"+ , "+:=====+:======:+======:+"+ , "| 1 | 2 | 3 |"+ , "+------+--------+-------+"+ ]+ in print (runParser GT.gridTable () "table" gt)+```++Use `traceLines :: [Text] -> Maybe (GridTable [Text])`, if the+table's raw lines have been retrieved in a different way.
+ gridtables.cabal view
@@ -0,0 +1,79 @@+cabal-version: 2.4+name: gridtables+version: 0.0.1.0+synopsis: Parser for reStructuredText-style grid tables.+description: Provides a parser for plain-text representations of+ tables. This package supports table headers, cells+ spanning multiple columns or rows, as well as a way+ to specfiy column alignments.+homepage: https://github.com/tarleb/gridtables+bug-reports: https://github.com/tarleb/gridtables/issues+license: MIT+license-file: LICENSE+author: Albert Krewinkel+maintainer: Albert Krewinkel <albert@zeitkraut.de>+copyright: © 2022 Albert Krewinkel+category: Text+extra-doc-files: README.md+ , CHANGELOG.md+tested-with: GHC == 8.6.5+ GHC == 8.8.4+ GHC == 8.10.7+ GHC == 9.0.2+ GHC == 9.2.2++source-repository head+ type: git+ location: https://github.com/tarleb/gridtables.git++common common-options+ build-depends: base >= 4.12 && < 5+ , array+ , parsec >= 3.1 && < 3.2+ , text >= 1.1.1.0 && < 1.3 || >= 2.0 && < 2.1+ default-language: Haskell2010+ default-extensions: OverloadedStrings+ other-extensions: FlexibleContexts+ , LambdaCase+ ghc-options: -Wall+ -Wcompat+ -Widentities+ -Wincomplete-record-updates+ -Wincomplete-uni-patterns+ -Wmissing-export-lists+ -Wpartial-fields+ -Wredundant-constraints+ -fhide-source-paths+ if impl(ghc >= 8.8)+ ghc-options: -Wmissing-deriving-strategies++ if impl(ghc >= 8.10)+ ghc-options: -Wunused-packages++ if impl(ghc >= 9.0)+ ghc-options: -Winvalid-haddock++library+ import: common-options+ hs-source-dirs: src+ build-depends: containers+ , doclayout+ exposed-modules: Text.GridTable+ , Text.GridTable.ArrayTable+ , Text.GridTable.Parse+ , Text.GridTable.Trace+ other-extensions: DeriveFunctor+ , DerivingStrategies+ , GeneralizedNewtypeDeriving++test-suite test-gridtables+ import: common-options+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: test-gridtables.hs+ build-depends: gridtables+ , tasty >= 0.11+ , tasty-hunit >= 0.9+ ghc-options: -threaded+ -rtsopts+ -with-rtsopts=-N
+ src/Text/GridTable.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{- |+Module : Text.GridTable+Copyright : © 2022 Albert Krewinkel+License : MIT+Maintainer : Albert Krewinkel <albert@zeitkraut.de>++Parse reStructuredText-style grid tables.+-}++module Text.GridTable+ ( module Text.GridTable.ArrayTable+ -- * Parse from character stream+ , gridTable+ -- * List-based representation+ , Cell (..)+ , rows+ ) where++import Prelude hiding (lines)+import Data.Array (Array, elems, bounds)+import Data.Bifunctor (bimap)+import Data.Maybe (mapMaybe)+import Text.GridTable.ArrayTable+import Text.GridTable.Parse (gridTable)++colBounds :: Array CellIndex a -> (ColIndex, ColIndex)+colBounds = bimap snd snd . bounds++-- | Returns the rows of a grid table as lists of simple cells.+rows :: ArrayTable a -> [[Cell a]]+rows gt =+ let tarr = arrayTableCells gt+ ncols = fromColIndex . uncurry (flip (-)) $ colBounds tarr+ toSimpleCell = \case+ ContentCell rs cs c -> Just $ Cell c rs cs+ ContinuationCell {} -> Nothing+ mkRows :: [[Cell a]] -> [GridCell a] -> [[Cell a]]+ mkRows rs = \case+ [] -> reverse rs+ xs -> let (r, xs') = splitAt (ncols + 1) xs+ in mkRows (mapMaybe toSimpleCell r:rs) xs'+ in mkRows [] $ elems tarr++-- | Raw grid table cell+data Cell a = Cell+ { cellContent :: a+ , cellRowSpan :: RowSpan+ , cellColSpan :: ColSpan+ }+ deriving stock (Eq, Ord, Show)
+ src/Text/GridTable/ArrayTable.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{- |+Module : Text.GridTable.ArrayTable+Copyright : © 2022 Albert Krewinkel+License : MIT+Maintainer : Albert Krewinkel <albert@zeitkraut.de>++Grid table representation based on arrays.+-}++module Text.GridTable.ArrayTable+ ( ArrayTable (..)+ , GridCell (..)+ , RowSpan (..)+ , ColSpan (..)+ , CellIndex+ , RowIndex (..)+ , ColIndex (..)+ , Alignment (..)+ , mapCells+ ) where++import Data.Array (Array, Ix)+import Data.Array.MArray (mapArray, thaw)+import Data.Array.ST (runSTArray)++-- | Table representation based on an array; cells are placed on a grid,+-- with indices spanned by other cells containing placeholder cells that+-- point to the spanning cell.+data ArrayTable a = ArrayTable+ { arrayTableCells :: Array CellIndex (GridCell a)+ , arrayTableHead :: Maybe RowIndex+ , arrayTableColSpecs :: Array ColIndex (Alignment, Int)+ }+ deriving stock (Eq, Show)++-- | Apply a function to all cell contents in a grid table.+mapCells :: (a -> b) -> ArrayTable a -> ArrayTable b+mapCells f gt =+ let f' = \case+ ContentCell rs cs c -> ContentCell rs cs $ f c+ ContinuationCell idx -> ContinuationCell idx+ cellArray = runSTArray $ do+ mut <- thaw $ arrayTableCells gt+ mapArray f' mut+ in gt { arrayTableCells = cellArray }++-- | Row index in a table array.+newtype RowIndex = RowIndex { fromRowIndex :: Int }+ deriving stock (Eq, Ix, Ord)+ deriving newtype (Enum, Num, Show)++-- | Column index in a table array.+newtype ColIndex = ColIndex { fromColIndex :: Int }+ deriving stock (Eq, Ix, Ord)+ deriving newtype (Enum, Num, Show)++-- | Index to a cell in a table part.+type CellIndex = (RowIndex, ColIndex)++-- | 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 a+ = ContentCell RowSpan ColSpan a+ | ContinuationCell CellIndex+ deriving stock (Eq, Show)++-- | The number of rows spanned by a cell.+newtype RowSpan = RowSpan Int+ deriving stock (Eq, Ord)+ deriving newtype (Enum, Num, Read, Show)++-- | The number of columns spanned by a cell.+newtype ColSpan = ColSpan Int+ deriving stock (Eq, Ord)+ deriving newtype (Enum, Num, Read, Show)++-- | Cell alignment+data Alignment+ = AlignDefault+ | AlignLeft+ | AlignCenter+ | AlignRight+ deriving stock (Enum, Eq, Ord, Read, Show)
+ src/Text/GridTable/Parse.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{- |+Module : Text.GridTable+Copyright : © 2022 Albert Krewinkel+License : MIT+Maintainer : Albert Krewinkel <albert@zeitkraut.de>++Parse reStructuredText-style grid tables.+-}++module Text.GridTable.Parse+ ( gridTable+ , tableLine+ ) where++import Prelude hiding (lines)+import Data.Text (Text)+import Text.GridTable.ArrayTable+import Text.GridTable.Trace (traceLines)+import Text.Parsec+import qualified Data.Text as T++-- | Parses a grid table.+gridTable :: Stream s m Char => ParsecT s u m (ArrayTable [Text])+gridTable = try $ do+ firstLine <- (:) <$> char '+'+ <*> (mconcat <$> many1 (gridPart '-'))+ <* skipSpaces+ <* newline+ lines <- many1 tableLine+ case traceLines (T.pack firstLine : lines) of+ Nothing -> fail "tracing failed"+ Just gt -> return gt++skipSpaces :: Stream s m Char => ParsecT s u m ()+skipSpaces = skipMany (satisfy $ \c -> c == '\t' || c == ' ')++-- | Parses a line that's part of a table. The line must start with+-- either a plus @+@ or a pipe @|@.+tableLine :: Stream s m Char+ => ParsecT s u m Text+tableLine = try $ do+ let borderChar = char '+' <|> char '|'+ firstChar <- borderChar+ rest <- manyTill (noneOf "\n\r") newline+ return $ T.stripEnd $ T.pack (firstChar : rest)++gridPart :: Stream s m Char+ => Char -> ParsecT s u m String+gridPart ch = do+ leftColon <- option id ((:) <$> char ':')+ dashes <- many1 (char ch)+ rightColon <- option id ((:) <$> char ':')+ plus <- char '+'+ return . leftColon . (dashes ++) . rightColon $ [plus]
+ src/Text/GridTable/Trace.hs view
@@ -0,0 +1,427 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{- |+Module : Text.GridTable.Trace+Copyright : © 2022 Albert Krewinkel+License : MIT+Maintainer : Albert Krewinkel <albert@zeitkraut.de>++Trace cells of a grid table.+-}++module Text.GridTable.Trace+ ( traceLines+ , TraceInfo (..)+ , initialTraceInfo+ , tableFromTraceInfo+ ) where++import Prelude hiding (lines)+import Control.Applicative ((<|>))+import Control.Monad (forM_)+import Control.Monad.ST+import Data.Array+import Data.Array.MArray+import Data.Array.ST+import Data.Function (on)+import Data.Maybe (fromMaybe, mapMaybe)+import Data.Set (Set)+import Data.Text (Text)+import Text.DocLayout (charWidth)+import Text.GridTable.ArrayTable+import qualified Data.Map.Strict as Map+import qualified Data.Set as Set+import qualified Data.Text as T++-- | Traces out the cells in the given lines and converts them to a+-- table containing the bare cell lines.+traceLines :: [Text] -> Maybe (ArrayTable [Text])+traceLines lines =+ let charGrid = toCharGrid lines+ specs1 = colSpecsInLine '-' charGrid 1+ partSeps = findSeparators charGrid+ charGrid' = convertToNormalLines (1:map partSepLine partSeps) charGrid+ traceInfo = traceCharGrid charGrid' initialTraceInfo+ in if Set.null (gridCells traceInfo)+ then fail "no cells"+ else return $ tableFromTraceInfo traceInfo partSeps specs1++-- | Type used to represent the 2D layout of table characters+type CharGrid = Array (CharRow, CharCol) (Maybe Char)++-- | Index of a half-width character in the character-wise+-- representation.+type CharIndex = (CharRow, CharCol)++-- | Character row+newtype CharRow = CharRow Int+ deriving stock (Eq, Show)+ deriving newtype (Enum, Ix, Num, Ord)++-- | Character column+newtype CharCol = CharCol { fromCharCol :: Int }+ deriving stock (Eq, Show)+ deriving newtype (Enum, Ix, Num, Ord)++-- | Converts a list of lines into an char array.+toCharGrid :: [Text] -> CharGrid+toCharGrid lines =+ let chars = foldr (\t m -> max m (T.length t)) 0 lines+ gbounds = ( (CharRow 1, CharCol 1)+ , (CharRow (length lines), CharCol chars)+ )+ charList c = case charWidth c of+ 2 -> [Just c, Nothing]+ _ -> [Just c]+ extendedLines = map ((\line -> take chars (line ++ repeat Nothing))+ . concatMap charList . T.unpack)+ lines+ in listArray gbounds (mconcat extendedLines)++-- | Information on, and extracted from, a body separator line. This is a line+-- that uses @=@ instead of @-@ to demark cell borders.+data PartSeparator = PartSeparator+ { partSepLine :: CharRow+ , partSepColSpec :: [ColSpec]+ }++-- | Alignment and character grid position of a column.+data ColSpec = ColSpec+ { colStart :: CharCol+ , colEnd :: CharCol+ , colAlign :: Alignment+ }++-- | Finds the row indices of all separator lines, i.e., lines that+-- contain only @+@ and @=@ characters.+findSeparators :: CharGrid -> [PartSeparator]+findSeparators charGrid = foldr go [] rowIdxs+ where+ gbounds = bounds charGrid+ rowIdxs = [fst (fst gbounds) .. fst (snd gbounds)]+ go i seps = case colSpecsInLine '=' charGrid i of+ Nothing -> seps+ Just colspecs -> PartSeparator i colspecs : seps++-- | Checks for a separator in the given line, returning the column properties+-- if it finds such a line.+colSpecsInLine :: Char -- ^ Character used in line (usually @-@)+ -> CharGrid -> CharRow -> Maybe [ColSpec]+colSpecsInLine c charGrid i =+ case charGrid ! (i, firstCol) of+ Just '+' -> loop [] (firstCol + 1)+ _ -> Nothing+ where+ loop acc j = case colSpecAt j of+ Nothing -> Nothing+ Just Nothing -> Just $ reverse acc+ Just (Just colspec) ->+ loop (colspec:acc) (colEnd colspec + 1)+ gbounds = bounds charGrid+ firstCol = snd (fst gbounds)+ lastCol = snd (snd gbounds)+ colSpecAt :: CharCol -> Maybe (Maybe ColSpec)+ colSpecAt j+ | j >= lastCol = Just Nothing+ | otherwise = case findEnd (j + 1) of+ Nothing -> Nothing+ Just (end, rightMark) ->+ let leftMark = charGrid ! (i, j) == Just ':'+ align = case (leftMark, rightMark) of+ (False , False) -> AlignDefault+ (True , False) -> AlignLeft+ (False , True ) -> AlignRight+ (True , True ) -> AlignCenter+ colspec = ColSpec+ { colStart = j+ , colEnd = end+ , colAlign = align+ }+ in pure (pure colspec)+ findEnd j = case charGrid ! (i, j) of+ Just '+' -> pure (j, False)+ Just ':' -> if charGrid ! (i, j + 1) == Just '+'+ then pure (j + 1, True)+ else Nothing+ Just c'+ | c' == c -> findEnd (j + 1)+ _ -> Nothing++-- | Returns new character grid in which the given lines have been+-- converted to normal cell-separating lines.+convertToNormalLines :: [CharRow] -> CharGrid -> CharGrid+convertToNormalLines sepLines charGrid = runSTArray $ do+ mutGrid <- thaw charGrid+ let gbounds = bounds charGrid+ cols = [snd (fst gbounds) .. snd (snd gbounds)]+ forM_ sepLines $ \rowidx -> do+ forM_ cols $ \colidx -> do+ let idx = (rowidx, colidx)+ c <- readArray mutGrid idx+ -- convert `=` to `-` and remove alignment markers+ case c of+ Just '=' -> writeArray mutGrid idx (Just '-')+ Just ':' -> writeArray mutGrid idx (Just '-')+ _ -> pure ()+ return mutGrid++-- | Info on the grid. Used to keep track of information collected while+-- tracing a character grid. The set of cells is used as a kind of queue+-- during parsing, while the other data is required to assemble the+-- final table.+data TraceInfo = TraceInfo+ { gridRowSeps :: Set CharRow+ , gridColSeps :: Set CharCol+ , gridCorners :: Set CharIndex+ , gridCells :: Set CellTrace+ }++-- | Initial tracing info.+initialTraceInfo :: TraceInfo+initialTraceInfo = TraceInfo+ { gridRowSeps = Set.fromList [CharRow 1]+ , gridColSeps = Set.fromList [CharCol 1]+ , gridCorners = Set.fromList [(CharRow 1, CharCol 1)]+ , gridCells = Set.fromList []+ }++-- | Trace the given char grid and collect all relevant info.+-- This function calls itself recursively.+traceCharGrid :: CharGrid+ -> TraceInfo+ -> TraceInfo+traceCharGrid charGrid traceInfo =+ -- Get the next corner an remove it from the set of unparsed corners.+ case Set.minView (gridCorners traceInfo) of+ Nothing -> traceInfo+ Just (startIdx@(top, left), corners) ->+ case traceCell charGrid startIdx of+ Nothing ->+ -- Corner is not a top-left corner of another cell. Continue+ -- with the remaining corners.+ traceCharGrid charGrid traceInfo { gridCorners = corners }+ Just ((bottom, right), newrowseps, newcolseps) -> do+ let content = getLines charGrid startIdx (bottom, right)+ let cell = CellTrace content left right top bottom+ let rowseps = gridRowSeps traceInfo+ let colseps = gridColSeps traceInfo+ let cells = gridCells traceInfo+ traceCharGrid charGrid $ TraceInfo+ { gridRowSeps = newrowseps `Set.union` rowseps+ , gridColSeps = newcolseps `Set.union` colseps+ , gridCorners = Set.insert (top, right) $+ Set.insert (bottom, left) corners+ , gridCells = cell `Set.insert` cells+ }++type ScanResult = (CharIndex, Set CharRow, Set CharCol)++type RowSeps = Set CharRow+type ColSeps = Set CharCol++-- | Traces a single cell on the grid, starting at the given position.+traceCell :: CharGrid -> CharIndex -> Maybe ScanResult+traceCell = scanRight++-- | Scans right from the given index, following a cell separator line+-- to the next column marker (@+@), then scans down. Returns the+-- bottom-right index of the cell if it can complete the trace, and+-- nothing if it reaches the end of line before the trace is complete.+--+-- All row and column markers found during scanning are seen are+-- collected and returned as part of the result.+scanRight :: CharGrid -> CharIndex -> Maybe ScanResult+scanRight charGrid start@(top, left) = do+ loop Set.empty (left + 1)+ where+ loop :: ColSeps -> CharCol -> Maybe ScanResult+ loop colseps j+ | not (bounds charGrid `inRange` (top, j)) = Nothing+ | otherwise = case charGrid ! (top, j) of+ Just '-' -> loop colseps (j + 1)+ Just '+' ->+ let colseps' = Set.insert j colseps+ in case scanDown charGrid start j of+ Nothing -> loop colseps' (j + 1)+ Just (end, rowseps, newcolseps) -> pure+ ( end+ , rowseps+ , colseps' `Set.union` newcolseps+ )+ _ -> Nothing++-- | Like 'scanRight', but scans down in the given column.+scanDown :: CharGrid+ -> CharIndex -- ^ top-left corner of cell+ -> CharCol -- ^ column of the cell's right border+ -> Maybe ScanResult+scanDown charGrid start@(top, _left) right = do+ loop Set.empty (top + 1)+ where+ loop :: RowSeps -> CharRow -> Maybe ScanResult+ loop rowseps i =+ if not (bounds charGrid `inRange` (i, right))+ then Nothing+ else case charGrid ! (i, right) of+ Just '+' ->+ let rowseps' = Set.insert i rowseps+ in case scanLeft charGrid start (i, right) of+ Nothing -> loop rowseps' (i + 1)+ Just (newrowseps, colseps) ->+ Just ( (i, right)+ , rowseps' `Set.union` newrowseps+ , colseps+ )+ Just '|' -> loop rowseps (i + 1)+ _ -> -- all but the final column must be terminated+ if right == snd (snd (bounds charGrid))+ then loop rowseps (i + 1)+ else Nothing++-- | Like 'scanRight', but scans left starting at the bottom-right+-- corner.+scanLeft :: CharGrid -> CharIndex -> CharIndex+ -> Maybe (RowSeps, ColSeps)+scanLeft charGrid start@(_top,left) end@(bottom, right) =+ let go :: CharCol -> Maybe ColSeps -> Maybe ColSeps+ go _ Nothing = Nothing+ go j (Just colseps) = case charGrid ! (bottom, j) of+ Just '+' -> Just (Set.insert j colseps)+ Just '-' -> Just colseps+ _ -> Nothing++ in if charGrid ! (bottom, left) /= Just '+'+ then Nothing+ else+ case foldr go (Just Set.empty) [(right - 1), right - 2 .. (left + 1)] of+ Nothing -> Nothing+ Just colseps ->+ case scanUp charGrid start end of+ Just rowseps -> Just (rowseps, colseps)+ Nothing -> Nothing++-- | Scans up from the bottom-left corner back to the top-left corner.+scanUp :: CharGrid -> CharIndex -> CharIndex+ -> Maybe RowSeps+scanUp charGrid (top, left) (bottom, _right) =+ let go :: CharRow -> Maybe RowSeps -> Maybe RowSeps+ go _ Nothing = Nothing+ go i (Just rowseps) = case charGrid ! (i, left) of+ Just '+' -> Just (Set.insert i rowseps)+ Just '|' -> Just rowseps+ _ -> Nothing+ in foldr go (Just Set.empty) [bottom - 1, bottom - 2 .. top + 1]++-- | Gets the textual contents, i.e. the lines of a cell.+getLines :: CharGrid -> CharIndex -> CharIndex -> [Text]+getLines charGrid (top, left) (bottom, right) =+ let rowIdxs = [top + 1 .. bottom - 1]+ colIdxs = [left + 1 .. right - 1]+ in map (\ir -> T.pack $ mapMaybe (\ic -> charGrid ! (ir, ic)) colIdxs)+ rowIdxs++-- | Traced cell with raw contents and border positions.+data CellTrace = CellTrace+ { cellTraceContent :: [Text]+ , cellTraceLeft :: CharCol+ , cellTraceRight :: CharCol+ , cellTraceTop :: CharRow+ , cellTraceBottom :: CharRow+ }+ deriving stock (Eq, Show)++instance Ord CellTrace where+ x `compare` y =+ case (compare `on` cellTraceTop) x y of+ EQ -> (compare `on` cellTraceLeft) x y+ o -> o++-- | Create a final grid table from line scanning data.+tableFromTraceInfo :: TraceInfo+ -> [PartSeparator]+ -> Maybe [ColSpec]+ -> ArrayTable [Text]+tableFromTraceInfo traceInfo partSeps colSpecsFirstLine =+ let rowseps = Set.toAscList $ gridRowSeps traceInfo+ colseps = Set.toAscList $ gridColSeps traceInfo+ rowindex = Map.fromList $ zip rowseps [1..]+ colindex = Map.fromList $ zip colseps [1..]+ colwidths = [ b - a - 1 | (b, a) <- zip (tail colseps) colseps ]+ colSpecs = zip+ (map colAlign+ (case partSeps of+ partSep:_ -> partSepColSpec partSep+ [] -> fromMaybe [] colSpecsFirstLine)+ ++ repeat AlignDefault)+ (map fromCharCol colwidths)+ lastCol = ColIndex (length colwidths)+ tableHead = subtract 1 <$>+ foldr ((<|>) . (`Map.lookup` rowindex) . partSepLine)+ Nothing+ partSeps+ in ArrayTable+ { arrayTableCells = runSTArray (toMutableArray traceInfo rowindex colindex)+ , arrayTableHead = tableHead+ , arrayTableColSpecs = listArray (1, lastCol) colSpecs+ }++-- | Create a mutable cell array from the scanning data.+toMutableArray :: TraceInfo+ -> Map.Map CharRow RowIndex+ -> Map.Map CharCol ColIndex+ -> ST s (STArray s CellIndex (GridCell [Text]))+toMutableArray traceInfo rowindex colindex = do+ let nrows = Map.size rowindex - 1+ let ncols = Map.size colindex - 1+ let gbounds = ( (RowIndex 1, ColIndex 1)+ , (RowIndex nrows, ColIndex ncols)+ )+ tblgrid <- newArray gbounds FreeCell+ forM_ (Set.toAscList $ gridCells traceInfo) $+ \(CellTrace content left right top bottom) -> do+ let cellPos = do+ rnum <- Map.lookup top rowindex+ cnum <- Map.lookup left colindex+ rs <- RowSpan . fromRowIndex . subtract rnum <$>+ Map.lookup bottom rowindex+ cs <- ColSpan . fromColIndex . subtract cnum <$>+ Map.lookup right colindex+ pure ((rnum, cnum), rs, cs)+ let (idx, rowspan, colspan) = case cellPos of+ Just cp -> cp+ Nothing -> error "A cell or row index was not found"+ writeArray tblgrid idx . FilledCell $+ ContentCell rowspan colspan content+ forM_ (continuationIndices idx rowspan colspan) $ \contIdx -> do+ -- FIXME: ensure that the cell has not been filled yet+ writeArray tblgrid contIdx $+ FilledCell (ContinuationCell idx)+ -- Swap BuilderCells with normal GridCells.+ let fromBuilderCell :: BuilderCell -> GridCell [Text]+ fromBuilderCell = \case+ FilledCell c -> c+ FreeCell -> error "Found an unassigned cell."+ getAssocs tblgrid >>= (\kvs -> forM_ kvs $ \(idx, bc) ->+ case bc of+ FreeCell -> error $ "unassigned: " ++ show idx+ _ -> pure ())+ mapArray fromBuilderCell tblgrid++-- | Calculate the array indices that are spanned by a cell.+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)]++-- | Helper type used to track which indices have been already been+-- filled in a mutable cell array.+data BuilderCell+ = FilledCell (GridCell [Text])+ | FreeCell
+ test/test-gridtables.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE FlexibleContexts #-}+{-|+Module : Main+Copyright : © 2022 Albert Krewinkel+License : MIT+Maintainer : Albert Krewinkel <albert+hslua@zeitkraut.de>++Tests for the gridtables library.+-}+module Main (main) where++import Data.Array (Array, listArray)+import Data.Functor.Identity (Identity)+import Data.Text (Text)+import Text.GridTable+import Text.GridTable.Parse (tableLine)+import Text.Parsec+import Test.Tasty (TestTree, defaultMain, testGroup)+import Test.Tasty.HUnit ((@?=), testCase)++import qualified Data.Text as T++main :: IO ()+main = defaultMain $ testGroup "gridtables"+ [ linesTests+ , gridTableTests+ ]++parse' :: ParsecT Text () Identity a -> Text -> Either ParseError a+parse' p t = runParser p () "<test input>" t++-- | Test parsing into lines+linesTests :: TestTree+linesTests = testGroup "lines"+ [ testCase "get lines" $+ parse' (many1 tableLine) "| one | two |\n| three |\n| four |\n"+ @?= Right ([ "| one | two |"+ , "| three |"+ , "| four |"+ ])++ , testCase "fail if not a table" $+ parse' (many tableLine) "nope\nnada\n" @?= Right []+ ]++-- | Test parsing of a text as grid tables.+gridTableTests :: TestTree+gridTableTests = testGroup "parseArrayTable"+ [ testCase "single cell" $+ let gt = T.unlines+ [ "+-----+"+ , "| one |"+ , "+-----+"+ ]+ gbounds = ( (RowIndex 1, ColIndex 1)+ , (RowIndex 1, ColIndex 1)+ )+ in parse' gridTable gt @?=+ Right (ArrayTable+ { arrayTableCells = listArray gbounds [ContentCell 1 1 [" one "]]+ , arrayTableHead = Nothing+ , arrayTableColSpecs = defaultAlign [5]+ })++ , testCase "multi-cell row" $+ let gt = T.unlines+ [ "+-----+-----+"+ , "| one | two |"+ , "+-----+-----+"+ ]+ gbounds = ( (RowIndex 1, ColIndex 1)+ , (RowIndex 1, ColIndex 2)+ )+ in parse' gridTable gt @?=+ Right (ArrayTable+ { arrayTableCells = listArray gbounds+ [ ContentCell 1 1 [" one "]+ , ContentCell 1 1 [" two "]+ ]+ , arrayTableHead = Nothing+ , arrayTableColSpecs = defaultAlign [5, 5]+ })+++ , testCase "wide character" $+ let gt = T.unlines+ [ "+----+------+"+ , "| 魚 | fish |"+ , "+----+------+"+ ]+ gbounds = ( (RowIndex 1, ColIndex 1)+ , (RowIndex 1, ColIndex 2)+ )+ in parse' gridTable gt @?=+ Right (ArrayTable+ { arrayTableCells = listArray gbounds+ [ ContentCell 1 1 [" 魚 "]+ , ContentCell 1 1 [" fish "]+ ]+ , arrayTableHead = Nothing+ , arrayTableColSpecs = defaultAlign [4, 6]+ })++ , testCase "two-row table" $+ let gt = T.unlines+ [ "+-----+"+ , "| one |"+ , "+-----+"+ , "| two |"+ , "+-----+"+ ]+ gbounds = ( (RowIndex 1, ColIndex 1)+ , (RowIndex 2, ColIndex 1)+ )+ in parse' gridTable gt @?=+ Right (ArrayTable+ { arrayTableCells = listArray gbounds+ [ ContentCell 1 1 [" one "]+ , ContentCell 1 1 [" two "]+ ]+ , arrayTableHead = Nothing+ , arrayTableColSpecs = defaultAlign [5]+ })++ , testCase "rowspan" $+ let gt = T.unlines+ [ "+-----+-------+"+ , "| one | two |"+ , "| +-------+"+ , "| | three |"+ , "+-----+-------+"+ ]+ gbounds = ( (RowIndex 1, ColIndex 1)+ , (RowIndex 2, ColIndex 2)+ )+ in parse' gridTable gt @?=+ Right (ArrayTable+ { arrayTableCells = listArray gbounds+ [ ContentCell 2 1 [" one ", " ", " "]+ , ContentCell 1 1 [" two "]+ , ContinuationCell (1, 1)+ , ContentCell 1 1 [" three "]+ ]+ , arrayTableHead = Nothing+ , arrayTableColSpecs = defaultAlign [5, 7]+ })++ , testGroup "table head"+ [ testCase "simple head" $+ let gt = T.unlines+ [ "+-----+-----+"+ , "| one | two |"+ , "+=====+=====+"+ , "| 1 | 2 |"+ , "+-----+-----+"+ ]+ gbounds = ( (RowIndex 1, ColIndex 1)+ , (RowIndex 2, ColIndex 2)+ )+ in parse' gridTable gt @?=+ Right (ArrayTable+ { arrayTableCells = listArray gbounds+ [ ContentCell 1 1 [" one "]+ , ContentCell 1 1 [" two "]+ , ContentCell 1 1 [" 1 "]+ , ContentCell 1 1 [" 2 "]+ ]+ , arrayTableHead = Just 1+ , arrayTableColSpecs = defaultAlign [5, 5]+ })++ , testCase "alignment markers" $+ let gt = T.unlines+ [ "+------+--------+-------+"+ , "| left | center | right |"+ , "+:=====+:======:+======:+"+ , "| 1 | 2 | 3 |"+ , "+------+--------+-------+"+ ]+ in parse' gridTable gt @?=+ Right (ArrayTable+ { arrayTableCells = listArray ((1,1), (2, 3))+ [ ContentCell 1 1 [" left "]+ , ContentCell 1 1 [" center "]+ , ContentCell 1 1 [" right "]+ , ContentCell 1 1 [" 1 "]+ , ContentCell 1 1 [" 2 "]+ , ContentCell 1 1 [" 3 "]+ ]+ , arrayTableHead = Just 1+ , arrayTableColSpecs = listArray (1, 3)+ [ (AlignLeft, 6)+ , (AlignCenter, 8)+ , (AlignRight, 7)+ ]+ })+ ]++ , testCase "marker in first line" $+ let gt = T.unlines+ [ "+:-----+:------:+------:+"+ , "| left | center | right |"+ , "+------+--------+-------+"+ , "| a 1 | b 2 | c 3 |"+ , "+------+--------+-------+"+ ]+ in parse' gridTable gt @?=+ Right (ArrayTable+ { arrayTableCells = listArray ((1,1), (2, 3))+ [ ContentCell 1 1 [" left "]+ , ContentCell 1 1 [" center "]+ , ContentCell 1 1 [" right "]+ , ContentCell 1 1 [" a 1 "]+ , ContentCell 1 1 [" b 2 "]+ , ContentCell 1 1 [" c 3 "]+ ]+ , arrayTableHead = Nothing+ , arrayTableColSpecs = listArray (1, 3)+ [ (AlignLeft, 6)+ , (AlignCenter, 8)+ , (AlignRight, 7)+ ]+ })++ , testCase "unterminated row" $+ let gt = T.unlines+ [ "+-----+"+ , "| one"+ , "+-----+"+ ]+ gbounds = ( (RowIndex 1, ColIndex 1)+ , (RowIndex 1, ColIndex 1)+ )+ in parse' gridTable gt @?=+ Right (ArrayTable+ { arrayTableCells = listArray gbounds+ [ ContentCell 1 1 [" one"]]+ , arrayTableHead = Nothing+ , arrayTableColSpecs = defaultAlign [5]+ })++ , testCase "trailing spaces" $+ let ls = T.unlines+ [ "+---+ "+ , "| 1 | "+ , "+---+"+ ]+ in parse' gridTable ls @?=+ Right (ArrayTable+ { arrayTableCells = listArray ((1,1), (1,1))+ [ ContentCell 1 1 [" 1 "]]+ , arrayTableHead = Nothing+ , arrayTableColSpecs = defaultAlign [3]+ })++ , testCase "followed by non-empty line" $+ let ls = T.unlines+ [ "+-----+"+ , "| one |"+ , "+-----+"+ , "text"+ ]+ in parse' (gridTable *> many1 letter) ls @?=+ Right "text"++ , testCase "followed by non-empty line after blank line" $+ let gt = T.unlines+ [ "+-----+"+ , "| one |"+ , "+-----+"+ , ""+ , "Hi Mom!"+ ]+ in parse' (gridTable *> newline *> many1 (letter <|> space)) gt @?=+ Right "Hi Mom"++ , testGroup "access functions"+ [ testCase "rows" $+ let gt = ArrayTable+ { arrayTableCells = listArray ((1, 1), (2, 2))+ [ ContentCell 2 1 "1"+ , ContentCell 1 1 "2"+ , ContinuationCell (1, 1)+ , ContentCell 1 1 "3"+ ]+ , arrayTableHead = Nothing+ , arrayTableColSpecs = defaultAlign [5, 7]+ } :: ArrayTable Text+ in rows gt @?= [ [Cell "1" 2 1, Cell "2" 1 1]+ , [Cell "3" 1 1]+ ]+ ]+ ]++defaultAlign :: [Int] -> Array ColIndex (Alignment, Int)+defaultAlign widths = listArray (1, ColIndex (length widths))+ $ map (\w -> (AlignDefault, w)) widths