packages feed

table-layout 0.9.1.0 → 1.0.0.0

raw patch · 29 files changed

+2381/−599 lines, 29 filesdep +doclayoutdep +textdep −data-default-instances-basedep ~QuickCheckdep ~basedep ~data-default-class

Dependencies added: doclayout, text

Dependencies removed: data-default-instances-base

Dependency ranges changed: QuickCheck, base, data-default-class

Files

CHANGELOG.md view
@@ -2,7 +2,48 @@  ## [Unreleased] -## [0.9.1.0] - 2020-12-21+## [1.0.0.0] - 2023-11-17++This release would not have been possible without the tireless work of Stephen+Morgan.++### Added++- Add `asciiDoubleS` table style.+- Add combinators for removing outer borders of tables.+- Provide general versions of grid and table functions that generate output for+  `StringBuilder` instances.+- Add dependency to `doclayout` and `text`.+- Add `WideString` and `WideText` to support multi-width character input. (#8)+- Custom vertical separators can now be specified in the table header+  specification in a hierarchic manner.+- Add simplified table style specification with `LineStyle` and many new+  combinators.+- Add `Cell` instance for `Data.Text`, `Data.Either`, `Data.Maybe`.+- Add versions of functions for tables and grids that return `ColModInfo`s.+- Provide functions to work with `Formatted`.+- Add safe versions of the `trim` function. (#35)+- Add `expandBetween` `LenSpec` which provides a lower and an upper bound for+  the width of a column. (#35)+- Add explicit defaults for data types (#26).+- Provide more functions to derive `ColModInfo`.+- Add `TableSpec` to specify tables.++### Changed++- Changed version bounds of `base`, `QuickCheck`, and `data-default-class`.+- Remove dependency on `data-default-instances-base`.+- Improve performance of Cell and StringBuilder instances+- Generalize `Formatted` to provide nested color formatting. (#11)+- Change `TableStyle` to use `String` as basic building blocks of tables. (#17)+- Add more separator types to `TableStyle`.+- Accept arbitrary instances of `Cell` as header titles.+- Lower requirements for `Cell` instances:  Cells no longer need to be able to+  drop characters.+- Drop `Monoid` requirement for vertical alignment.+- Rendering functions for tables now use `TableSpec`.+- Renamed functions to derive `ColModInfo`.+  ### Fixed
README.md view
@@ -16,14 +16,12 @@  ## Tutorial -### Grid layout+### Grids  Render some text rows as grid: ``` hs-> putStrLn $ gridString [column expand left def def, column expand right def def]-                        [ ["top left", "top right"]-                        , ["bottom left", "bottom right"]-                        ]+> let g = [["top left", "top right"], ["bottom left", "bottom right"]]+> putStrLn $ gridString [column expand left def def, column expand right def def] g ``` `gridString` will join cells with a whitespace and rows with a newline character. The result is not spectacular but does look as expected: ```@@ -32,7 +30,7 @@ ``` There are sensible default values for all column specification types, even for columns. We could have used just `def` for the first column. -### Number columns+### Number Columns  Additionally some common types are provided. A particularly useful one is `numCol`: ``` hs@@ -48,7 +46,7 @@ 5000.00001 ``` -### Improving readability of grids+### Improving Readability of Grids  Big grids are usually not that readable. To improve their readability, two functions are provided: @@ -58,22 +56,21 @@ A good way to use this would be the [ansi-terminal package][], provided you are using a terminal to output your text. Another way to introduce color into cells is the `Formatted` type: ``` > :set -XOverloadedStrings-> let red s = formatted "\ESC[31m" s "\ESC[0m"-> gridString [def, numCol] [["Jim", "1203"], ["Jane", "523"], ["Jack", red "-959000"]]+> import Text.Layout.Table.Cell.Formatted+> import System.Console.ANSI.Codes+> let red s = formatted (setSGRCode [SetColor Foreground Dull Red]) (plain s) (setSGRCode [Reset])+> let g = [["Jim", "1203"], ["Jane", "523"], ["Jack", red "-959000"]]+> putStrLn $ gridString [def, numCol] g ``` This way the color can depend on the cell content. -### Table layout+### Tables  For more complex data, grids do not offer as much visibility. Sometimes we want to explicitly display a table, for example, as output in a database application. `tableLines` and `tableString` are used to create a table.  ``` hs-putStrLn $ tableString [def , numCol]-                       unicodeRoundS-                       def-                       [ rowG ["Jack", "184.74"]-                       , rowG ["Jane", "162.2"]-                       ]+> let t = headerlessTableS [def , numCol] unicodeRoundS [rowG ["Jack", "184.74"], rowG ["Jane", "162.2"]]+> putStrLn $ tableString t ``` A row group is a group of rows which are not visually separated from each other. Thus multiple rows form one cell. @@ -86,17 +83,16 @@ ╰──────┴────────╯ ``` -### Table headers+### Table Headers  Optionally we can use table headers. `titlesH` will center titles, whereas `fullH` allows more control:  ``` hs-putStrLn $ tableString [fixedLeftCol 10, column (fixed 10) center dotAlign def]-                       unicodeS-                       (titlesH ["Text", "Number"])-                       [ rowG ["A very long text", "0.42000000"]-                       , rowG ["Short text", "100200.5"]-                       ]+> let cs = [fixedLeftCol 10, column (fixed 10) center dotAlign def]+> let h = (titlesH ["Text", "Number"])+> let rgs = [rowG ["A very long text", "0.42000000"], rowG ["Short text", "100200.5"]]+> let t = columnHeaderTableS cs unicodeS h rgs+> putStrLn $ tableString t ``` Headers are always displayed with a different style than the other columns (centered by default). A maximum column width is respected, otherwise a header may acquire additional space. ```@@ -109,16 +105,14 @@ └────────────┴────────────┘ ``` ### Vertical positioning and justified text-Because a row group consists of multiple lines, we may also want to align the content of cells vertically, especially when we don't know how many lines there will be. The following piece of code will display a left-justified text alongside the length of the text:+Because a row group consists of multiple lines, we may also want to align the content of cells vertically, especially when we do not know how many lines there will be.  The following piece of code will display a left-justified text alongside the length of the text: ``` hs-let txt = "Lorem ipsum ..." -in putStrLn $ tableString [fixedLeftCol 50, numCol]-                          asciiS-                          (titlesH ["Text", "Length"])-                          [ colsAllG center [ justifyText 50 txt-                                            , [show $ length txt]-                                            ]-                          ]+> let txt = "Lorem ipsum ..." +> let rgs = [colsAllG center [justifyText 50 txt, [show $ length txt]]]+> let cs = [fixedLeftCol 50, numCol]+> let h = titlesH ["Text", "Length"]+> let t = columnHeaderTableS cs asciiS h rgs+> putStrLn $ tableString t ``` `colsAllG` will merge the given columns into a row group with the given positioning: ```@@ -136,11 +130,11 @@ | officia deserunt mollit anim id est laborum.       |        | +----------------------------------------------------+--------+ ```-Additionally, the positioning can be specified for each column with `colsG`. For grids `colsAsRows` and `colsAsRowsAll` are provided.+Additionally, the positioning can be specified for each column with `colsG`.  For grids `colsAsRows` and `colsAsRowsAll` are provided. -## Get in contact+## Contact -* Report issues and suggestions to the GitHub page.+* Please report issues and suggestions to the GitHub page. * Any kind of feedback is welcome. * Contributions are much appreciated. Contact me first for bigger changes.
src/Test.hs view
@@ -2,43 +2,67 @@  import Text.Layout.Table +data MySeparator = BigSep | SmallSep | TinySep++inheritMyStyle :: TableStyle LineStyle LineStyle -> TableStyle LineStyle MySeparator+inheritMyStyle = inheritStyleHeaderGroup makeLineSolid id (fst . style) (snd . style)+  where+    style BigSep   = (HeavyLine,  HeavyLine)+    style SmallSep = (SingleLine, DashLine)+    style TinySep  = (SingleLine, NoLine)+ main :: IO ()-main = putStrLn $ tableString [ column (expandUntil 30) left (charAlign ':') def-                              , column expand center noAlign noCutMark-                              ]-                              unicodeRoundS-                              (titlesH ["Layout", "Result"])-                              rowGroups+main = putStrLn $ tableString $ columnHeaderTableS+                                [ column (expandUntil 30) left (charAlign ':') ellipsisCutMark+                                , column expand center noAlign noCutMark+                                ]+                                unicodeRoundS+                                (titlesH ["Layout", "Result"])+                                testRowGroups   where-    rowGroups    = flip concatMap styles $ \style ->+    testRowGroups = flip concatMap styles $ \style ->         flip map columTs $ \(cSpec, is) ->             colsAllG center [ is                             , genTable cSpec style                             ]-    genTable c s = tableLines (repeat c)-                              s-                              (titlesH ["Some text", "Some numbers", "X"])-                              [ rowsG [ [longText, smallNum, "foo"]-                                      , [shortText, bigNum, "bar"]-                                      ]-                              ]+    genTable c s = tableLines $ fullTableS+                                (repeat c)+                                s+                                (fullSepH DashLine (repeat $ headerColumn right Nothing) ["1", "Two"])+                                (groupH BigSep+                                    [ fullSepH SmallSep (repeat defHeaderColSpec) ["Some text", "Some numbers", "X"]+                                    , groupH SmallSep+                                        [ fullSepH TinySep (repeat defHeaderColSpec) ["Z", "W"]+                                        , fullSepH TinySep (repeat defHeaderColSpec) ["A", "B"]+                                        ]+                                    , fullSepH TinySep  (repeat defHeaderColSpec) ["Text", "Y"]+                                    ]+                                )+                                [ rowsG [ [longText, smallNum, "foo", "blah", "bloo", "blop", "blog", shortText, "baz"]+                                        , [shortText, bigNum, "bar", "yadda", "yoda", "yeeda", "york", shortText, "wibble"]+                                        ]+                                , rowsG [ [longText, smallNum, "foo", "bibbidy", "babbidy", "boo", "blue", shortText, "wobble" ]+                                        ]+                                ]     longText  = "This is long text"     shortText = "Short"     bigNum    = "200300400500600.2"     smallNum  = "4.20000000"-    styles    = [ asciiS-                , asciiRoundS-                , unicodeS-                , unicodeRoundS-                , unicodeBoldS-                , unicodeBoldStripedS-                , unicodeBoldHeaderS-                ]-    columTs   = [ ( column l p a def+    styles    = map inheritMyStyle+                    [ asciiS+                    , asciiRoundS+                    , unicodeS+                    , withoutBorders unicodeS+                    , unicodeRoundS+                    , unicodeBoldS+                    , unicodeBoldStripedS+                    , unicodeBoldHeaderS+                    ]+    columTs   = [ ( column l p a ellipsisCutMark                   , ["len spec: " ++ dL, "position: " ++ pL, "alignment: " ++ aL]                   )-                | (l, dL) <- zip [expand, fixed 10, expandUntil 10, fixedUntil 10]-                           ["expand", "fixed 10", "expand until 10", "fixed until 10"]+                | (l, dL) <- zip [expand, fixed 10, expandUntil 10, fixedUntil 10, expandBetween 5 15]+                           ["expand", "fixed 10", "expand until 10", "fixed until 10", "expand [5, 15]"]                 , (p, pL) <- zip [left, right, center] ["left", "right", "center"]                 , (a, aL) <- zip [noAlign, dotAlign] ["no align", "align at '.'"]                 ]
src/Text/Layout/Table.hs view
@@ -3,9 +3,11 @@ -- and length restriction it also provides advanced features like justifying -- text and fancy tables with styling support. ---{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} module Text.Layout.Table-    ( -- * Layout combinators+    ( -- * Column Layout       -- | Specify how a column is rendered with the combinators in this       -- section. Sensible default values are provided with 'def'. @@ -17,85 +19,129 @@     , numCol     , fixedCol     , fixedLeftCol-      -- ** Length of columns+    , defColSpec+      -- ** Length of Columns     , LenSpec     , expand     , fixed     , expandUntil     , fixedUntil-      -- ** Positional alignment+    , expandBetween+      -- ** Positional Alignment     , Position     , H     , left     , right     , center-      -- ** Alignment of cells at characters+    , beginning+      -- ** Alignment of Cells at Characters     , AlignSpec     , noAlign     , charAlign     , predAlign     , dotAlign-      -- ** Cut marks+      -- ** Cut Marks     , CutMark     , noCutMark     , singleCutMark     , doubleCutMark+    , ellipsisCutMark -      -- * Basic grid layout+      -- * Grids+      -- ** Rendering     , Row     , grid+    , gridB+    , gridBWithCMIs     , gridLines+    , gridLinesB     , gridString+    , gridStringB++      -- ** Concatenating     , concatRow     , concatLines     , concatGrid -      -- * Grid modification functions+      -- ** Modification Functions     , altLines     , checkeredCells -      -- * Table layout-      -- ** Grouping rows+      -- * Tables+      -- ** Grouping Rows+      -- | Rows in character-based tables are separated by separator lines.+      -- This section provides the tools to decide when this separation is+      -- happening.  Thus, several text rows may be in the same row of the+      -- table.     , RowGroup     , rowsG     , rowG++    -- *** Columns as Row Groups+    -- | [Text justification](#text) may be used to turn text into+    -- length-limited columns. Such columns may be turned into a 'RowGroup'+    -- with 'colsG' or 'colsAllG'.     , colsG     , colsAllG +      -- ** Specifying Tables+      -- | The most basic `TableSpec` may be constructed by using `simpleTableS`.+    , module Text.Layout.Table.Spec.TableSpec++      -- ** Rendering+      -- | Render a 'TableSpec'.+    , tableLines+    , tableLinesB+    , tableLinesBWithCMIs+    , tableString+    , tableStringB+       -- ** Headers     , HeaderColSpec     , headerColumn     , HeaderSpec+    , noneSepH+    , noneH+    , fullSepH     , fullH     , titlesH+    , groupH+    , headerH+    , defHeaderColSpec -      -- ** Layout-    , tableLines-    , tableString+      -- ** Styles+    , module Text.Layout.Table.Style+    , module Text.Layout.Table.LineStyle -      -- * Text justification-      -- $justify++      -- * Multi-Row Cell Rendering+      -- ** Text Justification+      -- | #text# Split text and turn it into a column.  Such columns may be+      -- combined with other columns.     , justify     , justifyText -      -- * Vertical column positioning+      -- ** Vertical Column Positioning+      -- | Turn rows of columns into a grid by aligning the columns.+    , V+    , top+    , bottom     , Col     , colsAsRowsAll     , colsAsRows-    , top-    , bottom-    , V -      -- * Table styles-    , module Text.Layout.Table.Style--      -- * Column modification functions+      -- * Custom Layout Generation+      -- ** Column Modification Functions     , pad+    , trim     , trimOrPad+    , trimOrPadBetween     , align     , alignFixed+    , buildCellMod+    , adjustCell -      -- * Column modifaction primitives+      -- ** Column Modifaction Primitives       -- | These functions are provided to be reused. For example if someone       -- wants to render their own kind of tables.     , ColModInfo@@ -106,24 +152,31 @@     , columnModifier     , AlignInfo     , widthAI-    , deriveColModInfos+    , deriveColModInfosFromGrid+    , deriveColModInfosFromColumns     , deriveAlignInfo     , OccSpec++      -- ** Table Headers+    , zipHeader+    , flattenHeader+    , headerContents     ) where  -- TODO AlignSpec:   multiple alignment points - useful?--- TODO RowGroup:    optional: vertical group labels -- TODO RowGroup:    optional: provide extra layout for a RowGroup -- TODO ColSpec:     add some kind of combinator to construct ColSpec values (e.g. via Monoid, see optparse-applicative) -import           Data.List+import           Data.Bifunctor import           Data.Default.Class-import           Data.Default.Instances.Base                 ()+import           Data.List+import           Data.Maybe+import           Data.Semigroup  import           Text.Layout.Table.Cell import           Text.Layout.Table.Justify+import           Text.Layout.Table.LineStyle import           Text.Layout.Table.Primitives.AlignInfo-import           Text.Layout.Table.Primitives.Basic import           Text.Layout.Table.Primitives.ColumnModifier import           Text.Layout.Table.Primitives.Header import           Text.Layout.Table.Primitives.Table@@ -136,6 +189,7 @@ import           Text.Layout.Table.Spec.OccSpec import           Text.Layout.Table.Spec.Position import           Text.Layout.Table.Spec.RowGroup+import           Text.Layout.Table.Spec.TableSpec import           Text.Layout.Table.Spec.Util import           Text.Layout.Table.StringBuilder import           Text.Layout.Table.Style@@ -152,11 +206,11 @@  -- | Numbers are positioned on the right and aligned on the floating point dot. numCol :: ColSpec-numCol = column def right dotAlign def+numCol = column expand right dotAlign ellipsisCutMark  -- | Fixes the column length and positions according to the given 'Position'. fixedCol :: Int -> Position H -> ColSpec-fixedCol l pS = column (fixed l) pS def def+fixedCol l pS = column (fixed l) pS noAlign ellipsisCutMark  -- | Fixes the column length and positions on the left. fixedLeftCol :: Int -> ColSpec@@ -167,17 +221,37 @@ -------------------------------------------------------------------------------  -- | Modifies cells according to the column specification.+gridB :: (Cell a, StringBuilder b) => [ColSpec] -> [Row a] -> [Row b]+gridB specs = fst . gridBWithCMIs specs++-- | Modifies cells according to the column specification, also returning the+-- 'ColModInfo' used to generate the grid.+gridBWithCMIs :: (Cell a, StringBuilder b) => [ColSpec] -> [Row a] -> ([Row b], [ColModInfo])+gridBWithCMIs specs tab = (zipWith4 columnModifier positions cms cMIs <$> tab, cMIs)+  where+    cMIs = deriveColModInfosFromGrid specs tab+    positions = map position specs+    cms = map cutMark specs++-- | A version of 'gridB' specialized to 'String'. grid :: Cell a => [ColSpec] -> [Row a] -> [Row String]-grid specs tab = zipWith ($) (deriveColMods specs tab) <$> tab+grid = gridB --- | Behaves like 'grid' but produces lines by joining with whitespace.+-- | A version of 'gridB' that joins the cells of a row with one space.+gridLinesB :: (Cell a, StringBuilder b) => [ColSpec] -> [Row a] -> [b]+gridLinesB specs = fmap (concatRow 1). gridB specs++-- | A version of 'gridLinesB' specialized to 'String'. gridLines :: Cell a => [ColSpec] -> [Row a] -> [String]-gridLines specs = fmap unwords . grid specs+gridLines = gridLinesB --- | Behaves like 'gridLines' but produces a string by joining with the newline--- character.+-- | A version of 'gridLinesB' that also concatenates the lines.+gridStringB :: (Cell a, StringBuilder b) => [ColSpec] -> [Row a] -> b+gridStringB specs = concatLines . gridLinesB specs++-- | A version of 'gridStringB' specialized to 'String'. gridString :: Cell a => [ColSpec] -> [Row a] -> String-gridString specs = concatLines . gridLines specs+gridString = gridStringB  concatLines :: StringBuilder b => [b] -> b concatLines = mconcat . intersperse (charB '\n')@@ -190,6 +264,8 @@     -> b concatRow n bs = mconcat $ intersperse (replicateCharB n ' ') bs +-- | Concatenates a whole grid with the given amount of horizontal spaces+-- between columns. concatGrid :: StringBuilder b => Int -> [Row b] -> b concatGrid n = concatLines . fmap (concatRow n) @@ -214,90 +290,184 @@  -- | Create a 'RowGroup' by aligning the columns vertically. The position is -- specified for each column.-colsG :: Monoid a => [Position V] -> [Col a] -> RowGroup a-colsG ps = rowsG . colsAsRows ps+colsG :: [Position V] -> [Col a] -> RowGroup a+colsG ps = nullableRowsG . colsAsRows ps  -- | Create a 'RowGroup' by aligning the columns vertically. Each column uses--- the same vertical positioning.-colsAllG :: Monoid a => Position V -> [Col a] -> RowGroup a-colsAllG p = rowsG . colsAsRowsAll p+-- the same position.+colsAllG :: Position V -> [Col a] -> RowGroup a+colsAllG p = nullableRowsG . colsAsRowsAll p --- | Layouts a pretty table with an optional header. Note that providing fewer--- layout specifications than columns or vice versa will result in not showing--- the redundant ones.-tableLines :: Cell a-           => [ColSpec]  -- ^ Layout specification of columns-           -> TableStyle -- ^ Visual table style-           -> HeaderSpec -- ^ Optional header details-           -> [RowGroup a] -- ^ Rows which form a cell together-           -> [String]-tableLines specs TableStyle { .. } header rowGroups =-    topLine : addHeaderLines (rowGroupLines ++ [bottomLine])+-- | Renders a table as 'StringBuilder' lines. Note that providing fewer layout+-- specifications than columns or vice versa will result in not showing the+-- redundant ones.+tableLinesB :: (Cell a, Cell r, Cell c, StringBuilder b)+            => TableSpec rowSep colSep r c a+            -> [b]+tableLinesB = fst . tableLinesBWithCMIs++-- | Renders a table as 'StringBuilder' lines, providing the 'ColModInfo' for+-- each column. Note that providing fewer layout specifications than columns or+-- vice versa will result in not showing the redundant ones.+tableLinesBWithCMIs :: forall rowSep r colSep c a b.+                       (Cell a, Cell r, Cell c, StringBuilder b)+                    => TableSpec rowSep colSep r c a+                    -> ([b], [ColModInfo])+tableLinesBWithCMIs TableSpec { tableStyle = TableStyle { .. }, ..  } =+    ( maybe id (:) optTopLine . addColHeader $ maybe id (\b -> (++[b])) optBottomLine rowGroupLines+    , cMIs+    )   where-    -- Helpers for horizontal lines that will put layout characters arround and+    -- Helpers for horizontal lines that will put layout characters around and     -- in between a row of the pre-formatted grid. -    -- | Generate columns filled with 'sym'.-    fakeColumns sym-                  = map (`replicateCharB` sym) colWidths+    -- | Generate columns filled with 'sym', or blank spaces if 'sym' is of width 0.+    -- If there is a rowHeader, keep that separate.+    fakeColumns :: String -> String -> (Maybe b, Row b)+    fakeColumns headerSym groupSym =+        (replicateSym headerSym . widthCMI <$> rowHeaderCMI, map (replicateSym groupSym) colWidths)+      where+        replicateSym sym w = stimesMonoid q (stringB sym') <> stringB (take r sym')+          where+            (q, r) = w `quotRem` l+            (sym', l) = let l' = length sym in if l' == 0 then (" ", 1) else (sym, l') -    -- Horizontal seperator lines that occur in a table.-    topLine       = hLineDetail realTopH realTopL realTopC realTopR $ fakeColumns realTopH-    bottomLine    = hLineDetail groupBottomH groupBottomL groupBottomC groupBottomR $ fakeColumns groupBottomH-    groupSepLine  = hLineDetail groupSepH groupSepLC groupSepC groupSepRC $ fakeColumns groupSepH-    headerSepLine = hLineDetail headerSepH headerSepLC headerSepC headerSepRC $ fakeColumns headerSepH+    -- | Replace the content of a 'HeaderSpec' with the content of the rows or columns to be rendered,+    -- and flatten to a list of content interspersed with column/row separators. If given 'NoneHS', first+    -- replace it with the shape of the data.+    flattenWithContent (NoneHS sep) contentShape r = flattenHeader . fmap fst . zipHeader mempty r $ fullSepH sep (repeat defHeaderColSpec) contentShape+    flattenWithContent h            _            r = flattenHeader . fmap fst $ zipHeader mempty r h +    -- | Intersperse a row with its rendered separators.+    withRowSeparators :: (rowSep -> Maybe b) -> [Row b] -> [Either (Maybe b) (Row b)]+    withRowSeparators renderDelimiter = map (first renderDelimiter) . flattenWithContent rowHeader rowGroups++    -- | Intersperse a column with its rendered separators, including an optional row header.+    withColSeparators :: (colSep -> String) -> (Maybe b, Row b) -> (Maybe b, Row (Either String b))+    withColSeparators renderDelimiter = second renderRow+      where+        renderRow = map (first renderIfDrawn) . flattenWithContent colHeader columns+        columns = maybe [] rowGroupShape $ listToMaybe rowGroups+        -- Render the delimiters of a column if it is drawn, otherwise return an empty string.+        renderIfDrawn x+            -- If no delimiters are drawn in this column, return the empty string+            | null headerV && null groupV = ""+            -- If this delimiter is not drawn, but others in the column are, pad with spaces+            | null separator              = replicate (max (visibleLength headerV) (visibleLength groupV)) ' '+            -- Otherwise, just render the delimiter+            | otherwise                   = separator+          where+            separator = renderDelimiter x+            headerV   = headerC x+            groupV    = groupC  x++    -- Draw a line using the specified delimiters, but only if the horizontal string is non-null+    optDrawLine horizontal rowSep leftD rightD headerSepD colSepD = if null horizontal && null rowSep+        then Nothing+        else Just . horizontalDetailLine horizontal rowSep leftD rightD headerSepD . withColSeparators colSepD $ fakeColumns rowSep horizontal+    -- Horizontal separator lines that occur in a table.+    optTopLine        = optDrawLine realTopH realRowHeaderT realTopL realTopR bothHeadersTR realTopC+    optBottomLine     = optDrawLine groupBottomH rowHeaderB realGroupBottomL groupBottomR rowHeaderSepBC groupBottomC+    optGroupSepLine s = optDrawLine (groupSepH s) (rowHeaderC s) (realGroupSepLC s) (groupSepRC s) (rowHeaderSepC s s) (groupSepC s)+    optHeaderSepLine  = optDrawLine headerSepH bothHeadersB realHeaderSepLC headerSepRC bothHeadersBR (\x -> headerSepC x x)+     -- Vertical content lines-    rowGroupLines =-        intercalate [groupSepLine] $ map (map (hLineContent groupV) . applyRowMods . rows) rowGroups+    rowGroupLines = concatRowGroups $ withRowSeparators optGroupSepLine linesPerRowGroup+    concatRowGroups = concatMap (either (maybe [] pure) id)+    linesPerRowGroup = map rowGroupToLines $ addRowHeader rowGroups+    rowGroupToLines :: (Maybe (HeaderColSpec, r), RowGroup a) -> [b]+    rowGroupToLines = map (horizontalContentLine realLeftV groupR rowHeaderSepV . withColSeparators groupC) . applyRowMods -    -- Optional values for the header-    (addHeaderLines, fitHeaderIntoCMIs, realTopH, realTopL, realTopC, realTopR)-                  = case header of-        HeaderHS headerColSpecs hTitles-               ->-            let headerLine    = hLineContent headerV (zipWith ($) headerRowMods hTitles)-                headerRowMods = zipWith3 headerCellModifier-                                         headerColSpecs-                                         cMSs-                                         cMIs-            in-            ( (headerLine :) . (headerSepLine :)-            , fitTitlesCMI hTitles posSpecs-            , headerTopH+    -- Optional values for the row header+    (addRowHeader, rowHeaderCMI, realLeftV, realHeaderTopL, realHeaderSepLC, realGroupSepLC, realGroupBottomL)+                  = case rowHeader of+        NoneHS _ ->+            ( map (Nothing,)+            , Nothing+            , groupL             , headerTopL-            , headerTopC-            , headerTopR+            , headerSepLC+            , groupSepLC+            , groupBottomL             )-        NoneHS ->+        _ ->+            let attachRowHeader grps = map (\(hSpec, (grp, r)) -> (Just (hSpec, r), grp))+                                     . headerContents $ zipHeader (rowG []) grps rowHeader+                singleColCMI = Just . deriveColModInfoFromColumnLA (expand, noAlign)+            in+            ( attachRowHeader+            , singleColCMI . map snd $ headerContents rowHeader+            , rowHeaderLeftV+            , bothHeadersTL+            , bothHeadersBL+            , rowHeaderLeftC+            , rowHeaderLeftB+            )++    -- Optional values for the column header+    (addColHeader, fitHeaderIntoCMIs, realTopH, realTopL, realTopC, realTopR, realRowHeaderT)+                  = case colHeader of+        NoneHS _ ->             ( id             , id             , groupTopH             , groupTopL             , groupTopC             , groupTopR+            , rowHeaderT             )+        _ ->+            let headerLine = horizontalContentLine headerL headerR bothHeadersR $ withColSeparators headerC+                               (emptyFromCMI <$> rowHeaderCMI, headerRowMods hTitles)+                headerRowMods = zipWith4 headerCellModifier+                                         headerColSpecs+                                         cMSs+                                         cMIs+                (headerColSpecs, hTitles) = unzip $ headerContents colHeader+            in+            ( (headerLine :) . maybe id (:) optHeaderSepLine+            , fitTitlesCMI hTitles posSpecs+            , headerTopH+            , realHeaderTopL+            , headerTopC+            , headerTopR+            , bothHeadersT+            ) -    cMSs          = map cutMark specs-    posSpecs      = map position specs-    applyRowMods  = map (zipWith ($) rowMods)-    rowMods       = zipWith3 columnModifier posSpecs cMSs cMIs-    cMIs          = fitHeaderIntoCMIs $ deriveColModInfos' specs $ concatMap rows rowGroups-    colWidths     = map widthCMI cMIs+    emptyFromCMI = spacesB . widthCMI --- | Does the same as 'tableLines', but concatenates lines.-tableString :: Cell a-            => [ColSpec]  -- ^ Layout specification of columns-            -> TableStyle -- ^ Visual table style-            -> HeaderSpec -- ^ Optional header details-            -> [RowGroup a] -- ^ Rows which form a cell together-            -> String-tableString specs style header rowGroups = concatLines $ tableLines specs style header rowGroups+    cMSs      = map cutMark colSpecs+    posSpecs  = map position colSpecs+    cMIs      = fitHeaderIntoCMIs $ deriveColModInfosFromColumns colSpecs $ transposeRowGroups rowGroups+    rowMods   = zipWith3 (\p cm cmi -> (emptyFromCMI cmi, columnModifier p cm cmi)) posSpecs cMSs cMIs ----------------------------------------------------------------------------------- Text justification--------------------------------------------------------------------------------+    rowBody :: RowGroup a -> [[b]]+    rowBody   = mapRowGroupColumns rowMods+    colWidths = map widthCMI cMIs --- $justify--- Text can easily be justified and distributed over multiple lines. Such--- columns can be combined with other columns.+    -- Apply modifiers to rows, adding row headers to the first row in the group if needed+    applyRowMods  :: (Maybe (HeaderColSpec, r), RowGroup a) -> [(Maybe b, [b])]+    applyRowMods (Just (hSpec, r), grp) | Just rCMI <- rowHeaderCMI+        = zip (header rCMI) (rowBody grp)+      where+        header cMI = fmap Just $ headerCellModifier hSpec noCutMark cMI r : repeat (emptyFromCMI cMI)+    applyRowMods (_, grp) = map (Nothing,) $ rowBody grp++-- | A version of 'tableLinesB' specialized to 'String'.+tableLines :: (Cell a, Cell r, Cell c)+           => TableSpec rowSep colSep r c a+           -> [String]+tableLines = tableLinesB++-- | A version of 'tableLinesB' that also concatenates the lines.+tableStringB :: (Cell a, Cell r, Cell c, StringBuilder b)+             => TableSpec rowSep colSep r c a+             -> b+tableStringB = concatLines . tableLinesB++-- | A version of 'tableStringB' specialized to 'String'.+tableString :: (Cell a, Cell r, Cell c)+            => TableSpec rowSep colSep r c a+            -> String+tableString = tableStringB+
src/Text/Layout/Table/Cell.hs view
@@ -1,47 +1,123 @@+{-# LANGUAGE DeriveFunctor     #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards   #-}+ module Text.Layout.Table.Cell where +import Control.Monad (join)+import qualified Data.Text as T+ import Text.Layout.Table.Primitives.AlignInfo+import Text.Layout.Table.Primitives.CellMod import Text.Layout.Table.Spec.CutMark import Text.Layout.Table.Spec.OccSpec import Text.Layout.Table.Spec.Position import Text.Layout.Table.StringBuilder --- | Types that can be shortened, measured for visible characters, and turned--- into a 'StringBuilder'.-class Cell a where-    -- Preprocessing functions:+-- | Ensure a value is not negative.+truncateNegative :: Int -> Int+truncateNegative = max 0 -    -- | Drop a number of characters from the left side. Treats negative numbers-    -- as zero.-    dropLeft :: Int -> a -> a-    dropLeft n = dropBoth n 0+-- | An object along with the amount that its length should be adjusted on both the left and right.+-- Positive numbers are padding and negative numbers are trimming.+data CellView a =+    CellView+    { baseCell :: a+    , leftAdjustment :: Int+    , rightAdjustment :: Int+    } deriving (Eq, Ord, Show, Functor) -    -- | Drop a number of characters from the right side. Treats negative-    -- numbers as zero.-    dropRight :: Int -> a -> a-    dropRight = dropBoth 0+-- | Add an adjustment to the left and right of a 'Cell'.+-- Positive numbers are padding and negative numbers are trimming.+adjustCell :: Int -> Int -> a -> CellView a+adjustCell l r a = CellView a l r -    -- | Drop characters from both sides. Treats negative numbers as zero.-    dropBoth :: Int -> Int -> a -> a-    dropBoth l r = dropRight r . dropLeft l+-- | Drop a number of characters from the left side. Treats negative numbers+-- as zero.+dropLeft :: Int -> a -> CellView a+dropLeft n = dropBoth n 0 +-- | Drop a number of characters from the right side. Treats negative+-- numbers as zero.+dropRight :: Int -> a -> CellView a+dropRight = dropBoth 0++-- | Drop characters from both sides. Treats negative numbers as zero.+dropBoth :: Int -> Int -> a -> CellView a+dropBoth l r = adjustCell (negate $ truncateNegative l) (negate $ truncateNegative r)++instance Applicative CellView where+  pure x = CellView x 0 0+  (CellView f l r) <*> (CellView x l' r') = CellView (f x) (l + l') (r + r')++instance Monad CellView where+  (CellView x l r) >>= f = let CellView y l' r' = f x in CellView y (l + l') (r + r')++-- | The total amount of adjustment in 'CellView'.+totalAdjustment :: CellView a -> Int+totalAdjustment a = leftAdjustment a + rightAdjustment a++-- | Redistribute padding or trimming using a given ratio.+redistributeAdjustment :: Int -> Int -> CellView a -> CellView a+redistributeAdjustment l r a = CellView (baseCell a) lAdjustment rAdjustment+  where+    lAdjustment = (totalAdjustment a * l) `div` (l + r)+    rAdjustment = totalAdjustment a - lAdjustment++-- | Types that can be measured for visible characters, define a sub-string+-- operation and turned into a 'StringBuilder'.+class Cell a where     -- | Returns the length of the visible characters as displayed on the     -- output medium.     visibleLength :: a -> Int -    -- | Measure the preceeding and following characters for a position where+    -- | Measure the preceding and following characters for a position where     -- the predicate matches.     measureAlignment :: (Char -> Bool) -> a -> AlignInfo      -- | Insert the contents into a 'StringBuilder'.     buildCell :: StringBuilder b => a -> b+    buildCell = buildCellView . pure -    {-# MINIMAL visibleLength, measureAlignment, buildCell, (dropBoth | (dropLeft, dropRight))  #-}+    -- | Insert the contents into a 'StringBuilder', padding or trimming as+    -- necessary.+    --+    -- The 'Cell' instance of 'CellView a' means that this can usually be+    -- substituted with 'buildCell', and is only needed for defining the+    -- instance.+    buildCellView :: StringBuilder b => CellView a -> b +    {-# MINIMAL visibleLength, measureAlignment, buildCellView #-}++instance Cell a => Cell (CellView a) where+    visibleLength (CellView a l r) = visibleLength a + l + r+    measureAlignment f (CellView a l r) = case mMatchRemaining of+        -- No match+        Nothing -> AlignInfo (truncateNegative $ matchAt + l + r) Nothing+        -- There is a match, but it is cut off from the left or right+        Just matchRemaining | matchAt < -l || matchRemaining < -r -> AlignInfo (truncateNegative $ matchAt + matchRemaining + 1 + l + r) Nothing+        -- There is a match, and it is not cut off+        Just matchRemaining -> AlignInfo (matchAt + l) (Just $ matchRemaining + r)+      where+        AlignInfo matchAt mMatchRemaining = measureAlignment f a+    buildCell = buildCellView+    buildCellView = buildCellView . join++instance Cell a => Cell (Maybe a) where+    visibleLength = maybe 0 visibleLength+    measureAlignment p = maybe mempty (measureAlignment p)+    buildCell = maybe mempty buildCell+    buildCellView (CellView a l r) = maybe (spacesB $ l + r) (buildCellView . adjustCell l r) a++instance (Cell a, Cell b) => Cell (Either a b) where+    visibleLength = either visibleLength visibleLength+    measureAlignment p = either (measureAlignment p) (measureAlignment p)+    buildCell = either buildCell buildCell+    buildCellView (CellView a l r) = either go go a+      where+        go x = buildCellView $ CellView x l r+ instance Cell String where-    dropLeft = drop-    dropRight n = reverse . drop n . reverse     visibleLength = length     measureAlignment p xs = case break p xs of         (ls, rs) -> AlignInfo (length ls) $ case rs of@@ -49,89 +125,221 @@             _ : rs' -> Just $ length rs'      buildCell = stringB+    buildCellView = buildCellViewLRHelper stringB drop (\n s -> zipWith const s $ drop n s) -remSpacesB :: (Cell a, StringBuilder b) => Int -> a -> b-remSpacesB n c = remSpacesB' n $ visibleLength c+instance Cell T.Text where+    visibleLength = T.length+    measureAlignment p xs = case T.break p xs of+        (ls, rs) -> AlignInfo (T.length ls) $ if T.null rs+            then Nothing+            else Just $ T.length rs - 1 -remSpacesB' :: StringBuilder b => Int -> Int -> b-remSpacesB' n k = spacesB $ n - k+    buildCell = textB+    buildCellView = buildCellViewLRHelper textB T.drop T.dropEnd +-- | Construct 'buildCellView' from a builder function, a function for+-- trimming from the left, and a function for trimming from the right.+--+-- Used to define instances of 'Cell'.+buildCellViewLRHelper :: StringBuilder b+                      => (a -> b)  -- ^ Builder function for 'a'.+                      -> (Int -> a -> a)  -- ^ Function for trimming on the left.+                      -> (Int -> a -> a)  -- ^ Function for trimming on the right.+                      -> CellView a+                      -> b+buildCellViewLRHelper build trimL trimR =+    buildCellViewHelper build (\i -> build . trimL i) (\i -> build . trimR i) (\l r -> build . trimL l . trimR r)++-- | Construct 'buildCellView' from a builder function, and a function for+-- trimming from the left and right simultaneously.+--+-- Used to define instanced of 'Cell'.+buildCellViewBothHelper+    :: StringBuilder b+    => (a -> b)  -- ^ Builder function for 'a'.+    -> (Int -> Int -> a -> a)  -- ^ Function for trimming on the left and right simultaneously.+    -> CellView a+    -> b+buildCellViewBothHelper build trimBoth =+    buildCellViewHelper build (\i -> build . trimBoth i 0) (\i -> build . trimBoth 0 i) (\l r -> build . trimBoth l r)++-- | Construct 'buildCellView' from builder functions and trimming functions.+--+-- Used to define instances of 'Cell'.+buildCellViewHelper+    :: StringBuilder b+    => (a -> b)  -- ^ Builder function for 'a'.+    -> (Int -> a -> b)  -- ^ Function for trimming on the left.+    -> (Int -> a -> b)  -- ^ Function for trimming on the right.+    -> (Int -> Int -> a -> b)  -- ^ Function for trimming on the left and right simultaneously.+    -> CellView a+    -> b+buildCellViewHelper build trimL trimR trimBoth (CellView a l r) =+    case (compare l 0, compare r 0) of+        (GT, GT) -> spacesB l <> build a <> spacesB r+        (GT, LT) -> spacesB l <> trimR (negate r) a+        (GT, EQ) -> spacesB l <> build a+        (LT, GT) -> trimL (negate l) a <> spacesB r+        (LT, LT) -> trimBoth (negate l) (negate r) a+        (LT, EQ) -> trimL (negate l) a+        (EQ, GT) -> build a <> spacesB r+        (EQ, LT) -> trimR (negate r) a+        (EQ, EQ) -> build a++-- | Creates a 'StringBuilder' with the amount of missing spaces.+remSpacesB+    :: (Cell a, StringBuilder b)+    => Int -- ^ The expected length.+    -> a -- ^ A cell.+    -> b+remSpacesB n c = remSpacesB' n $ visibleLength c+ -- | Fill the right side with spaces if necessary.-fillRight :: (Cell a, StringBuilder b) => Int -> a -> b-fillRight n c = buildCell c <> remSpacesB n c+fillRight :: Cell a => Int -> a -> CellMod a+fillRight n c = fillRight' n (visibleLength c) c +-- | Fill the right side with spaces if necessary. Preconditions that are+-- required to be met (otherwise the function will produce garbage):+--+-- prop> visibleLength c == k+fillRight' :: Cell a => Int -> Int -> a -> CellMod a+fillRight' n k = padCellRight (truncateNegative $ n - k)+ -- | Fill both sides with spaces if necessary.-fillCenter :: (Cell a, StringBuilder b) => Int -> a -> b-fillCenter n c = spacesB q <> buildCell c <> spacesB (q + r)+fillCenter :: Cell a => Int -> a -> CellMod a+fillCenter n c = fillCenter' n (visibleLength c) c++-- | Fill both sides with spaces if necessary. Preconditions that are+-- required to be met (otherwise the function will produce garbage):+--+-- prop> visibleLength c == k+fillCenter' :: Cell a => Int -> Int -> a -> CellMod a+fillCenter' n k = padCell q (q + r)   where-    missing = n - visibleLength c+    missing = n - k     (q, r)  = missing `divMod` 2  -- | Fill the left side with spaces if necessary.-fillLeft :: (Cell a, StringBuilder b) => Int -> a -> b-fillLeft n c = remSpacesB n c <> buildCell c+fillLeft :: Cell a => Int -> a -> CellMod a+fillLeft n c = fillLeft' n (visibleLength c) c --- | Assume the given length is greater or equal than the length of the cell--- passed. Pads the given cell accordingly using the position specification.+-- | Fill the left side with spaces if necessary. Preconditions that are+-- required to be met (otherwise the function will produce garbage): ----- >>> pad left 10 "foo" :: String+-- prop> visibleLength c == k+fillLeft' :: Cell a => Int -> Int -> a -> CellMod a+fillLeft' n k = padCellLeft (truncateNegative $ n - k)++-- | Pads the given cell accordingly using the position specification.+--+-- >>> buildCellMod noCutMark $ pad left 10 "foo" :: String -- "foo       "+pad :: Cell a => Position o -> Int -> a -> CellMod a+pad p n c = pad' p n (visibleLength c) c++-- | Pads the given cell accordingly using the position specification.+-- Preconditions that are required to be met (otherwise the function will+-- produce garbage): ---pad :: (Cell a, StringBuilder b) => Position o -> Int -> a -> b-pad p = case p of-    Start  -> fillRight-    Center -> fillCenter-    End    -> fillLeft+-- prop> visibleLength c == k+pad' :: Cell a => Position o -> Int -> Int -> a -> CellMod a+pad' p n k = case p of+    Start  -> fillRight' n k+    Center -> fillCenter' n k+    End    -> fillLeft' n k  -- | If the given text is too long, the 'String' will be shortened according to -- the position specification. Adds cut marks to indicate that the column has -- been trimmed in length, otherwise it behaves like 'pad'. ----- >>> trimOrPad left (singleCutMark "..") 10 "A longer text." :: String+-- >>> let cm = singleCutMark ".."+-- >>> buildCellMod cm $ trimOrPad left cm 10 "A longer text." :: String -- "A longer.." ---trimOrPad :: (Cell a, StringBuilder b) => Position o -> CutMark -> Int -> a -> b-trimOrPad p cm n c = case compare (visibleLength c) n of-    LT -> pad p n c-    EQ -> buildCell c-    GT -> trim p cm n c+trimOrPad :: Cell a => Position o -> CutMark -> Int -> a -> CellMod a+trimOrPad p cutMark n c = case compare k n of+    LT -> pad' p n k c+    EQ -> keepCell c+    GT -> trim' p cutMark n k c+  where+    k = visibleLength c --- | Trim a cell based on the position. Preconditions that require to be met--- (otherwise the function will produce garbage):+-- | If the given text is too long, it will be trimmed to length `upper`+-- according to the position specification, and cut marks will be added to+-- indicate that the column has been trimmed in length. Otherwise, if+-- the given text is too short, it will be padded to length `lower`.+--+-- >>> let cm = singleCutMark ".."+-- >>> buildCellMod cm $ trimOrPadBetween left cm 7 10 "A longer text." :: String+-- "A longer.."+-- >>> buildCellMod cm $ trimOrPadBetween left cm 7 10 "Short" :: String+-- "Short  "+-- >>> buildCellMod cm $ trimOrPadBetween left cm 7 10 "A medium" :: String+-- "A medium"+--+-- Preconditions that are required to be met (otherwise the output will be+-- counterintuitive):+--+-- prop> lower <= upper+trimOrPadBetween+    :: Cell a+    => Position o+    -> CutMark+    -> Int  -- ^ The length `lower` to pad to if too short+    -> Int  -- ^ The length `upper` to trim to if too long+    -> a+    -> CellMod a+trimOrPadBetween p cutMark lower upper c+    | k > lower = trim' p cutMark upper k c+    | k < upper = pad' p lower k c+    | otherwise = keepCell c+  where+    k = visibleLength c++-- | Trim a cell based on the position. Cut marks may be trimmed if necessary.+trim :: Cell a => Position o -> CutMark -> Int -> a -> CellMod a+trim p cutMark n c = if k <= n then keepCell c else trim' p cutMark n k c+  where+    k = visibleLength c++-- | Trim a cell based on the position. Cut marks may be trimmed if necessary.+--+-- Preconditions that are required to be met (otherwise the function will produce garbage):+-- -- prop> visibleLength c > n-trim :: (Cell a, StringBuilder b) => Position o -> CutMark -> Int -> a -> b-trim p cm n c = case p of-    Start  -> buildCell (dropRight (cutLen + rightLen) c) <> buildCell (rightMark cm)+-- prop> visibleLength c == k+trim' :: Cell a => Position o -> CutMark -> Int -> Int -> a -> CellMod a+trim' p cutMark n k = case p of+    Start  -> trimCellRight (cutLen + rightLen) (min n rightLen)     Center -> case cutLen `divMod` 2 of-        (0, 1) -> buildCell (leftMark cm) <> buildCell (dropLeft (1 + leftLen) c)-        (q, r) -> if n > leftLen + rightLen-                  then buildCell (leftMark cm) <> buildCell (dropBoth (leftLen + q + r) (rightLen + q) c)-                       <> buildCell (rightMark cm)+        (0, 1) -> trimCellLeft (1 + leftLen) n+        (q, r) -> if n >= leftLen + rightLen+                  -- Both cutmarks fit.+                  then trimCell (leftLen + q + r) (rightLen + q) leftLen rightLen                   else case n `divMod` 2 of-                      (qn, rn) -> buildCell (take qn $ leftMark cm)-                                  <> buildCell (drop (rightLen - qn - rn) $ rightMark cm)-    End    -> buildCell (leftMark cm) <> buildCell (dropLeft (leftLen + cutLen) c)+                    (qn, rn) -> trimCell k 0 qn (qn + rn)+    End    -> trimCellLeft (leftLen + cutLen) (min n leftLen)   where-    leftLen = length $ leftMark cm-    rightLen = length $ rightMark cm+    leftLen = length $ leftMark cutMark+    rightLen = length $ rightMark cutMark -    cutLen = visibleLength c - n+    cutLen = k - n  -- | Align a cell by first locating the position to align with and then padding -- on both sides. If no such position is found, it will align it such that it -- gets aligned before that position. -- -- >>> let { os = predOccSpec (== '.') ; ai = deriveAlignInfo os "iiii.fff" }--- >>> in align os ai <$> ["1.5", "30", ".25"] :: [String]+-- >>> in buildCellMod noCutMark . align os ai <$> ["1.5", "30", ".25"] :: [String] -- ["   1.5  ","  30    ","    .25 "] -- -- This function assumes that the given 'String' fits the 'AlignInfo'. Thus: -- -- prop> ai <> deriveAlignInfo s = ai ---align :: (Cell a, StringBuilder b) => OccSpec -> AlignInfo -> a -> b+align :: Cell a => OccSpec -> AlignInfo -> a -> CellMod a align oS (AlignInfo ln optRN) c = case measureAlignment (predicate oS) c of-    AlignInfo lk optRK -> remSpacesB' ln lk <> buildCell c <> remSpacesB' (maybe 0 succ optRN) (maybe 0 succ optRK)+    AlignInfo lk optRK -> padCell (truncateNegative $ ln - lk) (truncateNegative $ maybe 0 succ optRN - maybe 0 succ optRK) c  data CutAction     = FillCA Int@@ -171,52 +379,57 @@  -- | If the amount to be cut is bigger than the cell length then any missing -- amount is taken away from any remaining padding.-spacesAfterCut :: StringBuilder b => CutAction -> Int -> Int -> b-spacesAfterCut ca cellLen cutAmount = spacesB $ s + min r 0+numSpacesAfterCut :: CutAction -> Int -> Int -> Int+numSpacesAfterCut ca cellLen cutAmount = s + min r 0   where     s = surplusSpace ca     r = cellLen - cutAmount  applyCutInfo-    :: (Cell a, StringBuilder b)+    :: Cell a     => CutInfo     -> CutMark     -> Int     -> Int     -> a-    -> b-applyCutInfo ci cm availSpace cellLen c = case ci of+    -> CellMod a+applyCutInfo ci cutMark availSpace cellLen = case ci of     -- The cuts might interfere with each other. Properly distribute available     -- length between both cut marks.     SidesCI (CutCA lCut) (CutCA rCut) ->         let (q, r) = availSpace `divMod` 2-        in applyLeftMark q-           <> buildCell (dropBoth (lCut + leftLen) (rCut + rightLen) c)-           <> applyRightMark (q + r)+        in modifyCellWithCutMarkLen (negate $ lCut + leftLen)+                                    (negate $ rCut + rightLen)+                                    q+                                    (q + r)     -- The left cut might need some of the right padding.     SidesCI (CutCA lCut) rCA          ->-        applyLeftMark availSpace-        <> buildCell (dropLeft (lCut + leftLen) c)-        <> spacesAfterCut rCA cellLen (lCut + leftLen)+        modifyCellWithCutMarkLen (negate $ lCut + leftLen)+                                 (numSpacesAfterCut rCA cellLen $ lCut + leftLen)+                                 availSpace+                                 0     -- The right cut might need some of the left padding.     SidesCI lCA (CutCA rCut)          ->-        spacesAfterCut lCA cellLen (rCut + rightLen)-        <> buildCell (dropRight (rCut + rightLen) c)-        <> applyRightMark availSpace+        modifyCellWithCutMarkLen (numSpacesAfterCut lCA cellLen $ rCut + rightLen)+                                 (negate $ rCut + rightLen)+                                 0+                                 availSpace     -- Filtered out all cuts at this point.     SidesCI lCA rCA                   ->-        let spacesB' = spacesB . surplusSpace-        in spacesB' lCA <> buildCell c <> spacesB' rCA+        padCell (surplusSpace lCA) (surplusSpace rCA)     MarkRightCI                       ->-        spacesB (max 0 $ availSpace - rightLen) <> applyRightMark availSpace+        modifyCellWithCutMarkLen (truncateNegative $ availSpace - rightLen)+                                 (negate cellLen)+                                 0+                                 (min availSpace rightLen)     MarkLeftCI                        ->-        applyLeftMark availSpace <> spacesB (max 0 $ availSpace - leftLen)+        modifyCellWithCutMarkLen (negate cellLen)+                                 (truncateNegative $ availSpace - leftLen)+                                 (min availSpace leftLen)+                                 0   where-    leftLen = length $ leftMark cm-    rightLen = length $ rightMark cm--    applyLeftMark k  = buildCell $ take k $ leftMark cm-    applyRightMark k = buildCell $ drop (rightLen - k) $ rightMark cm+    leftLen = length $ leftMark cutMark+    rightLen = length $ rightMark cutMark  -- | Given a position, the available width, and the length of an alignment -- (left and right side, separator is implied) compute a range for the view.@@ -241,19 +454,36 @@ -- | Aligns a cell using a fixed width, fitting it to the width by either -- filling or cutting while respecting the alignment. alignFixed-    :: (Cell a, StringBuilder b)+    :: Cell a     => Position o     -> CutMark     -> Int     -> OccSpec     -> AlignInfo     -> a-    -> b-alignFixed p cm n oS (AlignInfo lMax optRMax) c = case optRMax of-    Nothing   -> trimOrPad p cm n c+    -> CellMod a+alignFixed p cutMark n oS (AlignInfo lMax optRMax) c = case optRMax of+    Nothing   -> trimOrPad p cutMark n c     Just rMax -> let (vl, vr)            = viewRange p n lMax rMax                      (cl, cr)            = cellRange lMax $ measureAlignment (predicate oS) c                      cutInfo             = determineCuts vl vr cl cr                      cellLen             = cr - cl-                 in applyCutInfo cutInfo cm n cellLen c+                 in applyCutInfo cutInfo cutMark n cellLen c++-- | Interpret 'CellMod' to create a builder.+buildCellMod+    :: (Cell c, StringBuilder s)+    => CutMark+    -> CellMod c+    -> s+buildCellMod cutMark CellMod {..} =+    -- 'buildCellView' takes care of padding and trimming.+    applyMarkOrEmpty applyLeftMark leftCutMarkLenCM+    <> buildCellView (CellView baseCellCM leftAdjustmentCM rightAdjustmentCM)+    <> applyMarkOrEmpty applyRightMark rightCutMarkLenCM+  where+    applyMarkOrEmpty applyMark k = if k > 0 then applyMark k else mempty++    applyLeftMark k  = stringB $ take k $ leftMark cutMark+    applyRightMark k = stringB . reverse . take k . reverse $ rightMark cutMark
src/Text/Layout/Table/Cell/Formatted.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE LambdaCase        #-}+ -- | Provides formatting to an instance of 'Cell'. For example, in a unix -- terminal one could use the following: --@@ -6,46 +8,106 @@ -- Hello World! -- -- The text then appears in dull red.+--+-- More complex nested formatting can be achieved by using the `Monoid`+-- instance. module Text.Layout.Table.Cell.Formatted     ( Formatted-    , formatted     , plain+    , formatted+    , mapAffix+    , cataFormatted     ) where +import Data.List (foldl', mapAccumL, mapAccumR) import Data.String +import Text.Layout.Table.Primitives.AlignInfo import Text.Layout.Table.Cell import Text.Layout.Table.StringBuilder  data Formatted a-    = Formatted-    { prefix :: String-    , content :: a-    , suffix :: String-    } deriving Functor+    = Empty+    | Concat [Formatted a]+    | Plain a+    | Format String (Formatted a) String+  deriving (Eq, Show, Functor, Foldable, Traversable)  -- | Create a value from content that is kept plain without any formatting. plain :: a -> Formatted a-plain x = Formatted "" x ""+plain = Plain  -- | Create a formatted value with formatting directives that are applied to -- the whole value. The actual formatting has to be done by the backend. formatted     :: String -- ^ Prefix text directives for formatting.-    -> a -- ^ The content to be formatted.+    -> Formatted a -- ^ The content to be formatted.     -> String -- ^ Suffix text directives for formatting.     -> Formatted a-formatted = Formatted+formatted = Format +-- | Map over the formatting directives of a formatted value.+mapAffix :: (String -> String)  -- ^ Function to operate on prefix text directives.+         -> (String -> String)  -- ^ Function to operate on suffix text directives.+         -> Formatted a  -- ^ The formatted value to operate on.+         -> Formatted a+mapAffix preF sufF = cataFormatted Empty Concat Plain (\p x s -> Format (preF p) x (sufF s))++-- | Process a formatted value to produce an arbitrary value.+-- This is the catamorphism for 'Formatted'.+cataFormatted :: b  -- ^ Value of 'Empty'.+              -> ([b] -> b)  -- ^ Function for operating over 'Concat'.+              -> (a -> b)  -- ^ Function for operating over 'Plain'.+              -> (String -> b -> String -> b)  -- ^ Function for operating over 'Format'.+              -> Formatted a+              -> b+cataFormatted emptyF concatF plainF formatF = \case+    Empty        -> emptyF+    Concat xs    -> concatF $ map cataFormatted' xs+    Plain x      -> plainF x+    Format p x s -> formatF p (cataFormatted' x) s+  where+    cataFormatted' = cataFormatted emptyF concatF plainF formatF+ instance IsString a => IsString (Formatted a) where     fromString = plain . fromString +instance Semigroup (Formatted a) where+    Empty <> b     = b+    a     <> Empty = a+    a <> b = Concat $ elements a ++ elements b+      where+        elements (Concat es) = es+        elements e = [e]++instance Monoid (Formatted a) where+    mempty = Empty+ instance Cell a => Cell (Formatted a) where-    dropLeft i = fmap $ dropLeft i-    dropRight i = fmap $ dropRight i-    dropBoth l r = fmap $ dropBoth l r-    visibleLength = visibleLength . content-    measureAlignment p = measureAlignment p . content+    visibleLength = sum . fmap visibleLength+    measureAlignment p = foldl' (mergeAlign p) mempty+    buildCell = buildFormatted buildCell+    buildCellView = buildCellViewHelper+        (buildFormatted buildCell)+        (\i -> buildFormatted buildCell . trimLeft i)+        (\i -> buildFormatted buildCell . trimRight i)+        (\l r -> buildFormatted buildCell . trimLeft l . trimRight r)+      where+        trimLeft i = snd . mapAccumL (dropTrackRemaining dropLeft) i+        trimRight i = snd . mapAccumR (dropTrackRemaining dropRight) i -    -- | Surrounds the content with the directives.-    buildCell h = stringB (prefix h) <> buildCell (content h) <> stringB (suffix h)+-- | Build 'Formatted' using a given constructor.+buildFormatted :: StringBuilder b => (a -> b) -> Formatted a -> b+buildFormatted build = cataFormatted mempty mconcat build (\p a s -> stringB p <> a <> stringB s)++-- | Drop characters either from the right or left, while also tracking the+-- remaining number of characters to drop.+dropTrackRemaining :: Cell a => (Int -> a -> CellView a) -> Int -> a -> (Int, CellView a)+dropTrackRemaining dropF i a+  | i <= 0    = (0, pure a)+  | otherwise = let l = visibleLength a in (max 0 $ i - l, dropF i a)++-- | Run 'measureAlignment' with an initial state, as though we were measuring the alignment in chunks.+mergeAlign :: Cell a => (Char -> Bool) -> AlignInfo -> a -> AlignInfo+mergeAlign _ (AlignInfo l (Just r)) x = AlignInfo l (Just $ r + visibleLength x)+mergeAlign p (AlignInfo l Nothing)  x = let AlignInfo l' r = measureAlignment p x in AlignInfo (l + l') r
+ src/Text/Layout/Table/Cell/WideString.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE MultiWayIf                 #-}+{-# LANGUAGE OverloadedStrings          #-}+module Text.Layout.Table.Cell.WideString+    ( WideString(..)+    , WideText(..)+    ) where++import Data.String+import qualified Data.Text as T+import Text.DocLayout++import Text.Layout.Table.Cell+import Text.Layout.Table.Primitives.AlignInfo++-- | A newtype for String in which characters can be wider than one space.+newtype WideString = WideString String+    deriving (Eq, Ord, Show, Read, Semigroup, Monoid, IsString)++instance Cell WideString where+    visibleLength (WideString s) = realLength s+    measureAlignment p (WideString s) = measureAlignmentWide p s+    buildCell (WideString s) = buildCell s+    buildCellView = buildCellViewLRHelper+      (\(WideString s) -> buildCell s)+      (\i (WideString s) -> WideString $ dropWide True i s)+      (\i (WideString s) -> WideString . reverse . dropWide False i $ reverse s)++-- | Drop characters from the left side of a 'String' until at least the+-- provided width has been removed.+--+-- The provided `Bool` determines whether to continue dropping zero-width+-- characters after the requested width has been dropped.+dropWide :: Bool -> Int -> String -> String+dropWide _ _ [] = []+dropWide gobbleZeroWidth i l@(x : xs)+    | gobbleZeroWidth && i == 0 && charLen == 0 = dropWide gobbleZeroWidth i xs+    | i <= 0       = l+    | charLen <= i = dropWide gobbleZeroWidth (i - charLen) xs+    | otherwise    = replicate (charLen - i) ' ' ++ dropWide gobbleZeroWidth 0 xs+  where+    charLen = charWidth x++measureAlignmentWide :: (Char -> Bool) -> String -> AlignInfo+measureAlignmentWide p xs = case break p xs of+    (ls, rs) -> AlignInfo (realLength ls) $ case rs of+        []      -> Nothing+        _ : rs' -> Just $ realLength rs'++-- | A newtype for Text in which characters can be wider than one space.+newtype WideText = WideText T.Text+    deriving (Eq, Ord, Show, Read, Semigroup, Monoid, IsString)++instance Cell WideText where+    visibleLength (WideText s) = realLength s+    measureAlignment p (WideText s) = measureAlignmentWideT p s+    buildCell (WideText s) = buildCell s+    buildCellView = buildCellViewLRHelper+        (\(WideText s) -> buildCell s)+        (\i (WideText s) -> WideText $ dropLeftWideT i s)+        (\i (WideText s) -> WideText $ dropRightWideT i s)++dropLeftWideT :: Int -> T.Text -> T.Text+dropLeftWideT i txt = case T.uncons txt of+    Nothing -> txt+    Just (x, xs) -> let l = charWidth x in if+        | i == 0 && l == 0 -> dropLeftWideT i xs+        | i <= 0    -> txt+        | l <= i    -> dropLeftWideT (i - l) xs+        | otherwise -> T.replicate (l - i) " " <> dropLeftWideT 0 xs++dropRightWideT :: Int -> T.Text -> T.Text+dropRightWideT i txt = case T.unsnoc txt of+    Nothing -> txt+    Just (xs, x) -> let l = charWidth x in if+        | i <= 0    -> txt+        | l <= i    -> dropRightWideT (i - l) xs+        | otherwise -> xs <> T.replicate (l - i) " "++measureAlignmentWideT :: (Char -> Bool) -> T.Text -> AlignInfo+measureAlignmentWideT p xs = case T.break p xs of+    (ls, rs) -> AlignInfo (realLength ls) $ if T.null rs+        then Nothing+        else Just . realLength $ T.drop 1 rs
+ src/Text/Layout/Table/LineStyle.hs view
@@ -0,0 +1,399 @@+module Text.Layout.Table.LineStyle+    ( -- * Line Styling+      LineStyle(..)+    , makeLineBold+    , makeLineLight+    , makeLineDashed+    , makeLineSolid++      -- * ASCII Lines and Joins+    , asciiHorizontal+    , asciiVertical+    , asciiJoinString+    , asciiJoinString4+    , roundedAsciiJoinString+    , roundedAsciiJoinString4++      -- * Unicode Lines and Joins+    , unicodeHorizontal+    , unicodeVertical+    , unicodeJoinString+    , unicodeJoinString4+    ) where++import Data.Default.Class++-- | The line styles supported by the Unicode Box-Drawing block.+data LineStyle+    = NoLine          -- ^ No lines in both orientations.+    | SingleLine      -- ^ @─@ and @│@.+    | HeavyLine       -- ^ @━@ and @┃@.+    | DoubleLine      -- ^ @═@ and @║@.+    | DashLine        -- ^ @┄@ and @┆@.+    | HeavyDashLine   -- ^ @┅@ and @┇@.+    | Dash4Line       -- ^ @┈@ and @┊@.+    | HeavyDash4Line  -- ^ @┉@ and @┋@.+    | Dash2Line       -- ^ @╌@ and @╎@.+    | HeavyDash2Line  -- ^ @╍@ and @╏@.+  deriving (Eq)++instance Default LineStyle where+    -- | A single line.+    def = SingleLine++-- | Make a 'LineStyle' bold.+makeLineBold :: LineStyle -> LineStyle+makeLineBold SingleLine = HeavyLine+makeLineBold DashLine   = HeavyDashLine+makeLineBold Dash4Line  = HeavyDash4Line+makeLineBold Dash2Line  = HeavyDash2Line+makeLineBold x          = x++-- | Make a 'LineStyle' unbolded.+makeLineLight :: LineStyle -> LineStyle+makeLineLight HeavyLine      = SingleLine+makeLineLight HeavyDashLine  = DashLine+makeLineLight HeavyDash4Line = Dash4Line+makeLineLight HeavyDash2Line = Dash2Line+makeLineLight x              = x++-- | Make a 'LineStyle' dashed.+makeLineDashed :: LineStyle -> LineStyle+makeLineDashed SingleLine = DashLine+makeLineDashed HeavyLine  = HeavyDashLine+makeLineDashed x          = x++-- | Make a 'LineStyle' solid.+makeLineSolid :: LineStyle -> LineStyle+makeLineSolid DashLine       = SingleLine+makeLineSolid Dash4Line      = SingleLine+makeLineSolid Dash2Line      = SingleLine+makeLineSolid HeavyDashLine  = HeavyLine+makeLineSolid HeavyDash4Line = HeavyLine+makeLineSolid HeavyDash2Line = HeavyLine+makeLineSolid x              = x++-- | Join styles supported by the Unicode Box-Drawing block.+data UnicodeJoin = NoJoin | Light | Heavy | Double++-- | The 'UnicodeJoin' associated to each 'LineStyle'.+joinType :: LineStyle -> UnicodeJoin+joinType NoLine          = NoJoin+joinType SingleLine      = Light+joinType DashLine        = Light+joinType Dash4Line       = Light+joinType Dash2Line       = Light+joinType HeavyLine       = Heavy+joinType HeavyDashLine   = Heavy+joinType HeavyDash4Line  = Heavy+joinType HeavyDash2Line  = Heavy+joinType DoubleLine      = Double+++-- | ASCII representations for horizontal lines.+asciiHorizontal :: LineStyle -> String+asciiHorizontal NoLine     = ""+asciiHorizontal DoubleLine = "="+asciiHorizontal _          = "-"++-- | ASCII representations for vertical lines.+asciiVertical :: LineStyle -> String+asciiVertical NoLine     = ""+asciiVertical DoubleLine = "||"+asciiVertical _          = "|"++-- | ASCII representations for joins using pluses.+asciiJoinString :: LineStyle -> LineStyle -> String+asciiJoinString h v = asciiJoinString4 h h v v++-- | ASCII representations for joins using rounded joins.+roundedAsciiJoinString :: LineStyle -> LineStyle -> String+roundedAsciiJoinString h v = roundedAsciiJoinString4 h h v v++-- | ASCII interior joins, allowing the lines to change when passing through the vertex.+-- Uses pluses for joins. The argument order is west, east, north, then south.+asciiJoinString4 :: LineStyle -> LineStyle -> LineStyle -> LineStyle -> String+asciiJoinString4 NoLine NoLine NoLine NoLine          = " "+asciiJoinString4 NoLine NoLine n      s      | n == s = asciiVertical n+asciiJoinString4 w      e      NoLine NoLine | w == e = asciiHorizontal w+asciiJoinString4 w      e      n      s               = aJoins w e n s++-- | ASCII interior joins, allowing the lines to change when passing through the vertex.+-- Uses rounded joins. The argument order is west, east, north, then south.+roundedAsciiJoinString4 :: LineStyle -> LineStyle -> LineStyle -> LineStyle -> String+roundedAsciiJoinString4 NoLine NoLine NoLine NoLine          = " "+roundedAsciiJoinString4 NoLine NoLine n      s      | n == s = asciiVertical n+roundedAsciiJoinString4 w      e      NoLine NoLine | w == e = asciiHorizontal w+roundedAsciiJoinString4 w      e      n      s               = arJoins w e n s++-- | Draw ASCII line joins with pluses. Arguments are in the order west, east,+-- north, south.+--+-- Only 'NoLine', 'SingleLine', and 'DoubleLine' are supported by ASCII. Other+-- line styles are treated as 'SingleLine'.+aJoins :: LineStyle -> LineStyle -> LineStyle -> LineStyle -> String+aJoins _ _ DoubleLine _          = "++"+aJoins _ _ _          DoubleLine = "++"+aJoins _ _ _          _          = "+"++-- | Draw ASCII line joins with rounded joins. Arguments are in order west,+-- east, north, south.+--+-- Only 'NoLine', 'SingleLine', and 'DoubleLine' are supported by ASCII. Other+-- line styles are treated as 'SingleLine'.+arJoins :: LineStyle -> LineStyle -> LineStyle -> LineStyle -> String+-- Top joins+arJoins _          _          NoLine     DoubleLine = ".."+arJoins _          _          NoLine     _          = "."+-- Bottom joins+arJoins _          _          DoubleLine NoLine     = "''"+arJoins _          _          _          NoLine     = "'"+-- T-joins+arJoins NoLine     _          SingleLine SingleLine = ":"+arJoins _          NoLine     SingleLine SingleLine = ":"+arJoins NoLine     _          DoubleLine DoubleLine = "::"+arJoins _          NoLine     DoubleLine DoubleLine = "::"+-- Left joins+arJoins NoLine     DoubleLine DoubleLine _          = "::"+arJoins NoLine     DoubleLine _          _          = ":"+arJoins NoLine     SingleLine DoubleLine _          = "++"+arJoins NoLine     SingleLine _          _          = "+"+-- Right joins+arJoins DoubleLine NoLine     DoubleLine _          = "::"+arJoins DoubleLine NoLine     _          _          = ":"+arJoins SingleLine NoLine     DoubleLine _          = "++"+arJoins SingleLine NoLine     _          _          = "+"+-- Interior joins+arJoins DoubleLine _          DoubleLine _          = "::"+arJoins DoubleLine _          _          _          = ":"+arJoins _          _          DoubleLine _          = "++"+arJoins _          _          _          _          = "+"+++-- | Unicode representations for horizontal lines.+unicodeHorizontal :: LineStyle -> String+unicodeHorizontal NoLine         = ""+unicodeHorizontal SingleLine     = "─"+unicodeHorizontal HeavyLine      = "━"+unicodeHorizontal DoubleLine     = "═"+unicodeHorizontal DashLine       = "┄"+unicodeHorizontal HeavyDashLine  = "┅"+unicodeHorizontal Dash4Line      = "┈"+unicodeHorizontal HeavyDash4Line = "┉"+unicodeHorizontal Dash2Line      = "╌"+unicodeHorizontal HeavyDash2Line = "╍"++-- | Unicode representations for vertical lines.+unicodeVertical :: LineStyle -> String+unicodeVertical NoLine         = ""+unicodeVertical SingleLine     = "│"+unicodeVertical HeavyLine      = "┃"+unicodeVertical DoubleLine     = "║"+unicodeVertical DashLine       = "┆"+unicodeVertical HeavyDashLine  = "┇"+unicodeVertical Dash4Line      = "┊"+unicodeVertical HeavyDash4Line = "┋"+unicodeVertical Dash2Line      = "╎"+unicodeVertical HeavyDash2Line = "╏"++-- | Unicode interior joins, specifying the horizontal and vertical lines.+unicodeJoinString :: LineStyle -> LineStyle -> String+unicodeJoinString h v = unicodeJoinString4 h h v v++-- | Unicode interior joins, allowing the lines to change when passing through the vertex.+unicodeJoinString4+    :: LineStyle -- ^ 'LineStyle' of the line coming from the west.+    -> LineStyle -- ^ 'LineStyle' of the line coming from the east.+    -> LineStyle -- ^ 'LineStyle' of the line coming from the north.+    -> LineStyle -- ^ 'LineStyle' of the line coming from the south.+    -> String+unicodeJoinString4 NoLine NoLine NoLine NoLine          = " "+unicodeJoinString4 NoLine NoLine n      s      | n == s = unicodeVertical n+unicodeJoinString4 w      e      NoLine NoLine | w == e = unicodeHorizontal w+unicodeJoinString4 w      e      n      s               = pure $ uJoins (joinType w) (joinType e) (joinType n) (joinType s)++-- | Find the Unicode box-drawing character which joins lines of given weights.+-- Arguments are in order west, east, north, south.+--+-- Not all joins are fully supported by Unicode, and in these cases we try to+-- gracefully substitute a similar character.+-- - Any join consisting solely of 'NoJoin', 'Light, and 'Heavy' is fully supported.+-- - Most joins consisting solely of 'NoJoin', 'Light, and 'Double' are supported.+--   For those that aren't, we substitute 'Heavy' for 'Double'.+-- - Any join which has both 'Heavy' and 'Double' is unsupported, and we+--   substitute 'Heavy' for 'Double'.+uJoins :: UnicodeJoin -> UnicodeJoin -> UnicodeJoin -> UnicodeJoin -> Char+-- All NoJoin, 1 case+uJoins NoJoin NoJoin NoJoin NoJoin = ' '+-- Using NoJoin and Light, 15 cases+uJoins NoJoin NoJoin Light  Light  = '│'+uJoins Light  Light  NoJoin NoJoin = '─'+uJoins Light  Light  Light  Light  = '┼'+uJoins NoJoin NoJoin NoJoin Light  = '╷'+uJoins NoJoin NoJoin Light  NoJoin = '╵'+uJoins NoJoin Light  NoJoin NoJoin = '╶'+uJoins Light  NoJoin NoJoin NoJoin = '╴'+uJoins NoJoin Light  NoJoin Light  = '┌'+uJoins NoJoin Light  Light  NoJoin = '└'+uJoins Light  NoJoin NoJoin Light  = '┐'+uJoins Light  NoJoin Light  NoJoin = '┘'+uJoins NoJoin Light  Light  Light  = '├'+uJoins Light  NoJoin Light  Light  = '┤'+uJoins Light  Light  NoJoin Light  = '┬'+uJoins Light  Light  Light  NoJoin = '┴'+-- Using NoJoin and Heavy, 15 cases+uJoins NoJoin NoJoin Heavy  Heavy  = '┃'+uJoins Heavy  Heavy  NoJoin NoJoin = '━'+uJoins Heavy  Heavy  Heavy  Heavy  = '╋'+uJoins NoJoin NoJoin NoJoin Heavy  = '╻'+uJoins NoJoin NoJoin Heavy  NoJoin = '╹'+uJoins NoJoin Heavy  NoJoin NoJoin = '╺'+uJoins Heavy  NoJoin NoJoin NoJoin = '╸'+uJoins NoJoin Heavy  NoJoin Heavy  = '┏'+uJoins NoJoin Heavy  Heavy  NoJoin = '┗'+uJoins Heavy  NoJoin NoJoin Heavy  = '┓'+uJoins Heavy  NoJoin Heavy  NoJoin = '┛'+uJoins NoJoin Heavy  Heavy  Heavy  = '┣'+uJoins Heavy  NoJoin Heavy  Heavy  = '┫'+uJoins Heavy  Heavy  NoJoin Heavy  = '┳'+uJoins Heavy  Heavy  Heavy  NoJoin = '┻'+-- Using NoJoin and Light with two Heavy, 18 cases+uJoins NoJoin Light  Heavy  Heavy  = '┠'+uJoins Light  NoJoin Heavy  Heavy  = '┨'+uJoins Light  Light  Heavy  Heavy  = '╂'+uJoins Heavy  Heavy  NoJoin Light  = '┯'+uJoins Heavy  Heavy  Light  NoJoin = '┷'+uJoins Heavy  Heavy  Light  Light  = '┿'+uJoins NoJoin Heavy  Light  Heavy  = '┢'+uJoins Light  Heavy  NoJoin Heavy  = '┲'+uJoins Light  Heavy  Light  Heavy  = '╆'+uJoins NoJoin Heavy  Heavy  Light  = '┡'+uJoins Light  Heavy  Heavy  NoJoin = '┺'+uJoins Light  Heavy  Heavy  Light  = '╄'+uJoins Heavy  NoJoin Light  Heavy  = '┪'+uJoins Heavy  Light  NoJoin Heavy  = '┱'+uJoins Heavy  Light  Light  Heavy  = '╅'+uJoins Heavy  NoJoin Heavy  Light  = '┩'+uJoins Heavy  Light  Heavy  NoJoin = '┹'+uJoins Heavy  Light  Heavy  Light  = '╃'+-- Using NoJoin and Light with southward Heavy, 7 cases+uJoins NoJoin NoJoin Light  Heavy  = '╽'+uJoins NoJoin Light  NoJoin Heavy  = '┎'+uJoins NoJoin Light  Light  Heavy  = '┟'+uJoins Light  NoJoin NoJoin Heavy  = '┒'+uJoins Light  NoJoin Light  Heavy  = '┧'+uJoins Light  Light  NoJoin Heavy  = '┰'+uJoins Light  Light  Light  Heavy  = '╁'+-- Using NoJoin and Light with northward Heavy, 7 cases+uJoins NoJoin NoJoin Heavy  Light  = '╿'+uJoins NoJoin Light  Heavy  NoJoin = '┖'+uJoins NoJoin Light  Heavy  Light  = '┞'+uJoins Light  NoJoin Heavy  NoJoin = '┚'+uJoins Light  NoJoin Heavy  Light  = '┦'+uJoins Light  Light  Heavy  NoJoin = '┸'+uJoins Light  Light  Heavy  Light  = '╀'+-- Using NoJoin and Light with westward Heavy, 7 cases+uJoins NoJoin Heavy  NoJoin Light  = '┍'+uJoins NoJoin Heavy  Light  NoJoin = '┕'+uJoins NoJoin Heavy  Light  Light  = '┝'+uJoins Light  Heavy  NoJoin NoJoin = '╼'+uJoins Light  Heavy  NoJoin Light  = '┮'+uJoins Light  Heavy  Light  NoJoin = '┶'+uJoins Light  Heavy  Light  Light  = '┾'+-- Using NoJoin and Light with eastward Heavy, 7 cases+uJoins Heavy  NoJoin NoJoin Light  = '┑'+uJoins Heavy  NoJoin Light  NoJoin = '┙'+uJoins Heavy  NoJoin Light  Light  = '┥'+uJoins Heavy  Light  NoJoin NoJoin = '╾'+uJoins Heavy  Light  NoJoin Light  = '┭'+uJoins Heavy  Light  Light  NoJoin = '┵'+uJoins Heavy  Light  Light  Light  = '┽'+-- Using Light and three Heavy, 4 cases+uJoins Light  Heavy  Heavy  Heavy  = '╊'+uJoins Heavy  Light  Heavy  Heavy  = '╉'+uJoins Heavy  Heavy  Light  Heavy  = '╈'+uJoins Heavy  Heavy  Heavy  Light  = '╇'+-- Up to this point we have defined all joins of NoJoin, Light, and Heavy, 81 cases total+-- Using NoJoin and Double, 15 cases+uJoins NoJoin NoJoin Double Double = '║'+uJoins Double Double NoJoin NoJoin = '═'+uJoins Double Double Double Double = '╬'+uJoins NoJoin NoJoin NoJoin Double = '╻'  -- Not available, use Heavy instead of Double+uJoins NoJoin NoJoin Double NoJoin = '╹'  -- Not available, use Heavy instead of Double+uJoins NoJoin Double NoJoin NoJoin = '╺'  -- Not available, use Heavy instead of Double+uJoins Double NoJoin NoJoin NoJoin = '╸'  -- Not available, use Heavy instead of Double+uJoins NoJoin Double NoJoin Double = '╔'+uJoins NoJoin Double Double NoJoin = '╚'+uJoins Double NoJoin NoJoin Double = '╗'+uJoins Double NoJoin Double NoJoin = '╝'+uJoins NoJoin Double Double Double = '╠'+uJoins Double NoJoin Double Double = '╣'+uJoins Double Double NoJoin Double = '╦'+uJoins Double Double Double NoJoin = '╩'+-- Using NoJoin and Light with two Double, 18 cases+uJoins NoJoin Light  Double Double = '╟'+uJoins Light  NoJoin Double Double = '╢'+uJoins Light  Light  Double Double = '╫'+uJoins Double Double NoJoin Light  = '╤'+uJoins Double Double Light  NoJoin = '╧'+uJoins Double Double Light  Light  = '╪'+uJoins NoJoin Double Light  Double = '┢'  -- Not available, use Heavy instead of Double+uJoins Light  Double NoJoin Double = '┲'  -- Not available, use Heavy instead of Double+uJoins Light  Double Light  Double = '╆'  -- Not available, use Heavy instead of Double+uJoins NoJoin Double Double Light  = '┡'  -- Not available, use Heavy instead of Double+uJoins Light  Double Double NoJoin = '┺'  -- Not available, use Heavy instead of Double+uJoins Light  Double Double Light  = '╄'  -- Not available, use Heavy instead of Double+uJoins Double NoJoin Light  Double = '┪'  -- Not available, use Heavy instead of Double+uJoins Double Light  NoJoin Double = '┱'  -- Not available, use Heavy instead of Double+uJoins Double Light  Light  Double = '╅'  -- Not available, use Heavy instead of Double+uJoins Double NoJoin Double Light  = '┩'  -- Not available, use Heavy instead of Double+uJoins Double Light  Double NoJoin = '┹'  -- Not available, use Heavy instead of Double+uJoins Double Light  Double Light  = '╃'  -- Not available, use Heavy instead of Double+-- Using NoJoin and Light with southward Double, 7 cases+uJoins NoJoin NoJoin Light  Double = '╽'  -- Not available, use Heavy instead of Double+uJoins NoJoin Light  NoJoin Double = '╓'+uJoins NoJoin Light  Light  Double = '┟'  -- Not available, use Heavy instead of Double+uJoins Light  NoJoin NoJoin Double = '╖'+uJoins Light  NoJoin Light  Double = '┧'  -- Not available, use Heavy instead of Double+uJoins Light  Light  NoJoin Double = '╥'+uJoins Light  Light  Light  Double = '╁'  -- Not available, use Heavy instead of Double+-- Using NoJoin and Light with northward Double, 7 cases+uJoins NoJoin NoJoin Double Light  = '╿'  -- Not available, use Heavy instead of Double+uJoins NoJoin Light  Double NoJoin = '╙'+uJoins NoJoin Light  Double Light  = '┞'  -- Not available, use Heavy instead of Double+uJoins Light  NoJoin Double NoJoin = '╜'+uJoins Light  NoJoin Double Light  = '┦'  -- Not available, use Heavy instead of Double+uJoins Light  Light  Double NoJoin = '╨'+uJoins Light  Light  Double Light  = '╀'  -- Not available, use Heavy instead of Double+-- Using NoJoin and Light with westward Double, 7 cases+uJoins NoJoin Double NoJoin Light  = '╓'+uJoins NoJoin Double Light  NoJoin = '╘'+uJoins NoJoin Double Light  Light  = '╞'+uJoins Light  Double NoJoin NoJoin = '╼'  -- Not available, use Heavy instead of Double+uJoins Light  Double NoJoin Light  = '┮'  -- Not available, use Heavy instead of Double+uJoins Light  Double Light  NoJoin = '┶'  -- Not available, use Heavy instead of Double+uJoins Light  Double Light  Light  = '┾'  -- Not available, use Heavy instead of Double+-- Using NoJoin and Light with eastward Double, 7 cases+uJoins Double NoJoin NoJoin Light  = '╕'+uJoins Double NoJoin Light  NoJoin = '╛'+uJoins Double NoJoin Light  Light  = '╡'+uJoins Double Light  NoJoin NoJoin = '╾'  -- Not available, use Heavy instead of Double+uJoins Double Light  NoJoin Light  = '┭'  -- Not available, use Heavy instead of Double+uJoins Double Light  Light  NoJoin = '┵'  -- Not available, use Heavy instead of Double+uJoins Double Light  Light  Light  = '┽'  -- Not available, use Heavy instead of Double+-- Using Light and three Double, 4 cases+uJoins Light  Double Double Double = '╊'  -- Not available, use Heavy instead of Double+uJoins Double Light  Double Double = '╉'  -- Not available, use Heavy instead of Double+uJoins Double Double Light  Double = '╈'  -- Not available, use Heavy instead of Double+uJoins Double Double Double Light  = '╇'  -- Not available, use Heavy instead of Double+-- Up to this point we have defined all joins of NoJoin, Light, and Double, 146 cases total+-- Beyond this point, all cases involve at least one of each of Heavy and+-- Double, for which there are no join glyphs defined in Unicode. For these, we degrade any+-- Double to a Heavy.+-- An alternate degradation path is Heavy -> Single, but for some of these+-- there would be a second degradation Double -> Heavy afterwards. It's unclear+-- which of these options is better.+uJoins e w n s = uJoins (degrade e) (degrade w) (degrade n) (degrade s)+  where+    degrade Double = Heavy+    degrade x      = x
src/Text/Layout/Table/Pandoc.hs view
@@ -1,10 +1,16 @@ -- | Render tables that can be used in <https://pandoc.org/ Pandoc>. In -- particular, this supports the -- <https://pandoc.org/MANUAL.html#tables pipe_tables> extension.-module Text.Layout.Table.Pandoc where+module Text.Layout.Table.Pandoc+  ( PandocSeparator+  , pandocPipeTableLines+  ) where  import Data.List +import Data.Default.Class++import Text.Layout.Table.Cell import Text.Layout.Table.Primitives.ColumnModifier import Text.Layout.Table.Primitives.Header import Text.Layout.Table.Spec.ColSpec@@ -12,32 +18,46 @@ import Text.Layout.Table.Spec.Position import Text.Layout.Table.Spec.Util +-- | The separator to be used for 'HeaderSpec'.  The only supported value is+-- 'def'.  Typically, it is not necessary to use this.+data PandocSeparator+    -- The value is not actually used anywhere.  It exists with the sole+    -- purpose to limit user input to the single supported character.+    = PandocSeparator++instance Default PandocSeparator where+    -- | A single line represented by @-@ and @|@.+    def = PandocSeparator+ -- | Generate a table that is readable but also serves as input to pandoc. ----- >>> mapM_ putStrLn $ pandocPipeTableLines [def, numCol] (titlesH ["text", "numeric value"]) [["a", "1.5"], ["b", "6.60000"]]+-- >>> mapM_ putStrLn $ pandocPipeTableLines [defColSpec, numCol] (titlesH ["text", "numeric value"]) [["a", "1.5"], ["b", "6.60000"]] -- |text|numberic value| -- |:---|-------------:| -- |a   |       1.5    | -- |b   |       6.60000| pandocPipeTableLines-    :: [ColSpec]-    -> HeaderSpec+    :: Cell c+    => [ColSpec]+    -> HeaderSpec PandocSeparator c     -> [Row String]     -> [String] pandocPipeTableLines specs h tab =     fmap (intercalate "|" . ("" :) . (++ [""])) $ consHeaderRow . (vSeparators :) $ zipWith ($) cmfs <$> tab   where     cmfs = zipWith (\spec cmi -> columnModifier (position spec) (cutMark spec) cmi) specs cmis-    cmis = zipWith (ensureWidthCMI 2) posSpecs $ fitHeaderIntoCMIs $ deriveColModInfos' specs tab+    cmis = zipWith (ensureWidthCMI 2) posSpecs $ fitHeaderIntoCMIs $ deriveColModInfosFromGrid specs tab      posSpecs = fmap position specs      (fitHeaderIntoCMIs, consHeaderRow) = case h of-        NoneHS                      -> (id, id)-        HeaderHS headerSpecs titles ->+        NoneHS _ -> (id, id)+        _        ->             ( fitTitlesCMI titles posSpecs             , (zipWith4 headerCellModifier headerSpecs (cutMark <$> specs) cmis titles :)             )+      where+        (headerSpecs, titles) = unzip $ headerContents h      vSeparators = zipWith (\pos cmi -> applyPandocPositionMarker pos $ replicate (widthCMI cmi) '-') posSpecs cmis
src/Text/Layout/Table/Primitives/AlignInfo.hs view
@@ -5,6 +5,7 @@ -- | Specifies the length before and after an alignment position (excluding the -- alignment character). data AlignInfo = AlignInfo Int (Maybe Int)+  deriving (Eq, Show)  -- | Private show function. showAI :: AlignInfo -> String
src/Text/Layout/Table/Primitives/Basic.hs view
@@ -29,8 +29,6 @@  import Text.Layout.Table.Spec.CutMark -import Data.List- spaces :: Int -> String spaces = flip replicate ' '
+ src/Text/Layout/Table/Primitives/CellMod.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DeriveFunctor #-}+module Text.Layout.Table.Primitives.CellMod where++-- | Provide all the information necessary to compare resulting dimensions and+-- to turn it into a 'StringBuilder'.+data CellMod a =+    CellMod+    { baseCellCM :: a+    , leftAdjustmentCM :: Int+    , rightAdjustmentCM :: Int+    , leftCutMarkLenCM :: Int+    , rightCutMarkLenCM :: Int+    } deriving (Eq, Ord, Show, Functor)++-- | Describe a padding operation on the left side.  The padding may not be+-- negative.+padCellLeft :: Int -> a -> CellMod a+padCellLeft leftPadding = modifyCell leftPadding 0++-- | Describe a padding operation on the right side.  The padding may not be+-- negative.+padCellRight :: Int -> a -> CellMod a+padCellRight rightPadding = modifyCell 0 rightPadding++-- | Describe a padding operation.  The padding may not be negative.+padCell :: Int -> Int -> a -> CellMod a+padCell leftPadding rightPadding = modifyCell leftPadding rightPadding++-- | Describe a trim operation.  None of the arguments may be negative.+trimCell :: Int -> Int -> Int -> Int -> a -> CellMod a+trimCell leftTrim rightTrim leftCMLen rightCMLen =+    modifyCellWithCutMarkLen (negate leftTrim) (negate rightTrim) leftCMLen rightCMLen++-- | Describe a trim operation on the left side.  None of the arguments may be negative.+trimCellLeft :: Int -> Int -> a -> CellMod a+trimCellLeft leftTrim leftCMLen =+    trimCell leftTrim 0 leftCMLen 0++-- | Describe a trim operation on the right side.  None of the arguments may be negative.+trimCellRight :: Int -> Int -> a -> CellMod a+trimCellRight rightTrim rightCMLen =+    trimCell 0 rightTrim 0 rightCMLen++modifyCellWithCutMarkLen :: Int -> Int -> Int -> Int -> a -> CellMod a+modifyCellWithCutMarkLen la ra lc rc c = CellMod c la ra lc rc++-- | Given adjustments for the left and the right side, either pad or trim.+-- Negative values will trim, positive values will pad.+modifyCell :: Int -> Int -> a -> CellMod a+modifyCell la ra = modifyCellWithCutMarkLen la ra 0 0++keepCell :: a -> CellMod a+keepCell = modifyCellWithCutMarkLen 0 0 0 0+
src/Text/Layout/Table/Primitives/ColumnModifier.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE RankNTypes #-} module Text.Layout.Table.Primitives.ColumnModifier where  import Control.Arrow ((&&&)) import Data.List+import Data.Semigroup (Max(..))  import Text.Layout.Table.Cell import Text.Layout.Table.Primitives.AlignInfo@@ -15,9 +17,9 @@ import Text.Layout.Table.StringBuilder  -- | Specifies how a column should be modified. Values of this type are derived--- in a traversal over the input columns by using 'deriveColModInfos'. Finally,--- 'columnModifier' will interpret them and apply the appropriate modification--- function to the cells of the column.+-- in a traversal over the input columns by using 'deriveColModInfosFromGrid'.+-- Finally, 'columnModifier' will interpret them and apply the appropriate+-- modification function to the cells of the column. data ColModInfo     = FillAligned OccSpec AlignInfo     | FillTo Int@@ -69,11 +71,11 @@     _             -> cmi  -- | Ensures that the given 'String' will fit into the modified columns.-ensureWidthOfCMI :: String -> Position H -> ColModInfo -> ColModInfo+ensureWidthOfCMI :: Cell a => a -> Position H -> ColModInfo -> ColModInfo ensureWidthOfCMI = ensureWidthCMI . visibleLength  -- | Fit titles of a header column into the derived 'ColModInfo'.-fitTitlesCMI :: [String] -> [Position H] -> [ColModInfo] -> [ColModInfo]+fitTitlesCMI :: Cell a => [a] -> [Position H] -> [ColModInfo] -> [ColModInfo] fitTitlesCMI = zipWith3 ensureWidthOfCMI  -- | Generates a function which modifies a given cell according to@@ -86,56 +88,86 @@     -> CutMark     -> ColModInfo     -> (a -> b)-columnModifier pos cms colModInfo = case colModInfo of+columnModifier pos cms colModInfo = buildCellMod cms . case colModInfo of     FillAligned oS ai -> align oS ai     FillTo maxLen     -> pad pos maxLen     FitTo lim mT      ->         maybe (trimOrPad pos cms lim) (uncurry $ alignFixed pos cms lim) mT --- | Derive the 'ColModInfo' by using layout specifications and the actual cells--- of a column. This function only needs to know about 'LenSpec' and 'AlignInfo'.-deriveColModInfos :: Cell a => [(LenSpec, AlignSpec)] -> [Row a] -> [ColModInfo]-deriveColModInfos specs = zipWith ($) (fmap fSel specs) . transpose+-- | Generate the 'AlignInfo' of a cell by using the 'OccSpec'.+deriveAlignInfo :: Cell a => OccSpec -> a -> AlignInfo+deriveAlignInfo occSpec = measureAlignment (predicate occSpec)++unpackColSpecs :: [ColSpec] -> [(LenSpec, AlignSpec)]+unpackColSpecs = fmap $ lenSpec &&& alignSpec++-- | Derive the 'ColModInfo' for each column of a list of rows by using the+-- corresponding specifications.+deriveColModInfosFromGridLA :: Cell a => [(LenSpec, AlignSpec)] -> [Row a] -> [ColModInfo]+deriveColModInfosFromGridLA specs = deriveColModInfosFromColumnsLA specs . transpose++-- | Derive the 'ColModInfo' for each column of a list of rows by using the+-- corresponding 'ColSpec'.+deriveColModInfosFromGrid :: Cell a => [ColSpec] -> [Row a] -> [ColModInfo]+deriveColModInfosFromGrid = deriveColModInfosFromGridLA . unpackColSpecs++-- | Derive the 'ColModInfo' of a single column by using the 'LenSpec' and the+-- 'AlignSpec'.+deriveColModInfoFromColumnLA :: (Foldable col, Cell a) => (LenSpec, AlignSpec) -> col a -> ColModInfo+deriveColModInfoFromColumnLA (lenS, alignS) = case alignS of+    NoAlign     -> let expandFun = FillTo+                       fixedFun i = const $ FitTo i Nothing+                       measureMaximumWidth = getMax . foldMap (Max . visibleLength)+                       lengthFun = id+                    in go expandFun fixedFun measureMaximumWidth lengthFun++    AlignOcc oS -> let expandFun = FillAligned oS+                       fixedFun i = FitTo i . Just . (,) oS+                       measureMaximumWidth = foldMap $ deriveAlignInfo oS+                       lengthFun = widthAI+                    in go expandFun fixedFun measureMaximumWidth lengthFun   where-    fSel (lenS, alignS) = case alignS of-        NoAlign     -> let fitTo i              = const $ FitTo i Nothing-                           expandUntil' f i max' = if f (max' <= i)-                                                   then FillTo max'-                                                   else fitTo i max'-                           fun                  = case lenS of-                               Expand        -> FillTo-                               Fixed i       -> fitTo i-                               ExpandUntil i -> expandUntil' id i-                               FixedUntil i  -> expandUntil' not i-                       in fun . maximum . map visibleLength-        AlignOcc oS -> let fitToAligned i      = FitTo i . Just . (,) oS-                           fillAligned         = FillAligned oS-                           expandUntil' f i ai = if f (widthAI ai <= i)-                                                then fillAligned ai-                                                else fitToAligned i ai-                           fun                = case lenS of-                               Expand        -> fillAligned-                               Fixed i       -> fitToAligned i-                               ExpandUntil i -> expandUntil' id i-                               FixedUntil i  -> expandUntil' not i-                        in fun . foldMap (deriveAlignInfo oS)+    go :: forall a w col. (Cell a, Foldable col)+       => (w -> ColModInfo)+       -> (Int -> w -> ColModInfo)+       -> (col a -> w)+       -> (w -> Int)+       -> col a+       -> ColModInfo+    go expandFun fixedFun measureMaximumWidth lengthFun =+        let expandBetween' i j widthInfo | lengthFun widthInfo > j = fixedFun j widthInfo+                                         | lengthFun widthInfo < i = fixedFun i widthInfo+                                         | otherwise               = expandFun widthInfo+            expandUntil' f i widthInfo = if f (lengthFun widthInfo <= i)+                                         then expandFun widthInfo+                                         else fixedFun i widthInfo+            interpretLenSpec = case lenS of+                Expand            -> expandFun+                Fixed i           -> fixedFun i+                ExpandUntil i     -> expandUntil' id i+                FixedUntil i      -> expandUntil' not i+                ExpandBetween i j -> expandBetween' i j+        in interpretLenSpec . measureMaximumWidth -deriveColModInfos' :: Cell a => [ColSpec] -> [Row a] -> [ColModInfo]-deriveColModInfos' = deriveColModInfos . fmap (lenSpec &&& alignSpec)+-- | Derive the 'ColModInfo' for each column of a list of columns by using the+-- corresponding specifications.+deriveColModInfosFromColumnsLA :: (Foldable col, Cell a) => [(LenSpec, AlignSpec)] -> [col a] -> [ColModInfo]+deriveColModInfosFromColumnsLA specs = zipWith ($) (fmap deriveColModInfoFromColumnLA specs) +-- | Derive the 'ColModInfo' for each column of a list of columns by using the+-- corresponding 'ColSpec'.+deriveColModInfosFromColumns :: (Foldable col, Cell a) => [ColSpec] -> [col a] -> [ColModInfo]+deriveColModInfosFromColumns = deriveColModInfosFromColumnsLA . unpackColSpecs+ -- | Derive the 'ColModInfo' and generate functions without any intermediate -- steps.-deriveColMods+deriveColumnModifiers     :: (Cell a, StringBuilder b)     => [ColSpec]     -> [Row a]     -> [a -> b]-deriveColMods specs tab =+deriveColumnModifiers specs tab =     zipWith (uncurry columnModifier) (map (position &&& cutMark) specs) cmis   where-    cmis = deriveColModInfos' specs tab---- | Generate the 'AlignInfo' of a cell by using the 'OccSpec'.-deriveAlignInfo :: Cell a => OccSpec -> a -> AlignInfo-deriveAlignInfo occSpec = measureAlignment (predicate occSpec)+    cmis = deriveColModInfosFromGrid specs tab
src/Text/Layout/Table/Primitives/Header.hs view
@@ -2,12 +2,14 @@  import Data.Maybe +import Text.Layout.Table.Cell+import Text.Layout.Table.StringBuilder import Text.Layout.Table.Primitives.ColumnModifier import Text.Layout.Table.Spec.CutMark import Text.Layout.Table.Spec.HeaderColSpec  -- | Combine a 'HeaderColSpec' and existing 'ColModInfo's to format header cells.-headerCellModifier :: HeaderColSpec -> CutMark -> ColModInfo -> (String -> String)+headerCellModifier :: (Cell a, StringBuilder b) => HeaderColSpec -> CutMark -> ColModInfo -> (a -> b) headerCellModifier (HeaderColSpec pos optCutMark) cutMark cmi =     columnModifier pos (fromMaybe cutMark optCutMark) (unalignedCMI cmi)
src/Text/Layout/Table/Primitives/Table.hs view
@@ -1,41 +1,40 @@ -- | This module provides primitives for generating tables. Tables are generated -- line by line thus the functions in this module produce 'StringBuilder's that -- contain a line.-module Text.Layout.Table.Primitives.Table where--import           Data.List+module Text.Layout.Table.Primitives.Table+    ( horizontalDetailLine+    , horizontalContentLine+    ) where  import           Text.Layout.Table.StringBuilder import           Text.Layout.Table.Spec.Util  --- | Draw a horizontal line that will use the delimiters around the--- appropriately and visually separate by 'hSpace'.-hLineDetail-    :: StringBuilder b-    => Char -- ^ The space character that is used as padding.-    -> Char -- ^ The delimiter that is used on the left side.-    -> Char -- ^ The delimiter that is used in between cells.-    -> Char -- ^ The delimiter that is sued on the right side.-    -> Row b -- ^ A row of builders.-    -> b -- ^ The formatted line as a 'StringBuilder'.-hLineDetail hSpace delimL delimM delimR cells =-    mconcat $ intersperse (charB hSpace) $ charB delimL : intersperse (charB delimM) cells ++ [charB delimR]---- | A simplified version of 'hLineDetail' that will use the same delimiter--- for everything.-hLine+-- | Draw a horizontal line that will use the provided delimiters around+-- the content appropriately and visually separate by 'hSpace'.+horizontalDetailLine     :: StringBuilder b-    => Char -- ^ The space character that is used as padding.-    -> Char -- ^ The delimiter that is used for everything.-    -> Row b -- ^ A row of builders.-    -> b -- ^ The formatted line as a 'StringBuilder'.-hLine hSpace delim = hLineDetail hSpace delim delim delim+    => String                            -- ^ The space characters that are used as padding.+    -> String                            -- ^ The space characters that are used as padding in the row header.+    -> String                            -- ^ The delimiter that is used on the left side.+    -> String                            -- ^ The delimiter that is used on the right side.+    -> String                            -- ^ The delimiter that is used for the row header separator.+    -> (Maybe b, Row (Either String b))  -- ^ Optionally a row header, along with a row of builders and separators.+    -> b                                 -- ^ The formatted line as a 'StringBuilder'.+horizontalDetailLine hSpace hSepSpace delimL delimR delimSep (header, cells) =+    stringB delimL <> renderedHeader <> renderedCells <> stringB delimR+  where+    renderedHeader = case header of+      Nothing -> mempty+      Just r  -> stringB hSepSpace <> r <> stringB hSepSpace <> stringB delimSep+    renderedCells = foldMap ((stringB hSpace <>) . either stringB id) cells <> stringB hSpace  -- | Render a line with actual content.-hLineContent+horizontalContentLine     :: StringBuilder b-    => Char -- ^ The delimiter that is used for everything.-    -> Row b -- ^ A row of builders.+    => String                            -- ^ The delimiter that is used on the left side.+    -> String                            -- ^ The delimiter that is used on the right side.+    -> String                            -- ^ The delimiter that is used on the row header separator.+    -> (Maybe b, Row (Either String b))  -- ^ A row of builders and separators.     -> b-hLineContent = hLine ' '+horizontalContentLine = horizontalDetailLine " " " "
src/Text/Layout/Table/Spec/AlignSpec.hs view
@@ -19,7 +19,7 @@ instance Default AlignSpec where     def = noAlign --- | Don't align text.+-- | Do not align text. noAlign :: AlignSpec noAlign = NoAlign @@ -27,7 +27,7 @@ occSpecAlign :: OccSpec -> AlignSpec occSpecAlign = AlignOcc --- | Align at the first match of a predicate.+-- | Align text at the first match of a predicate. predAlign :: (Char -> Bool) -> AlignSpec predAlign = occSpecAlign . predOccSpec
src/Text/Layout/Table/Spec/ColSpec.hs view
@@ -2,9 +2,12 @@     ( ColSpec     , lenSpec     , position+    , beginning     , alignSpec     , cutMark+    , ellipsisCutMark     , column+    , defColSpec     ) where  import Data.Default.Class@@ -26,7 +29,13 @@     }  instance Default ColSpec where-    def = column def def def def+    def = defColSpec++-- | The default 'ColSpec' uses as much space as needed, positioned at the+-- left/top (depending on orientation), does not align to any character, and+-- uses a single unicode ellipsis on either side as a cut mark.+defColSpec :: ColSpec+defColSpec = column expand beginning noAlign ellipsisCutMark  -- | Smart constructor to specify a column. column :: LenSpec -> Position H -> AlignSpec -> CutMark -> ColSpec
src/Text/Layout/Table/Spec/CutMark.hs view
@@ -6,22 +6,28 @@     , noCutMark     , leftMark     , rightMark+    , ellipsisCutMark     ) where  import Data.Default.Class --- | Specifies how the place looks where a 'String' has been cut. Note that the--- cut mark may be cut itself to fit into a column.+-- | Specifies a cut mark that is used whenever content is cut to fit into a+-- cell.  If the cut mark itself is too small to fit into a cell it may be cut+-- as well. data CutMark     = CutMark     { leftMark  :: String     , rightMark :: String-    }+    } deriving (Show, Eq)  -- | A single ellipsis unicode character is used to show cut marks. instance Default CutMark where-    def = singleCutMark "…"+    def = ellipsisCutMark +-- | The default 'CutMark' is a single ellipsis unicode character on each side.+ellipsisCutMark :: CutMark+ellipsisCutMark = singleCutMark "…"+ -- | Specify two different cut marks, one for cuts on the left and one for cuts -- on the right. doubleCutMark :: String -> String -> CutMark@@ -31,7 +37,7 @@ singleCutMark :: String -> CutMark singleCutMark l = doubleCutMark l (reverse l) --- | Don't show any cut mark when text is cut.+-- | Do not show any cut mark when content is cut. noCutMark :: CutMark noCutMark = singleCutMark ""
src/Text/Layout/Table/Spec/HeaderColSpec.hs view
@@ -1,7 +1,6 @@ module Text.Layout.Table.Spec.HeaderColSpec where  import Data.Default.Class-import Data.Default.Instances.Base ()  import Text.Layout.Table.Spec.Position import Text.Layout.Table.Spec.CutMark@@ -9,12 +8,16 @@ -- | Specifies how a header is rendered. data HeaderColSpec = HeaderColSpec (Position H) (Maybe CutMark) --- | Smart constructor for 'HeaderColSpec'. By omitting the cut mark it will use--- the one specified in the 'Text.Layout.Primitives.Column.ColSpec' like the--- other cells in that column.+-- | Smart constructor for 'HeaderColSpec'. By omitting the cut mark, it will+-- use the one specified in the 'Text.Layout.Primitives.Column.ColSpec' like+-- the other cells in that column. headerColumn :: Position H -> Maybe CutMark -> HeaderColSpec headerColumn = HeaderColSpec  -- | Header columns are usually centered. instance Default HeaderColSpec where-    def = headerColumn center def+    def = defHeaderColSpec++-- | The default 'HeaderColSpec' centers the text and uses no 'CutMark'.+defHeaderColSpec :: HeaderColSpec+defHeaderColSpec = headerColumn center Nothing
src/Text/Layout/Table/Spec/HeaderSpec.hs view
@@ -1,22 +1,84 @@+{-# LANGUAGE DeriveTraversable #-}+ module Text.Layout.Table.Spec.HeaderSpec where +import Data.Bifunctor import Data.Default.Class+import Data.List  import Text.Layout.Table.Spec.HeaderColSpec  -- | Specifies a header.-data HeaderSpec-    = HeaderHS [HeaderColSpec] [String]-    | NoneHS+data HeaderSpec sep a+    -- | A grouping of subheaders separated by delimiters with the given label+    = GroupHS sep [HeaderSpec sep a]+    -- | A single header column with a given 'HeaderColSpec' and content.+    | HeaderHS HeaderColSpec a+    -- | Do not display the header, and determine the shape as a flat list+    -- sized to the table content with a given separator.+    | NoneHS sep+  deriving (Functor, Foldable, Traversable) +instance Bifunctor HeaderSpec where+    bimap f g (GroupHS sep hs)       = GroupHS (f sep) (map (bimap f g) hs)+    bimap _ g (HeaderHS spec title)  = HeaderHS spec (g title)+    bimap f _ (NoneHS sep)           = NoneHS (f sep)+ -- | By the default the header is not shown.-instance Default HeaderSpec where-    def = NoneHS+instance Default sep => Default (HeaderSpec sep a) where+    def = defHeaderSpec --- | Specify a header column for every title.-fullH :: [HeaderColSpec] -> [String] -> HeaderSpec-fullH = HeaderHS+-- | The default 'HeaderSpec' does not display the header and uses the default+-- separator.+defHeaderSpec :: Default sep => HeaderSpec sep a+defHeaderSpec = NoneHS def --- | Use titles with the default header column specification.-titlesH :: [String] -> HeaderSpec-titlesH = fullH $ repeat def+-- | Specify no header, with columns separated by a given separator.+noneSepH :: sep -> HeaderSpec sep String+noneSepH = NoneHS++-- | Specify no header, with columns separated by a default separator.+noneH :: Default sep => HeaderSpec sep String+noneH = noneSepH def++-- | Specify every header column in detail and separate them by the given+-- separator.+fullSepH :: sep -> [HeaderColSpec] -> [a] -> HeaderSpec sep a+fullSepH sep specs = GroupHS sep . zipWith HeaderHS specs++-- | Specify every header column in detail and separate them with the default+-- separator.+fullH :: Default sep => [HeaderColSpec] -> [a] -> HeaderSpec sep a+fullH = fullSepH def++-- | Use titles with the default header column specification and separator.+titlesH :: Default sep => [a] -> HeaderSpec sep a+titlesH = fullH (repeat defHeaderColSpec)++-- | Combine the header specification for multiple columns by separating the+-- columns with a specific separator.+groupH :: sep -> [HeaderSpec sep a] -> HeaderSpec sep a+groupH = GroupHS++-- | Specify the header for a single column.+headerH :: HeaderColSpec -> a -> HeaderSpec sep a+headerH = HeaderHS++-- | Zip a 'HeaderSpec' with a list.+zipHeader :: b -> [b] -> HeaderSpec sep a -> HeaderSpec sep (b, a)+zipHeader e bs = snd . mapAccumL helper bs+  where+    helper (s : ss) title = (ss, (s, title))+    helper []       title = ([], (e, title))++-- | Flatten a header to produce a list of content and separators.+flattenHeader :: HeaderSpec sep a -> [Either sep a]+flattenHeader (GroupHS sep hs)   = intercalate [Left sep] $ map flattenHeader hs+flattenHeader (HeaderHS _ title) = [Right title]+flattenHeader (NoneHS _)         = []++-- | Get the titles and column specifications from a header.+headerContents :: HeaderSpec sep a -> [(HeaderColSpec, a)]+headerContents (GroupHS _ hs)        = concatMap headerContents hs+headerContents (HeaderHS spec title) = [(spec, title)]+headerContents (NoneHS _)            = []
src/Text/Layout/Table/Spec/LenSpec.hs view
@@ -4,6 +4,7 @@     , fixed     , expandUntil     , fixedUntil+    , expandBetween     ) where  import Data.Default.Class@@ -14,7 +15,9 @@     | Fixed Int     | ExpandUntil Int     | FixedUntil Int+    | ExpandBetween Int Int +-- | The default 'LenSpec' allows columns to use as much space as needed. instance Default LenSpec where     def = expand @@ -33,3 +36,8 @@ -- | The column will be at least as wide as the given width. fixedUntil :: Int -> LenSpec fixedUntil = FixedUntil++-- | The column will be at least as wide as the first width, and will expand as+-- long as it is smaller than the second.+expandBetween :: Int -> Int -> LenSpec+expandBetween = ExpandBetween
src/Text/Layout/Table/Spec/Position.hs view
@@ -23,8 +23,13 @@         Center -> "center"         End    -> "bottom" +-- | The default 'Position' displays at the left or top, depending on the orientation. instance Default (Position orientation) where-    def = Start+    def = beginning++-- | Displays at the left or top, depending on the orientation.+beginning :: Position orientation+beginning = Start  -- | Horizontal orientation. data H
src/Text/Layout/Table/Spec/RowGroup.hs view
@@ -1,18 +1,66 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-} module Text.Layout.Table.Spec.RowGroup where  import Text.Layout.Table.Spec.Util +import Data.List (transpose)+import Data.Functor (void)+ -- | Groups rows together which should not be visually seperated from each other.-newtype RowGroup a-    = RowGroup-    { rows :: [Row a]-    }+data RowGroup a+    = SingletonRowGroup (Row a)+    | MultiRowGroup [Row a]+    | NullableRowGroup [Row (Maybe a)]  -- | Group the given rows together. rowsG :: [Row a] -> RowGroup a-rowsG = RowGroup+rowsG = MultiRowGroup  -- | Make a group of a single row. rowG :: Row a -> RowGroup a-rowG = RowGroup . (: [])+rowG = SingletonRowGroup +-- | Provide a 'RowGroup' where single cells may be missing.+nullableRowsG :: [Row (Maybe a)] -> RowGroup a+nullableRowsG = NullableRowGroup++-- | Extracts the shape of the 'RowGroup' from the first row.+rowGroupShape :: RowGroup a -> [()]+rowGroupShape rg = case rg of+    SingletonRowGroup r  -> void r+    MultiRowGroup rs     -> firstSubListShape rs+    NullableRowGroup ors -> firstSubListShape ors+  where+    firstSubListShape l = case l of+        r : _ -> void r+        []    -> []++data ColumnSegment a+    = SingleValueSegment a+    | ColumnSegment (Col a)+    | NullableColumnSegment (Col (Maybe a))+    deriving (Functor, Foldable, Eq, Show)++newtype SegmentedColumn a = SegmentedColumn [ColumnSegment a] deriving (Functor, Foldable, Eq, Show)++-- | Break down several 'RowGroups', which conceptually form a column by+-- themselves, into a list of columns.+transposeRowGroups :: Col (RowGroup a) -> [SegmentedColumn a]+transposeRowGroups = fmap SegmentedColumn . transpose . map transposeRowGroup+  where+    transposeRowGroup :: RowGroup a -> [ColumnSegment a]+    transposeRowGroup rg = case rg of+        SingletonRowGroup row -> SingleValueSegment <$> row+        MultiRowGroup rows    -> ColumnSegment <$> transpose rows+        NullableRowGroup rows -> NullableColumnSegment <$> transpose rows++-- | Map each column with the corresponding function and replace empty inputs+-- with the given value.+mapRowGroupColumns :: [(b, a -> b)] -> RowGroup a -> [[b]]+mapRowGroupColumns mappers rg = case rg of+    SingletonRowGroup row  -> pure $ zipWith snd mappers row+    MultiRowGroup rows     -> mapGrid snd rows+    NullableRowGroup orows -> mapGrid (uncurry maybe) orows+  where+    mapGrid applyMapper = map $ zipWith applyMapper mappers
+ src/Text/Layout/Table/Spec/TableSpec.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE RecordWildCards #-}+module Text.Layout.Table.Spec.TableSpec where++import Data.Default.Class++import Text.Layout.Table.Spec.ColSpec+import Text.Layout.Table.Spec.HeaderSpec+import Text.Layout.Table.Spec.RowGroup+import Text.Layout.Table.Style++-- | Type used to specify tables.+data TableSpec rowSep colSep r c a+    = TableSpec+    { colSpecs :: [ColSpec]+    -- ^ Layout specification of the columns+    , tableStyle :: TableStyle rowSep colSep+    -- ^ The style of the table+    , rowHeader :: HeaderSpec rowSep r+    -- ^ Specification of the row header+    , colHeader :: HeaderSpec colSep c+    -- ^ Specification of the column header+    , rowGroups :: [RowGroup a]+    -- ^ A list of visually separated rows+    }++-- | Specify a table with the style and the row groups.+simpleTableS+    :: (Default rowSep, Default colSep)+    => TableStyle rowSep colSep+    -> [RowGroup a]+    -> TableSpec rowSep colSep String String a+simpleTableS = headerlessTableS $ repeat defColSpec++-- | Specify a table with the columns, the style, and the row groups.+headerlessTableS+    :: (Default rowSep, Default colSep)+    => [ColSpec]+    -> TableStyle rowSep colSep+    -> [RowGroup a]+    -> TableSpec rowSep colSep String String a+headerlessTableS colSpecs tableStyle rowGroups = TableSpec { .. }+  where+    rowHeader = noneH+    colHeader = noneH++-- | Specify a table without a row header.+columnHeaderTableS+    :: Default rowSep+    => [ColSpec]+    -> TableStyle rowSep colSep+    -> HeaderSpec colSep c+    -> [RowGroup a]+    -> TableSpec rowSep colSep String c a+columnHeaderTableS colSpecs tableStyle colHeader rowGroups = TableSpec { .. }+  where+    rowHeader = noneH++-- | Specify a table with everything.+fullTableS+    :: [ColSpec]+    -> TableStyle rowSep colSep+    -> HeaderSpec rowSep r+    -> HeaderSpec colSep c+    -> [RowGroup a]+    -> TableSpec rowSep colSep r c a+fullTableS = TableSpec
src/Text/Layout/Table/StringBuilder.hs view
@@ -2,6 +2,8 @@ module Text.Layout.Table.StringBuilder where  import Data.Semigroup+import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as TB  -- | A type that is used to construct parts of a table. class Monoid a => StringBuilder a where@@ -11,6 +13,10 @@     -- | Create a builder with a single 'Char'.     charB :: Char -> a +    -- | Create a builder with a 'Text'.+    textB :: T.Text -> a+    textB = stringB . T.unpack+     -- | Create a builder with several 'Char's.     replicateCharB :: Int -> Char -> a     replicateCharB i c = stimesMonoid i (charB c)@@ -22,6 +28,14 @@ spacesB :: StringBuilder a => Int -> a spacesB k = replicateCharB k ' ' +-- | Creates a 'StringBuilder' with the amount of missing spaces.+remSpacesB'+    :: StringBuilder b+    => Int -- ^ The expected length.+    -> Int -- ^ The actual length.+    -> b+remSpacesB' n k = spacesB $ n - k+ instance StringBuilder String where     stringB = id     charB = (: [])@@ -30,5 +44,16 @@ instance StringBuilder (Endo String) where     stringB = diff     charB = Endo . (:)-    replicateCharB i c = Endo $ \s -> foldr ($) s $ replicate i (c :) +    replicateCharB i c = stimesMonoid i (Endo (c :)) +instance StringBuilder T.Text where+    stringB = T.pack+    charB = T.singleton+    textB = id+    replicateCharB n = T.replicate n . T.singleton++instance StringBuilder TB.Builder where+    stringB = TB.fromString+    charB = TB.singleton+    textB = TB.fromText+    replicateCharB n = TB.fromText . T.replicate n . T.singleton
src/Text/Layout/Table/Style.hs view
@@ -1,199 +1,353 @@--- | This module provides a primitive styling facility. To make your own style--- have a look at <https://en.wikipedia.org/wiki/Box-drawing_character>.-module Text.Layout.Table.Style where+-- | This module provides predefined styles, combinators to modify them,+-- abstract style descriptions, and combinators for quickly turning them into+-- styles.+--+-- The following resource may be useful for constructing your own primitive+-- styles: <https://en.wikipedia.org/wiki/Box-drawing_character>. +{-# LANGUAGE RecordWildCards #-}++module Text.Layout.Table.Style+    ( -- * Pre-Constructed Table Styles+      -- ** ASCII+      -- These styles use only ASCII characters.+      asciiS+    , asciiRoundS+    , asciiDoubleS++      -- ** Unicode+    , unicodeS+    , unicodeBoldHeaderS+    , unicodeRoundS+    , unicodeBoldS+    , unicodeBoldStripedS+    , unicodeDoubleFrameS++      -- * Combinators+    , withoutBorders+    , withoutTopBorder+    , withoutBottomBorder+    , withoutLeftBorder+    , withoutRightBorder+    , withRoundCorners+    , inheritStyle+    , inheritStyleHeaderGroup++      -- * Construct Table Styles from an Abstract Specification+    , asciiTableStyleFromSpec+    , roundedAsciiTableStyleFromSpec+    , unicodeTableStyleFromSpec+    , tableStyleFromSpec++      -- ** Construct an Abstract Specifiction+    , TableStyleSpec(..)+    , simpleTableStyleSpec+    , setTableStyleSpecSeparator++      -- * Low-Level Styling Facility+    , TableStyle(..)+    ) where++import Text.Layout.Table.LineStyle+ -- | Specifies the different letters to construct the non-content structure of a -- table.-data TableStyle = TableStyle-                { headerSepH   :: Char-                , headerSepLC  :: Char-                , headerSepRC  :: Char-                , headerSepC   :: Char-                , headerTopL   :: Char-                , headerTopR   :: Char-                , headerTopC   :: Char-                , headerTopH   :: Char-                , headerV      :: Char-                , groupV       :: Char-                , groupSepH    :: Char-                , groupSepC    :: Char-                , groupSepLC   :: Char-                , groupSepRC   :: Char-                , groupTopC    :: Char-                , groupTopL    :: Char-                , groupTopR    :: Char-                , groupTopH    :: Char-                , groupBottomC :: Char-                , groupBottomL :: Char-                , groupBottomR :: Char-                , groupBottomH :: Char-                }+--+-- This is quite low-level and difficult to construct by hand. If you want to+-- construct your own, you may wish to use the higher-level interface provided+-- by (in increasing order of detail):+--+--   1. 'simpleTableStyleSpec'+--   2. 'TableStyleSpec'+--   3. 'unicodeTableStyleFromSpec'+--   4. 'asciiTableStyleFromSpec'+--   5. 'tableStyleFromSpec'+data TableStyle rowSep colSep+    = TableStyle+    -- Within the column header but not the row header (11 cases)+    { headerSepH     :: String+    , headerSepLC    :: String+    , headerSepRC    :: String+    , headerSepC     :: colSep -> colSep -> String+    , headerTopH     :: String+    , headerTopL     :: String+    , headerTopR     :: String+    , headerTopC     :: colSep -> String+    , headerL        :: String+    , headerR        :: String+    , headerC        :: colSep -> String+    -- Within the row header but not the column header (11 cases)+    , rowHeaderSepV  :: String+    , rowHeaderSepTC :: String+    , rowHeaderSepBC :: String+    , rowHeaderSepC  :: rowSep -> rowSep -> String+    , rowHeaderLeftV :: String+    , rowHeaderLeftT :: String+    , rowHeaderLeftB :: String+    , rowHeaderLeftC :: rowSep -> String+    , rowHeaderT     :: String+    , rowHeaderB     :: String+    , rowHeaderC     :: rowSep -> String+    -- Within the intersection of the row and column headers (8 cases)+    , bothHeadersTL  :: String+    , bothHeadersTR  :: String+    , bothHeadersBL  :: String+    , bothHeadersBR  :: String+    , bothHeadersL   :: String+    , bothHeadersR   :: String+    , bothHeadersT   :: String+    , bothHeadersB   :: String+    -- Main body of the table, in neither the row or column headers (15 cases)+    , groupL         :: String+    , groupR         :: String+    , groupC         :: colSep -> String+    , groupSepH      :: rowSep -> String+    , groupSepC      :: rowSep -> colSep -> String+    , groupSepLC     :: rowSep -> String+    , groupSepRC     :: rowSep -> String+    , groupTopC      :: colSep -> String+    , groupTopL      :: String+    , groupTopR      :: String+    , groupTopH      :: String+    , groupBottomC   :: colSep -> String+    , groupBottomL   :: String+    , groupBottomR   :: String+    , groupBottomH   :: String+    } +-- | Inherit from a 'TableStyle' through a pair of functions.+inheritStyle :: (c -> a)        -- ^ The function to transform the row labels.+             -> (d -> b)        -- ^ The function to transform the column labels.+             -> TableStyle a b  -- ^ The 'TableStyle' to inherit from.+             -> TableStyle c d+inheritStyle f g = inheritStyleHeaderGroup f f g g++-- | Inherit from a 'TableStyle' using a triple of functions, specifying the+-- correspondence for row separators, column heading separators, and column separators.+inheritStyleHeaderGroup :: (c -> a)        -- ^ The function to transform the row labels in the header.+                        -> (c -> a)        -- ^ The function to transform the row labels in the body.+                        -> (d -> b)        -- ^ The function to transform the column labels in the header.+                        -> (d -> b)        -- ^ The function to transform the column labels in the body.+                        -> TableStyle a b  -- ^ The 'TableStyle' to inherit from.+                        -> TableStyle c d+inheritStyleHeaderGroup rowHead row colHead col ts =+    ts { headerSepC     = \a b -> headerSepC ts (colHead a) (col b)+       , headerTopC     = headerTopC     ts . colHead+       , headerC        = headerC        ts . colHead+       , rowHeaderSepC  = \a b -> rowHeaderSepC ts (rowHead a) (rowHead b)+       , rowHeaderLeftC = rowHeaderLeftC ts . rowHead+       , rowHeaderC     = rowHeaderC     ts . rowHead+       , groupC         = groupC         ts . col+       , groupSepH      = groupSepH      ts . row+       , groupSepC      = \a b -> groupSepC ts (row a) (col b)+       , groupSepLC     = groupSepLC     ts . row+       , groupSepRC     = groupSepRC     ts . row+       , groupTopC      = groupTopC      ts . col+       , groupBottomC   = groupBottomC   ts . col+       }++-- | Remove the top, bottom, left, and right borders from a 'TableStyle'.+withoutBorders :: TableStyle a b -> TableStyle a b+withoutBorders = withoutTopBorder . withoutBottomBorder . withoutLeftBorder . withoutRightBorder++-- | Remove the top border from a 'TableStyle'.+withoutTopBorder :: TableStyle a b -> TableStyle a b+withoutTopBorder ts = ts { headerTopH = "", headerTopL = "", headerTopR = "", headerTopC = const ""+                         , rowHeaderLeftT = "", rowHeaderT = "", rowHeaderSepTC = ""+                         , bothHeadersTL = "", bothHeadersTR = "", bothHeadersT = ""+                         , groupTopC = const "", groupTopL = "", groupTopR = "", groupTopH = ""+                         }++-- | Remove the bottom border from a 'TableStyle'.+withoutBottomBorder :: TableStyle a b -> TableStyle a b+withoutBottomBorder ts = ts { rowHeaderLeftB = "", rowHeaderB = "", rowHeaderSepBC = ""+                            , groupBottomC = const "", groupBottomL = "", groupBottomR = "", groupBottomH = "" }++-- | Remove the left border from a 'TableStyle'.+withoutLeftBorder :: TableStyle a b -> TableStyle a b+withoutLeftBorder ts = ts { headerSepLC = "", headerTopL = "", headerL = ""+                          , rowHeaderLeftV = "", rowHeaderLeftT = "", rowHeaderLeftB = "", rowHeaderLeftC = const ""+                          , bothHeadersTL = "", bothHeadersBL = "", bothHeadersL = ""+                          , groupL = "", groupSepLC = const "", groupTopL = "", groupBottomL = ""+                          }++-- | Remove the right border from a 'TableStyle'.+withoutRightBorder :: TableStyle a b -> TableStyle a b+withoutRightBorder ts = ts { headerSepRC = "", headerTopR = "", headerR = ""+                           , groupR = "", groupSepRC = const "", groupTopR = "", groupBottomR = ""+                           }++-- | Modify a 'TableStyle' to use Unicode rounded corners.+withRoundCorners :: TableStyle a b -> TableStyle a b+withRoundCorners ts = ts { headerTopL     = "╭"+                         , rowHeaderLeftT = "╭"+                         , bothHeadersTL  = "╭"+                         , groupTopL      = "╭"+                         , headerTopR     = "╮"+                         , groupTopR      = "╮"+                         , rowHeaderLeftB = "╰"+                         , groupBottomL   = "╰"+                         , groupBottomR   = "╯"+                         }++-- | A short-hand specification for generating Unicode table styles, by+-- specifying the line type of each of the main lines.+data TableStyleSpec+    = TableStyleSpec+    { headerSep         :: LineStyle+    , headerTop         :: LineStyle+    , headerLeft        :: LineStyle+    , headerRight       :: LineStyle+    , rowHeaderSep      :: LineStyle+    , rowHeaderLeft     :: LineStyle+    , rowHeaderTop      :: LineStyle+    , rowHeaderBottom   :: LineStyle+    , bothHeadersTop    :: LineStyle+    , bothHeadersBottom :: LineStyle+    , bothHeadersLeft   :: LineStyle+    , bothHeadersRight  :: LineStyle+    , groupLeft         :: LineStyle+    , groupRight        :: LineStyle+    , groupTop          :: LineStyle+    , groupBottom       :: LineStyle+    }++-- | Constructs a simple 'TableStyleSpec' which uses the given 'LineStyle's in+-- the headers and group, respectively.+simpleTableStyleSpec :: LineStyle -> LineStyle -> TableStyleSpec+simpleTableStyleSpec headerStyle groupStyle+    = TableStyleSpec+    { headerSep         = headerStyle+    , headerTop         = headerStyle+    , headerLeft        = headerStyle+    , headerRight       = headerStyle+    , rowHeaderSep      = headerStyle+    , rowHeaderLeft     = headerStyle+    , rowHeaderTop      = headerStyle+    , rowHeaderBottom   = headerStyle+    , bothHeadersTop    = headerStyle+    , bothHeadersBottom = headerStyle+    , bothHeadersLeft   = headerStyle+    , bothHeadersRight  = headerStyle+    , groupLeft         = groupStyle+    , groupRight        = groupStyle+    , groupTop          = groupStyle+    , groupBottom       = groupStyle+    }++-- Generate an ASCII 'TableStyle' from a 'TableStyleSpec' using pluses for joins.+asciiTableStyleFromSpec :: TableStyleSpec -> TableStyle LineStyle LineStyle+asciiTableStyleFromSpec = tableStyleFromSpec asciiHorizontal asciiVertical asciiJoinString4++-- Generate an ASCII 'TableStyle' from a 'TableStyleSpec' using rounded joins.+roundedAsciiTableStyleFromSpec :: TableStyleSpec -> TableStyle LineStyle LineStyle+roundedAsciiTableStyleFromSpec = tableStyleFromSpec asciiHorizontal asciiVertical roundedAsciiJoinString4++-- Generate a unicode 'TableStyle' from a 'TableStyleSpec'.+unicodeTableStyleFromSpec :: TableStyleSpec -> TableStyle LineStyle LineStyle+unicodeTableStyleFromSpec = tableStyleFromSpec unicodeHorizontal unicodeVertical unicodeJoinString4++-- | Generate a 'TableStyle from a given 'TableStyleSpec', along with functions+-- to construct horizontal and vertical lines and joins.+-- The function for constructing join strings takes its arguments in the order+-- west, east, north, south.+tableStyleFromSpec :: (LineStyle -> String) -> (LineStyle -> String)+                   -> (LineStyle -> LineStyle -> LineStyle -> LineStyle -> String)+                   -> TableStyleSpec+                   -> TableStyle LineStyle LineStyle+tableStyleFromSpec hString vString joinString TableStyleSpec { .. }+    = TableStyle+    { headerSepH     = hString headerSep+    , headerSepLC    = joinString NoLine headerSep headerLeft groupLeft+    , headerSepRC    = joinString headerSep NoLine headerRight groupRight+    , headerSepC     = joinString headerSep headerSep+    , headerTopH     = hString headerTop+    , headerTopL     = joinString NoLine headerTop NoLine headerLeft+    , headerTopR     = joinString headerTop NoLine NoLine headerRight+    , headerTopC     = joinString headerTop headerTop NoLine+    , headerL        = vString headerLeft+    , headerR        = vString headerRight+    , headerC        = vString+    , rowHeaderSepV  = vString rowHeaderSep+    , rowHeaderSepTC = joinString rowHeaderTop groupTop NoLine rowHeaderSep+    , rowHeaderSepBC = joinString rowHeaderBottom groupBottom rowHeaderSep NoLine+    , rowHeaderSepC  = \h g -> joinString h g rowHeaderSep rowHeaderSep+    , rowHeaderLeftV = vString rowHeaderLeft+    , rowHeaderLeftT = joinString NoLine rowHeaderTop NoLine rowHeaderLeft+    , rowHeaderLeftB = joinString NoLine rowHeaderBottom rowHeaderLeft NoLine+    , rowHeaderLeftC = \h -> joinString NoLine h rowHeaderLeft rowHeaderLeft+    , rowHeaderT     = hString rowHeaderTop+    , rowHeaderB     = hString rowHeaderBottom+    , rowHeaderC     = hString+    , bothHeadersTL  = joinString NoLine bothHeadersTop NoLine bothHeadersLeft+    , bothHeadersTR  = joinString bothHeadersTop headerTop NoLine bothHeadersRight+    , bothHeadersBL  = joinString NoLine bothHeadersBottom bothHeadersLeft rowHeaderLeft+    , bothHeadersBR  = joinString bothHeadersBottom headerSep bothHeadersRight rowHeaderSep+    , bothHeadersL   = vString bothHeadersLeft+    , bothHeadersR   = vString bothHeadersRight+    , bothHeadersT   = hString bothHeadersTop+    , bothHeadersB   = hString bothHeadersBottom+    , groupL         = vString groupLeft+    , groupR         = vString groupRight+    , groupC         = vString+    , groupSepH      = hString+    , groupSepC      = \h v -> joinString h h v v+    , groupSepLC     = \h -> joinString NoLine h groupLeft groupLeft+    , groupSepRC     = \h -> joinString h NoLine groupRight groupRight+    , groupTopC      = joinString groupTop groupTop NoLine+    , groupTopL      = joinString NoLine groupTop NoLine groupLeft+    , groupTopR      = joinString groupTop NoLine NoLine groupRight+    , groupTopH      = hString groupTop+    , groupBottomC   = \v -> joinString groupBottom groupBottom v NoLine+    , groupBottomL   = joinString NoLine groupBottom groupLeft NoLine+    , groupBottomR   = joinString groupBottom NoLine groupRight NoLine+    , groupBottomH   = hString groupBottom+    }++-- | Modify a 'TableStyleSpec' to use the given 'LineStyle' for header separators.+setTableStyleSpecSeparator :: LineStyle -> TableStyleSpec -> TableStyleSpec+setTableStyleSpecSeparator sep spec =+    spec { headerSep = sep, rowHeaderSep = sep, bothHeadersBottom = sep, bothHeadersRight = sep }+ -- | My usual ASCII table style.-asciiRoundS :: TableStyle-asciiRoundS = TableStyle -            { headerSepH   = '='-            , headerSepLC  = ':'-            , headerSepRC  = ':'-            , headerSepC   = ':'-            , headerTopL   = '.'-            , headerTopR   = '.'-            , headerTopC   = '.'-            , headerTopH   = '-'-            , headerV      = '|'-            , groupV       = '|'-            , groupSepH    = '-'-            , groupSepC    = '+'-            , groupSepLC   = ':'-            , groupSepRC   = ':'-            , groupTopC    = '.'-            , groupTopL    = '.'-            , groupTopR    = '.'-            , groupTopH    = '-'-            , groupBottomC = '\''-            , groupBottomL = '\''-            , groupBottomR = '\''-            , groupBottomH = '-'-            }+asciiRoundS :: TableStyle LineStyle LineStyle+asciiRoundS = tableStyleFromSpec asciiHorizontal asciiVertical roundedAsciiJoinString4 $+    simpleTableStyleSpec SingleLine SingleLine  -- | Uses lines and plus for joints.-asciiS :: TableStyle-asciiS = TableStyle-       { headerSepH   = '-'-       , headerSepLC  = '+'-       , headerSepRC  = '+'-       , headerSepC   = '+'-       , headerTopL   = '+'-       , headerTopR   = '+'-       , headerTopC   = '+'-       , headerTopH   = '-'-       , headerV      = '|'-       , groupV       = '|'-       , groupSepH    = '-'-       , groupSepC    = '+'-       , groupSepLC   = '+'-       , groupSepRC   = '+'-       , groupTopC    = '+'-       , groupTopL    = '+'-       , groupTopR    = '+'-       , groupTopH    = '-'-       , groupBottomC = '+'-       , groupBottomL = '+'-       , groupBottomR = '+'-       , groupBottomH = '-'-       }+asciiS :: TableStyle LineStyle LineStyle+asciiS = asciiTableStyleFromSpec $ simpleTableStyleSpec SingleLine SingleLine --- | Uses special unicode characters to draw clean thin boxes. -unicodeS :: TableStyle-unicodeS = TableStyle-         { headerSepH   = '═'-         , headerSepLC  = '╞'-         , headerSepRC  = '╡'-         , headerSepC   = '╪'-         , headerTopL   = '┌'-         , headerTopR   = '┐'-         , headerTopC   = '┬'-         , headerTopH   = '─'-         , headerV      = '│'-         , groupV       = '│'-         , groupSepH    = '─'-         , groupSepC    = '┼'-         , groupSepLC   = '├'-         , groupSepRC   = '┤'-         , groupTopC    = '┬'-         , groupTopL    = '┌'-         , groupTopR    = '┐'-         , groupTopH    = '─'-         , groupBottomC = '┴'-         , groupBottomL = '└'-         , groupBottomR = '┘'-         , groupBottomH = '─'-         }+-- | Like 'asciiS', but uses double lines and double pluses for borders.+asciiDoubleS :: TableStyle LineStyle LineStyle+asciiDoubleS = asciiTableStyleFromSpec $ simpleTableStyleSpec DoubleLine SingleLine +-- | Uses special unicode characters to draw clean thin boxes.+unicodeS :: TableStyle LineStyle LineStyle+unicodeS = unicodeTableStyleFromSpec . setTableStyleSpecSeparator DoubleLine $+    simpleTableStyleSpec SingleLine SingleLine+ -- | Same as 'unicodeS' but uses bold headers.-unicodeBoldHeaderS :: TableStyle-unicodeBoldHeaderS = unicodeS-                   { headerSepH  = '━'-                   , headerSepLC = '┡'-                   , headerSepRC = '┩'-                   , headerSepC  = '╇'-                   , headerTopL  = '┏'-                   , headerTopR  = '┓'-                   , headerTopC  = '┳'-                   , headerTopH  = '━'-                   , headerV     = '┃'-                   }+unicodeBoldHeaderS :: TableStyle LineStyle LineStyle+unicodeBoldHeaderS = inheritStyleHeaderGroup makeLineBold id makeLineBold id .+    unicodeTableStyleFromSpec $ simpleTableStyleSpec HeavyLine SingleLine --- | Same as 'unicodeS' but uses round edges.-unicodeRoundS :: TableStyle-unicodeRoundS = unicodeS-              { groupTopL    = roundedTL-              , groupTopR    = roundedTR-              , groupBottomL = roundedBL-              , groupBottomR = roundedBR-              , headerTopL   = roundedTL-              , headerTopR   = roundedTR-              }-  where-    roundedTL = '╭'-    roundedTR = '╮'-    roundedBL = '╰'-    roundedBR = '╯'+-- | Like 'unicodeS' but with rounded edges.+unicodeRoundS :: TableStyle LineStyle LineStyle+unicodeRoundS = withRoundCorners unicodeS  -- | Uses bold lines.-unicodeBoldS :: TableStyle-unicodeBoldS = TableStyle-             { headerSepH   = '━'-             , headerSepLC  = '┣'-             , headerSepRC  = '┫'-             , headerSepC   = '╋'-             , headerTopL   = '┏'-             , headerTopR   = '┓'-             , headerTopC   = '┳'-             , headerTopH   = '━'-             , headerV      = '┃'-             , groupV       = '┃'-             , groupSepH    = '━'-             , groupSepC    = '╋'-             , groupSepLC   = '┣'-             , groupSepRC   = '┫'-             , groupTopC    = '┳'-             , groupTopL    = '┏'-             , groupTopR    = '┓'-             , groupTopH    = '━'-             , groupBottomC = '┻'-             , groupBottomL = '┗'-             , groupBottomR = '┛'-             , groupBottomH = '━'-             }+unicodeBoldS :: TableStyle LineStyle LineStyle+unicodeBoldS = unicodeTableStyleFromSpec $ simpleTableStyleSpec HeavyLine HeavyLine --- | Uses bold lines with exception of group seperators, which are striped slim.-unicodeBoldStripedS :: TableStyle-unicodeBoldStripedS = unicodeBoldS { groupSepH = '-', groupSepC = '┃', groupSepLC = '┃', groupSepRC = '┃' }+-- | Uses bold lines with the exception of group separators, which are striped.+unicodeBoldStripedS :: TableStyle LineStyle LineStyle+unicodeBoldStripedS = unicodeBoldS+                    { groupSepLC = const $ unicodeVertical HeavyLine+                    , groupSepRC = const $ unicodeVertical HeavyLine+                    , groupSepC  = const unicodeVertical+                    }  -- | Draw every line with a double frame.-unicodeDoubleFrameS :: TableStyle-unicodeDoubleFrameS = TableStyle-                    { headerSepH   = '═'-                    , headerSepLC  = '╠'-                    , headerSepRC  = '╣'-                    , headerSepC   = '╬'-                    , headerTopL   = '╔'-                    , headerTopR   = '╗'-                    , headerTopC   = '╦'-                    , headerTopH   = '═'-                    , headerV      = '║'-                    , groupV       = '║'-                    , groupSepH    = '═'-                    , groupSepC    = '╬'-                    , groupSepLC   = '╠'-                    , groupSepRC   = '╣'-                    , groupTopC    = '╦'-                    , groupTopL    = '╔'-                    , groupTopR    = '╗'-                    , groupTopH    = '═'-                    , groupBottomC = '╩'-                    , groupBottomL = '╚'-                    , groupBottomR = '╝'-                    , groupBottomH = '═'-                    }+unicodeDoubleFrameS :: TableStyle LineStyle LineStyle+unicodeDoubleFrameS = unicodeTableStyleFromSpec $ simpleTableStyleSpec DoubleLine DoubleLine
src/Text/Layout/Table/Vertical.hs view
@@ -17,21 +17,21 @@ {- | Merges multiple columns together to a valid grid without holes. For example:  >>> colsAsRowsAll top [justifyText 10 "This text will not fit on one line.", ["42", "23"]]-[["This  text","42"],["will   not","23"],["fit on one",""],["line.",""]]+[[Just "This  text",Just "42"],[Just "will   not",Just "23"],[Just "fit on one",Nothing],[Just "line.",Nothing]]  The result is intended to be used with a grid layout function like 'Text.Layout.Table.grid'. -}-colsAsRowsAll :: Monoid a => Position V -> [Col a] -> [Row a]-colsAsRowsAll ps = transpose . vPadAll mempty ps+colsAsRowsAll :: Position V -> [Col a] -> [Row (Maybe a)]+colsAsRowsAll p = transpose . vPadAll Nothing p . fmap (fmap Just)  {- | Works like 'colsAsRowsAll' but every position can be specified on its    own:  >>> colsAsRows [top, center, bottom] [["a1"], ["b1", "b2", "b3"], ["c3"]]-[["a1","b1",""],["","b2",""],["","b3","c3"]]+[[Just "a1",Just "b1",Nothing],[Nothing,Just "b2",Nothing],[Nothing,Just "b3",Just "c3"]] -}-colsAsRows :: Monoid a => [Position V] -> [Col a] -> [Row a]-colsAsRows ps = transpose . vPad mempty ps+colsAsRows :: [Position V] -> [Col a] -> [Row (Maybe a)]+colsAsRows ps = transpose . vPad Nothing ps . fmap (fmap Just)  -- | Fill all columns to the same length by aligning at the given position. vPadAll :: a -> Position V -> [Col a] -> [Col a]
table-layout.cabal view
@@ -6,7 +6,7 @@ -- PVP summary:      +-+------- breaking API changes --                   | | +----- non-breaking API additions --                   | | | +--- code changes with no API change-version:             0.9.1.0+version:             1.0.0.0  synopsis:            Format tabular data as grid or table. @@ -55,7 +55,9 @@   exposed-modules:     Text.Layout.Table,                        Text.Layout.Table.Cell,                        Text.Layout.Table.Cell.Formatted,+                       Text.Layout.Table.Cell.WideString,                        Text.Layout.Table.Justify,+                       Text.Layout.Table.LineStyle,                        Text.Layout.Table.Style,                        Text.Layout.Table.Vertical,                        Text.Layout.Table.StringBuilder,@@ -65,6 +67,7 @@                        -- Will be moved into another package in the future.                        Text.Layout.Table.Primitives.AlignInfo,                        Text.Layout.Table.Primitives.Basic,+                       Text.Layout.Table.Primitives.CellMod,                        Text.Layout.Table.Primitives.ColumnModifier,                        Text.Layout.Table.Primitives.Header,                        Text.Layout.Table.Primitives.Table,@@ -77,6 +80,7 @@                        Text.Layout.Table.Spec.OccSpec,                        Text.Layout.Table.Spec.Position,                        Text.Layout.Table.Spec.RowGroup,+                       Text.Layout.Table.Spec.TableSpec,                        Text.Layout.Table.Spec.Util   other-modules: @@ -89,9 +93,10 @@                        MultiWayIf      -- Other library packages from which modules are imported.-  build-depends:       base >=4.9 && <4.15,-                       data-default-class >=0.1.1 && < 0.2,-                       data-default-instances-base ==0.1.*+  build-depends:       base >=4.9 && <4.19,+                       data-default-class >=0.1.2 && < 0.2,+                       doclayout >=0.3 && <0.5,+                       text    hs-source-dirs:      src   @@ -100,19 +105,23 @@  executable table-layout-test-styles   main-is:             Test.hs-  build-depends:       base >=4.9 && <4.15,-                       data-default-class >=0.1.1 && < 0.2,-                       data-default-instances-base ==0.1.*+  build-depends:       base >=4.9 && <4.19,+                       data-default-class >=0.1.2 && < 0.2,+                       doclayout >=0.3 && <0.5,+                       text   hs-source-dirs:      src   other-modules:       Text.Layout.Table,                        Text.Layout.Table.Cell,                        Text.Layout.Table.Cell.Formatted,+                       Text.Layout.Table.Cell.WideString,                        Text.Layout.Table.Justify,+                       Text.Layout.Table.LineStyle,                        Text.Layout.Table.Style,                        Text.Layout.Table.Vertical                         Text.Layout.Table.Primitives.AlignInfo,                        Text.Layout.Table.Primitives.Basic,+                       Text.Layout.Table.Primitives.CellMod,                        Text.Layout.Table.Primitives.ColumnModifier,                        Text.Layout.Table.Primitives.Header,                        Text.Layout.Table.Primitives.Table,@@ -127,6 +136,7 @@                        Text.Layout.Table.Spec.OccSpec,                        Text.Layout.Table.Spec.Position,                        Text.Layout.Table.Spec.RowGroup,+                       Text.Layout.Table.Spec.TableSpec,                        Text.Layout.Table.Spec.Util    default-language:    Haskell2010@@ -135,11 +145,12 @@   type:                exitcode-stdio-1.0   hs-source-dirs:      test-suite, src   main-is:             Spec.hs-  build-depends:       base >=4.9 && <4.15,-                       QuickCheck >=2.8 && < 2.14,+  build-depends:       base >=4.9 && <4.19,+                       QuickCheck >=2.8 && < 2.15,                        HUnit >=1.3,-                       data-default-class >=0.1.1 && < 0.2,-                       data-default-instances-base ==0.1.*,+                       data-default-class >=0.1.2 && < 0.2,+                       doclayout >=0.3 && <0.5,+                       text,                        hspec    other-modules:       TestSpec,@@ -148,12 +159,15 @@                         Text.Layout.Table.Cell,                        Text.Layout.Table.Cell.Formatted,+                       Text.Layout.Table.Cell.WideString,                        Text.Layout.Table.Justify,+                       Text.Layout.Table.LineStyle,                        Text.Layout.Table.Style,                        Text.Layout.Table.Vertical                         Text.Layout.Table.Primitives.AlignInfo,                        Text.Layout.Table.Primitives.Basic,+                       Text.Layout.Table.Primitives.CellMod,                        Text.Layout.Table.Primitives.ColumnModifier,                        Text.Layout.Table.Primitives.Header,                        Text.Layout.Table.Primitives.Table,@@ -168,6 +182,7 @@                        Text.Layout.Table.Spec.OccSpec,                        Text.Layout.Table.Spec.Position,                        Text.Layout.Table.Spec.RowGroup,+                       Text.Layout.Table.Spec.TableSpec,                        Text.Layout.Table.Spec.Util    default-language:    Haskell2010
test-suite/TestSpec.hs view
@@ -4,16 +4,76 @@  -- TODO idempotency of fitting CMIs +import qualified Data.Text as T++import Data.Maybe (listToMaybe)+import Data.List (isInfixOf)+import Text.DocLayout (charWidth)+ import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck  import Text.Layout.Table-import Text.Layout.Table.Cell (determineCuts, CutInfo(..), determineCutAction, CutAction(..), applyCutInfo, viewRange)+import Text.Layout.Table.Cell (Cell(..), CutAction(..), CutInfo(..), applyCutInfo, determineCutAction, determineCuts, dropLeft, dropRight, viewRange, buildCellMod)+import Text.Layout.Table.Cell.WideString (WideString(..), WideText(..))+import Text.Layout.Table.Spec.AlignSpec+import Text.Layout.Table.Spec.CutMark import Text.Layout.Table.Spec.OccSpec+import Text.Layout.Table.Spec.Position+import Text.Layout.Table.Spec.RowGroup import Text.Layout.Table.Primitives.Basic+import Text.Layout.Table.Primitives.AlignInfo import Text.Layout.Table.Justify+import Text.Layout.Table.Cell.Formatted ++-- A newtype wrapper around 'String', allowing an 'Arbitrary' instance which+-- guarantees the width of each character is exactly one.+newtype NonControlASCIIString = NonControlASCIIString String+  deriving (Eq, Ord, Show)++-- Generate only non-control characters within the ASCII range+-- (see https://en.wikipedia.org/wiki/Control_character).+instance Arbitrary NonControlASCIIString where+  arbitrary = NonControlASCIIString <$> listOf (chooseEnum ('\32', '\126'))+  shrink (NonControlASCIIString xs) = NonControlASCIIString <$> shrink xs++instance Arbitrary (Position o) where+    arbitrary = elements [Start, End, Center]+    shrink Center = [Start, End]+    shrink End    = [Start]+    shrink Start  = []++instance Arbitrary AlignSpec where+    arbitrary = oneof [pure noAlign, charAlign <$> arbitrary]+    shrink NoAlign = []+    shrink _ = [NoAlign]++forAllAlign :: Testable prop => (AlignSpec -> prop) -> Property+forAllAlign = forAllShrinkShow arbitrary shrink showAlign . (. maybe NoAlign charAlign)+  where+    showAlign Nothing = "NoAlign"+    showAlign (Just c) = "align at " ++ show c++instance Arbitrary CutMark where+    arbitrary = elements [noCutMark, def, customCM, unevenCM]+    shrink x | x == noCutMark = []+             | x == def       = [noCutMark]+             | otherwise      = [noCutMark, def]++customCM, unevenCM :: CutMark+customCM = doubleCutMark "<.." "..>"+unevenCM = doubleCutMark "<" "-->"++occS     = predOccSpec (== ':')+hposG    = elements [left, center, right]++-- Arbitrary instance of WideString needs to exclude combining characters at the start+instance Arbitrary WideString where+    arbitrary = fmap WideString $ arbitrary `suchThat` (maybe True ((0 /=) . charWidth) . listToMaybe)+    shrink (WideString x) = map WideString $ shrink x+ spec :: Spec spec = do     describe "fill" $ do@@ -49,19 +109,35 @@         prop "right" propPadRight         prop "center" propPadCenter +    describe "trim" $ do+        prop "left" $ propTrim left noCutMark+        prop "left with cut mark" $ propTrim left customCM+        prop "right" $ propTrim right noCutMark+        prop "right with cut mark" $ propTrim right customCM+        prop "center" $ propTrim center noCutMark+        prop "center with cut mark" $ propTrim center customCM++        describe "trimmed cut mark" $ do+            let trim' p = buildCellMod customCM $ trim p customCM 1 "aa"+            it "right" $ trim' left  `shouldBe` ">"+            it "left" $ trim' right `shouldBe` "<"+     describe "trimOrPad" $ do+        let trimOrPad' p cm n s = buildCellMod cm $ trimOrPad p cm n s+        let pad' p n s = buildCellMod noCutMark $ pad p n s         prop "pad" $ forAll hposG $ \p s (Positive (Small n)) ->-            length (s :: String) > n || trimOrPad p noCutMark n s == (pad p n s :: String)-        it "left" $ trimOrPad left customCM 5 "1234567890" `shouldBe` "12..>"-        it "right" $ trimOrPad right customCM 5 "1234567890" `shouldBe` "<..90"-        it "center" $ trimOrPad center customCM 8 "1234567890" `shouldBe` "<..56..>"-        it "center one sided" $ trimOrPad center customCM 9 "1234567890" `shouldBe` "<..567890"+            length (s :: String) > n || trimOrPad' p noCutMark n s == (pad' p n s :: String)+        it "left" $ trimOrPad' left customCM 5 "1234567890" `shouldBe` "12..>"+        it "right" $ trimOrPad' right customCM 5 "1234567890" `shouldBe` "<..90"+        it "center" $ trimOrPad' center customCM 8 "1234567890" `shouldBe` "<..56..>"+        it "center one sided" $ trimOrPad' center customCM 9 "1234567890" `shouldBe` "<..567890"      describe "align" $ do         let ai = deriveAlignInfo occS "abc:42"-        it "ex1" $ align occS ai "c:4" `shouldBe` "  c:4 "-        it "ex2" $ align occS ai "x" `shouldBe`   "  x   "-        it "ex3" $ align occS ai ":x" `shouldBe`  "   :x "+        let align' s = buildCellMod noCutMark (align occS ai s) :: String+        it "ex1" $ align' "c:4" `shouldBe` "  c:4 "+        it "ex2" $ align' "x" `shouldBe`   "  x   "+        it "ex3" $ align' ":x" `shouldBe`  "   :x "      describe "determineCuts" $ do         describe "cases" $ do@@ -82,9 +158,10 @@         it "actual width has more than required" $ determineCutAction 4 6 `shouldBe` CutCA 2      describe "applyCutInfo" $ do-        let apply ci = applyCutInfo ci customCM 5 11 "abcde:12345" :: String-            apply2 ci s = applyCutInfo ci customCM 5 (length s) s :: String-            apply3 ci n s = applyCutInfo ci customCM n (length s) s :: String+        let apply ci = buildCellMod customCM (applyCutInfo ci customCM 5 11 "abcde:12345") :: String+            apply2 ci s = buildCellMod customCM (applyCutInfo ci customCM 5 (length s) s) :: String+            apply3 ci n s = buildCellMod customCM (applyCutInfo ci customCM n (length s) s) :: String+            apply4 ca s = buildCellMod unevenCM (applyCutInfo ca unevenCM 5 (length s) s) :: String         --                                     "<...>"         it "double cut" $ apply (SidesCI (CutCA 3) (CutCA 3)) `shouldBe` "<...>"         it "left cut" $ apply (SidesCI (CutCA 6) NoneCA) `shouldBe` "<..45"@@ -100,8 +177,8 @@         it "mark left 2" $ apply3 MarkLeftCI 2 "" `shouldBe` "<."         it "mark left 3" $ apply3 MarkLeftCI 4 "a" `shouldBe` "<.. " -        it "uneven mark left" $ applyCutInfo MarkLeftCI unevenCM 5 5 "12345" `shouldBe` "<    "-        it "uneven mark right" $ applyCutInfo MarkRightCI unevenCM 5 5 "12345" `shouldBe` "  -->"+        it "uneven mark left" $ apply4 MarkLeftCI "12345" `shouldBe` "<    "+        it "uneven mark right" $ apply4 MarkRightCI "12345" `shouldBe` "  -->"      describe "viewRange" $ do         -- "     :     "@@ -121,9 +198,9 @@     describe "alignFixed" $ do         -- 5 spaces on each side.         let ai               = deriveAlignInfo occS "     :     "-            alignFixed' p l  = alignFixed p customCM l occS ai+            alignFixed' p l  = buildCellMod customCM . alignFixed p customCM l occS ai             ai2              = deriveAlignInfo occS "       :   "-            alignFixed2' p l = alignFixed p customCM l occS ai2+            alignFixed2' p l = buildCellMod customCM . alignFixed p customCM l occS ai2         it "left 1" $ alignFixed' left 6 "ab:42" `shouldBe` "   ..>"         it "left 2" $ alignFixed' left 6 "abcd:42" `shouldBe` " ab..>" @@ -171,6 +248,129 @@         describe "concatPadLine" $ do             it "even" $ concatPadLine 9 (Line 9 3 ["It", "is", "on"]) `shouldBe` "It is on"             it "odd" $ concatPadLine 13 (Line 11 4 ["It", "is", "on", "us"]) `shouldBe` "It  is on  us"++    describe "grid" . modifyMaxSuccess (const 1000) $ do+        let wide   = "A long string"+            narrow = "Short"+        describe "expand" $ do+            prop "for String"     $ propExpand id noAlign+            prop "for WideString" $ propExpand WideString noAlign+        describe "fixed" $ do+            prop "for String"     $ propFixed id noAlign+            prop "for WideString" $ propFixed WideString noAlign+        describe "expandUntil" $ do+            prop "for String"     $ propExpandUntil id noAlign+            prop "for WideString" $ propExpandUntil WideString noAlign+            let col pos i = column (expandUntil i) pos noAlign noCutMark+            it "when dropping from the right" $+                grid [col left 8]  [[wide], [narrow]] `shouldBe` [["A long s"], ["Short   "]]+            it "when dropping from the left" $+                grid [col right 8] [[wide], [narrow]] `shouldBe` [["g string"], ["   Short"]]+        describe "fixedUntil" $ do+            prop "for String"     $ propFixedUntil id noAlign+            prop "for WideString" $ propFixedUntil WideString noAlign+        describe "expandBetween" $ do+            prop "for String"     $ propExpandBetween id noAlign+            prop "for WideString" $ propExpandBetween WideString noAlign++    describe "formatted text" $ do+        let exampleF = formatted "XXX" (plain "Hello" <> formatted "Z" (plain "there") "W") "YYY"+        describe "rendering" $ do+            it "plain" $ buildCell (plain "Hello") `shouldBe` "Hello"+            it "formatted" $ buildCell (formatted "XXX" (plain "Hello") "YYY") `shouldBe` "XXXHelloYYY"+            it "concatenation of formatted" $ buildCell exampleF `shouldBe` "XXXHelloZthereWYYY"+        describe "dropLeft" $ do+            it "drops 0" $ buildCell (dropLeft 0 exampleF) `shouldBe` "XXXHelloZthereWYYY"+            it "drops 3" $ buildCell (dropLeft 3 exampleF) `shouldBe` "XXXloZthereWYYY"+            it "drops 8" $ buildCell (dropLeft 8 exampleF) `shouldBe` "XXXZreWYYY"+            it "drops 20" $ buildCell (dropLeft 20 exampleF) `shouldBe` "XXXZWYYY"+        describe "dropRight" $ do+            it "drops 0" $ buildCell (dropRight 0 exampleF) `shouldBe` "XXXHelloZthereWYYY"+            it "drops 3" $ buildCell (dropRight 3 exampleF) `shouldBe` "XXXHelloZthWYYY"+            it "drops 8" $ buildCell (dropRight 8 exampleF) `shouldBe` "XXXHeZWYYY"+            it "drops 20" $ buildCell (dropRight 20 exampleF) `shouldBe` "XXXZWYYY"+        describe "visibleLength" $ do+            it "plain" $ visibleLength (plain "Hello") `shouldBe` 5+            it "formatted" $ visibleLength exampleF `shouldBe` 10+        describe "measureAlignment" $ do+            it "finds e" $ measureAlignmentAt 'e' exampleF `shouldBe` AlignInfo 1 (Just 8)+            it "finds h" $ measureAlignmentAt 'h' exampleF `shouldBe` AlignInfo 6 (Just 3)+            it "doesn't find q" $ measureAlignmentAt 'q' exampleF `shouldBe` AlignInfo 10 Nothing++    describe "wide string" $ do+        let wide = WideString "㐀㐁㐂"+            narrow = WideString "Bien sûr!"+        describe "buildCell" $ do+            prop "agrees for ascii strings" $ \(NonControlASCIIString x) -> buildCell (WideString x) `shouldBe` x+            it "renders double width" $ buildCell wide `shouldBe` "㐀㐁㐂"+            it "renders zero width" $ buildCell narrow `shouldBe` "Bien sûr!"+        describe "visibleLength" $ do+            prop "agrees for ascii strings" $ \(NonControlASCIIString x) -> visibleLength (WideString x) `shouldBe` visibleLength x+            it "detects double width" $ visibleLength wide `shouldBe` 6+            it "detects zero width" $ visibleLength narrow `shouldBe` 9+        describe "measureAlignment" $ do+            prop "agrees for ascii strings" $ \(NonControlASCIIString x) -> measureAlignmentAt 'e' (WideString x) `shouldBe` measureAlignment (=='e') x+            it "detects double width" $ measureAlignmentAt '㐁' wide `shouldBe` AlignInfo 2 (Just 2)+            it "fails to detect" $ measureAlignmentAt 'a' wide `shouldBe` AlignInfo 6 Nothing+            it "detects zero width after" $ measureAlignmentAt 'n' narrow `shouldBe` AlignInfo 3 (Just 5)+            it "detects zero width before" $ measureAlignmentAt 'r' narrow `shouldBe` AlignInfo 7 (Just 1)+        describe "dropLeft" $ do+            prop "agrees for ascii strings" $ \(Small n) (NonControlASCIIString x) -> buildCell (dropLeft n (WideString x)) `shouldBe` (buildCell (dropLeft n x) :: String)+            describe "on wide characters" $ do+                it "drops 1 character of double width" $ buildCell (dropLeft 2 wide) `shouldBe` "㐁㐂"+                it "drops 2 characters of double width and adds a space" $ buildCell (dropLeft 3 wide) `shouldBe` " 㐂"+            describe "on narrow characters" $ do+                it "drops combining characters with their previous" $ buildCell (dropLeft 7 narrow) `shouldBe` "r!"+                it "drops combining characters after a dropped wide character which overshoots" $ buildCell (dropLeft 1 (WideString "㐀̈㐁")) `shouldBe` " 㐁"+        describe "dropRight" $ do+            prop "agrees for ascii strings" $ \(Small n) (NonControlASCIIString x) -> buildCell (dropRight n (WideString x)) `shouldBe` (buildCell (dropRight n x) :: String)+            describe "on wide characters" $ do+                it "drops 1 character of double width" $ buildCell (dropRight 2 wide) `shouldBe` "㐀㐁"+                it "drops 2 characters of double width and adds a space" $ buildCell (dropRight 3 wide) `shouldBe` "㐀 "+            describe "on narrow characters" $ do+                it "drops a combining character for free" $ buildCell (dropRight 3 narrow) `shouldBe` "Bien s"+                it "does not drop a combining character without their previous" $ buildCell (dropRight 2 narrow) `shouldBe` "Bien sû"++    describe "wide text" $ do+        describe "buildCell" $ do+            prop "gives the same result as wide string" $ \x -> buildCell (WideText $ T.pack x) `shouldBe` x+        describe "visibleLength" $ do+            prop "gives the same result as wide string" $ \x -> visibleLength (WideText $ T.pack x) `shouldBe` visibleLength (WideString x)+        describe "measureAlignment" $ do+            prop "gives the same result as wide string" $ \x -> measureAlignment (=='e') (WideText $ T.pack x) `shouldBe` measureAlignment (=='e') (WideString x)+        describe "dropLeft" $ do+            prop "gives the same result as wide string" $ \(Small n) x -> buildCell (dropLeft n . WideText $ T.pack x) `shouldBe` (buildCell . dropLeft n $ WideString x :: String)+        describe "dropRight" $ do+            prop "gives the same result as wide string" $ \(Small n) x -> buildCell (dropRight n . WideText $ T.pack x) `shouldBe` (buildCell . dropRight n $ WideString x :: String)++    describe "row groups" $ do+        describe "rowGroupShape" $ do+            it "multi" $ rowGroupShape (MultiRowGroup [[0, 1], [2, 3]]) `shouldBe` [(), ()]+            it "multi only first row 1" $ rowGroupShape (MultiRowGroup [[0, 1], [2, 3, 4]]) `shouldBe` [(), ()]+            it "multi only first row 2" $ rowGroupShape (MultiRowGroup [[0, 1], []]) `shouldBe` [(), ()]+            it "multi empty" $ rowGroupShape (MultiRowGroup []) `shouldBe` []+            it "singleton empty" $ rowGroupShape (SingletonRowGroup []) `shouldBe` []+            it "singleton" $ rowGroupShape (SingletonRowGroup [1, 2]) `shouldBe` [(), ()]+            it "nullable empty" $ rowGroupShape (NullableRowGroup []) `shouldBe` []+            it "nullable one element" $ rowGroupShape (NullableRowGroup [[Just 4]]) `shouldBe` [()]+            it "nullable but no null" $ rowGroupShape (NullableRowGroup [[Just 1, Just 2]]) `shouldBe` [(), ()]+            it "nullable mixed" $ rowGroupShape (NullableRowGroup [[Just 1, Nothing, Nothing]]) `shouldBe` [(), (), ()]++        let rgs = [rg1, rg2, rg3] :: [RowGroup Int]+            rg1 = MultiRowGroup [[0, 1, 2], [3, 4, 5]]+            rg2 = SingletonRowGroup [6, 7, 8]+            rg3 = NullableRowGroup [[Nothing, Just 9, Nothing]]+        it "transposeRowGroups" $+            transposeRowGroups rgs `shouldBe` [ SegmentedColumn [ColumnSegment [0, 3], SingleValueSegment 6, NullableColumnSegment [Nothing]]+                                              , SegmentedColumn [ColumnSegment [1, 4], SingleValueSegment 7, NullableColumnSegment [Just 9]]+                                              , SegmentedColumn [ColumnSegment [2, 5], SingleValueSegment 8, NullableColumnSegment [Nothing]]+                                              ]+        describe "mapRowGroupColumns" $ do+            let mappers = [(negate 1, (+ 1)), (0, (* 2)), (negate 2, (`div` 2))]+            it "multi" $ mapRowGroupColumns mappers rg1 `shouldBe` [[1, 2, 1], [4, 8, 2]]+            it "singleton" $ mapRowGroupColumns mappers rg2 `shouldBe` [[7, 14, 4]]+            it "nullable" $ mapRowGroupColumns mappers rg3 `shouldBe` [[negate 1, 18, negate 2]]+   where     customCM = doubleCutMark "<.." "..>"     unevenCM = doubleCutMark "<" "-->"@@ -181,21 +381,92 @@     propPadLeft :: String -> Positive (Small Int) -> Bool     propPadLeft s (Positive (Small n)) =         let len    = length s-            padded = pad left n s+            padded = buildCellMod noCutMark $ pad left n s         in len >= n || (take len padded == s && all (== ' ') (drop len padded))      propPadRight :: String -> Positive (Small Int) -> Bool     propPadRight s (Positive (Small n)) =         let len    = length s-            padded = pad right n s+            padded = buildCellMod noCutMark $ pad right n s         in len >= n || (drop (n - len) padded == s                         && all (== ' ') (take (n - len) padded))      propPadCenter :: String -> Positive (Small Int) -> Bool     propPadCenter s (Positive (Small n)) =         let len      = length s-            padded   = pad center n s+            padded   = buildCellMod noCutMark $ pad center n s             (q, r)   = (n - len) `divMod` 2             trimLeft = drop q padded         in len >= n || (all (== ' ') (take q padded) && take len trimLeft == s                         && drop len trimLeft == replicate (q + r) ' ')++    propTrim :: Position o -> CutMark -> String -> Positive (Small Int) -> Bool+    propTrim pos cm s (Positive (Small n)) =+        let len = length s+            trimmed = buildCellMod cm (trim pos cm n s) :: String+            cutMarkTooLong = case pos of+                Start  -> n < length (rightMark cm)+                End    -> n < length (leftMark cm)+                Center -> n < length (rightMark cm) + length (leftMark cm)+        in cutMarkTooLong || if len > n+           then length trimmed == n+           else trimmed == s++    gridPropHelper :: (Cell a, Testable prop) => ColSpec -> (String -> a) -> [a] -> (Int -> prop) -> Property+    gridPropHelper col f xs isRightLength =+        allRowsHaveRightLength (grid [col] $ map pure xs) .||. anyRowHasPathologicalUnicode xs+      where+        allRowsHaveRightLength = conjoin . map (conjoin . map (isRightLength . visibleLength . f))+        anyRowHasPathologicalUnicode = disjoin . map (hasPathologicalUnicode . buildCell)++    propExpand :: Cell a => (String -> a) -> AlignSpec -> Position H -> CutMark+               -> NonEmptyList a -> Property+    propExpand f align pos cm (NonEmpty xs) =+        let col = column expand pos align cm+            len = maximum $ map visibleLength xs+        in gridPropHelper col f xs (=== len)++    propFixed :: Cell a => (String -> a) -> AlignSpec -> Position H -> CutMark+              -> Positive (Small Int) -> NonEmptyList a -> Property+    propFixed f align pos cm (Positive (Small n)) (NonEmpty xs) =+        let col = column (fixed n) pos align cm+        in gridPropHelper col f xs (=== n)++    propExpandUntil :: Cell a => (String -> a) -> AlignSpec -> Position H -> CutMark+                    -> Positive (Small Int) -> NonEmptyList a -> Property+    propExpandUntil f align pos cm (Positive (Small n)) (NonEmpty xs) =+        let col = column (expandUntil n) pos align cm+            len = maximum $ map visibleLength xs+        in cover 10 (len <= n) "shorter than limit" . cover 10 (len > n)  "longer than limit" $+               gridPropHelper col f xs (=== min len n)++    propFixedUntil :: Cell a => (String -> a) -> AlignSpec -> Position H -> CutMark+                   -> Positive (Small Int) -> NonEmptyList a -> Property+    propFixedUntil f align pos cm (Positive (Small n)) (NonEmpty xs) =+        let col = column (fixedUntil n) pos align cm+            len = maximum $ map visibleLength xs+        in cover 10 (len <= n) "shorter than limit" . cover 10 (len > n)  "longer than limit" $+               gridPropHelper col f xs (=== max len n)++    propExpandBetween :: Cell a => (String -> a) -> AlignSpec -> Position H -> CutMark+                      -> Positive (Small Int) -> Positive (Small Int) -> NonEmptyList a -> Property+    propExpandBetween f align pos cm (Positive (Small m)) (Positive (Small n)) (NonEmpty xs) =+        let col = column (expandBetween (min m n) (max m n)) pos align cm+            len = maximum $ map visibleLength xs+            b = min m n+            t = max m n+        in cover 10 (len <= b) "shorter than limit" . cover 10 (len > t)  "longer than limit" .+           cover 10 (len > b && len <= t) "between limits" $+               gridPropHelper col f xs (=== max b (min t len))++    -- A keypad character followed by a zero-width join or variation selector+    -- will cause tests to fail, but this is pathological Unicode and failure+    -- is acceptable.+    hasPathologicalUnicode :: String -> Bool+    hasPathologicalUnicode test = or $ do+        k <- '#' : '*' : ['0'..'9']+        v <- ['\8205', '\65039']+        return $ [k, v] `isInfixOf` test++    measureAlignmentAt :: Cell a => Char -> a -> AlignInfo+    measureAlignmentAt c = measureAlignment (== c)