packages feed

rainbox 0.4.0.4 → 0.26.0.0

raw patch · 33 files changed

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014, Omari Norman+Copyright (c) 2014 - 2020 Omari Norman  All rights reserved.
README.md view
@@ -4,46 +4,23 @@ Provides pretty printing of boxes in two dimensions.  Rainbox is useful for console programs that need to format tabular data. +On Hackage+==========++https://hackage.haskell.org/package/rainbox+ Documentation =============  In addition to the Haddock documentation, a tutorial is available in-[the Rainbox.Tutorial module](lib/Rainbox/Tutorial.lhs).  This-module is best read in your text editor or through the Github web-interface, as it is written in literate Haskell, which HsColour does-not fare so well with.+[the Rainbox.Tutorial module](lib/Rainbox/Tutorial.hs).  Portability ===========  There's nothing unportable in Rainbox; however, it does use-[Rainbow](http://hackage.haskell.org/package/rainbow) which works-only on UNIX-like systems because it uses the UNIX terminfo library.-I only develop for UNIX-like systems because they are the only ones-I use.--Tests-=====--You can simply use "cabal test".  However, I recommend that you do:--    cabal configure --enable-tests-    cabal build-    dist/build/rainbox-test/rainbox-test-    dist/build/rainbox-visual/rainbox-visual--The last test, `rainbox-visual`, relies on you to examine the output-and make sure it looks correct.--Tests are also run on Travis:--[![Build Status](https://travis-ci.org/massysett/rainbox.svg?branch=master)](https://travis-ci.org/massysett/rainbox)--and although you can see the output of `rainbox-visual` there, it's-not formatted quite right on Travis.--At this time, Rainbox is verified to work with GHC versions 7.4.1,-7.6.3, and 7.8.2.+[Rainbow](http://hackage.haskell.org/package/rainbow) which is only+tested on UNIX-like systems.  License =======
changelog view
@@ -1,11 +1,7 @@-0.4.0.2--  * lower array dependendy to 0.4.0.0; this is the version that shipped-    with GHC 7.4.1+v0.22.0.0 -0.4.0.0+* Changes to conform to rainbow-0.32.0.0 -  * update for newer version of rainbow, where each Chunk has a list of Text-  rather than a single Text+v0.20.0.0 -  * test with GHC 7.8.2+* Made updates to monoid for base-4.11
− current-versions.txt 
@@ -1,60 +0,0 @@-This package was tested to work with these dependency-versions and compiler version.-These are the default versions fetched by cabal install.-Tested as of: 2014-06-14 02:31:26.107979 UTC-Path to compiler: ghc-7.8.2-Compiler description: 7.8.2--/opt/ghc/7.8.2/lib/ghc-7.8.2/package.conf.d:-    Cabal-1.18.1.3-    array-0.5.0.0-    base-4.7.0.0-    bin-package-db-0.0.0.0-    binary-0.7.1.0-    rts-1.0-    bytestring-0.10.4.0-    containers-0.5.5.1-    deepseq-1.3.0.2-    directory-1.2.1.0-    filepath-1.3.0.2-    (ghc-7.8.2)-    ghc-prim-0.3.1.0-    (haskell2010-1.1.2.0)-    (haskell98-2.0.0.3)-    hoopl-3.10.0.1-    hpc-0.6.0.1-    integer-gmp-0.5.1.0-    old-locale-1.0.0.6-    old-time-1.1.0.2-    pretty-1.1.1.1-    process-1.2.0.0-    template-haskell-2.9.0.0-    time-1.4.2-    transformers-0.3.0.0-    unix-2.7.0.1--/home/massysett/rainbox/sunlight-8257/db:-    QuickCheck-2.7.5-    ansi-terminal-0.6.1.1-    ansi-wl-pprint-0.6.7.1-    async-2.0.1.5-    mtl-2.2.1-    optparse-applicative-0.9.0-    parsec-3.1.5-    primitive-0.5.3.0-    rainbow-0.14.0.2-    rainbox-0.4.0.4-    random-1.0.1.1-    regex-base-0.93.2-    regex-tdfa-1.2.0-    stm-2.4.3-    tagged-0.7.2-    tasty-0.8.1.1-    tasty-quickcheck-0.8.1-    terminfo-0.4.0.0-    text-1.1.1.3-    tf-random-0.5-    transformers-0.4.1.0-    transformers-compat-0.3.3.4-    unbounded-delays-0.1.0.7-
lib/Rainbox.hs view
@@ -1,162 +1,90 @@--- | Create grids of (possibly) colorful boxes.+-- | Typically to use Rainbox you will want these @import@s: ----- For an introduction, see "Rainbox.Tutorial".  That file is--- written in literate Haskell, so you will want to look at the--- source itself.  HsColour does not do very well with literate--- Haskell, so you will want to view the file in your text editor or--- on Github:+-- @+-- import qualified Data.Sequence as Seq+-- import Rainbow+-- import Rainbox ----- <https://github.com/massysett/rainbox/blob/master/lib/Rainbox/Tutorial.lhs>+-- -- and, for GHC before 7.10:+-- import Data.Monoid+-- @ ----- This module only helps you create simple grids of cells, rather--- like a spreadsheet that does not allow you to merge or split--- cells.  If your needs are more complicated, use "Rainbox.Box",--- which allows you to build 'Box'es of arbitrary complexity by--- pasting simpler 'Box'es together.  (You can of course use this--- module together with "Rainbox.Box" to create very complex--- layouts.)+-- Rainbox does not re-export anything from "Data.Sequence" or+-- "Rainbow" because I don't know if you want all those things dumped+-- into the same namespace.+--+-- "Rainbox.Tutorial" wil get you started.  "Rainbox.Core" contains+-- the implementation details, which you should not need to pay+-- attention to (if you do need to use "Rainbox.Core" for ordinary+-- usage of the library, that's a bug; please report it.) module Rainbox-  ( -- * Backgrounds-    Background(..)-  , defaultBackground-  , backgroundFromChunk-  , same--  -- * Alignment-  , Align-  , Horiz-  , Vert-  , top-  , bottom+  ( -- * Alignment and Boxes+    Alignment+  , Horizontal+  , Vertical+  , center   , left   , right-  , center--  -- * Bar-  , Bar(..)--  -- * Cell-  , Cell(..)--  -- * Creating Box and gluing them together+  , top+  , bottom+  , centerH+  , centerV+  , Box+  , Orientation ( spacer, spreader ) -  -- | For simple needs you will only need 'gridByRows' or-  -- 'gridByCols'; 'boxCells' and 'glueBoxes' are provided for more-  -- complex needs.-  , gridByRows-  , gridByCols-  , checkGrid-  , boxCells-  , glueBoxes+  -- * Box construction+  , fromChunk+  , blank+  , wrap    -- * Rendering   , render-  , printBox-  ) where--import Rainbox.Box-import Rainbox.Array2d-import Data.Array-import Data.String---- | A 'Cell' consists of multiple screen lines; each screen line is--- a 'Bar'.-data Cell = Cell-  { bars :: [Bar]-  -- ^ Each Bar is one line on the screen.--  , horiz :: Align Horiz-  -- ^ How this Cell aligns compared to the other Cell in its-  -- column; use 'left', 'center', or 'right'.--  , vert :: Align Vert-  -- ^ How this Cell aligns compared to other Cell in its row; use-  -- 'top', 'center', or 'bottom'.--  , background :: Background-  -- ^ Background color for necessary padding that is added to the-  -- Cell to make it the correct width and height.  Does not affect-  -- the 'Chunk' contained in the 'bars'; these will use the colors-  -- that are designated in the 'Chunk' itself.-  } deriving (Eq, Show)---- | Creates a Cell with a 'left' horizontal alignment, a 'top'--- vertical alignment, and a 'defaultBackground'.  The cell will be--- one 'Bar' tall and contain the text given in the string.-instance IsString Cell where-  fromString s = Cell [(fromString s)] left top defaultBackground+  , putBox+  , hPutBox --- | Returns the width of each 'Bar' in the 'Cell'.-cellWidths :: Cell -> [Int]-cellWidths = map width . bars+  -- * Tables+  --+  -- | Types and functions to build a simple spreadsheet-like grid.+  -- You create a nested 'Seq' of 'Cell', and then use 'tableByRows'+  -- or 'tableByColumns' to create a 'Box', which you can then+  -- render using "Rainbow" functions.  Each column is as wide as+  -- necessary to accomodate the widest cell in the column, but no+  -- wider, which means the columns will tend to meld together.  To+  -- add separators you'll have to add separator cells in yourself. --- | Transforms a grid of 'Cell' to a grid of 'Box' by adding--- necessary padding to each 'Cell'.  In every row of the array, all--- the 'Box' will have equal height; in every column of the array,--- all the 'Box' will have equal width.-boxCells-  :: (Ix col, Ix row)-  => Array (col, row) Cell-  -> Array (col, row) Box-boxCells ay = cells $ mapTable conv tbl-  where-    tbl = table getWidth getHeight ay-      where-        getWidth _ = maximum . (0:) . concat . map cellWidths . map snd-        getHeight _ = maximum . (0:) . map (length . bars . snd)-    conv lCol lRow _ _ c = grow bk (Height lRow) (Width lCol) av ah bx-      where-        Cell bs ah av bk = c-        bx = barsToBox bk ah bs+  -- ** Cell type+  , Cell(..)+  , separator --- | Use 'catH' and 'catV' to fuse an array of 'Box' into a single--- 'Box'.  For example, if the 'bounds' of the array are--- @((0,0),(3,5))@, then the array has the number of cells given by--- @rangeSize ((0,0), (3,5))@ (that is, 24).  The upper left corner--- is @(0,0)@ and the lower right corner is @(3,5)@; the upper right--- and lower left corners are @(3,0)@ and @(0,5)@, respectively.-glueBoxes-  :: (Ix col, Ix row)-  => Array (col, row) Box-  -> Box-glueBoxes-  = catH defaultBackground top-  . map (catV defaultBackground left)-  . cols+  -- ** van Laarhoven lenses+  , rows+  , horizontal+  , vertical+  , background --- | Creates a single 'Box' from a list of rows of 'Cell'.  Each--- list is a row of 'Cell'.  The list of rows is from top to bottom;--- within each row, the cells are given from left to right.------ /This function is partial./  Each list of 'Cell' must be--- the same length; otherwise, your program will crash.  Since you--- will typically generate the list of rows using 'map' or list--- comprehensions or the like, this isn't typically a problem; if it--- is a problem, then check the inputs to this function with--- 'checkGrid' before you apply it.+  -- ** Table builders+  , tableByRows+  , tableByColumns -gridByRows :: [[Cell]] -> Box-gridByRows = glueBoxes . boxCells . arrayByRows+  -- * Bi-color tables+  --+  -- | Build tables with rows of alternating background colors.+  , BicolorTableCellLine+  , BicolorTableCell+  , BicolorTableRow+  , BicolorTable(..)+  , bicolorTableToBox+  , hPutBicolorTable+  , putBicolorTable --- | Creates a single 'Box' from a list of columns of 'Cell'.  Each--- list is a column of 'Cell'.  The list of columns is from left to--- right; within each column, the cells are given from top to--- bottom.------ /This function is partial./  Each list of 'Cell' must be--- the same length; otherwise, your program will crash.  Since you--- will typically generate the list of columns using 'map' or list--- comprehensions or the like, this isn't typically a problem; if it--- is a problem, then check the inputs to this function with--- 'checkGrid' before you apply it.+  -- ** van Laarhoven lenses+  , bctEvenBackground+  , bctOddBackground+  , bctSpacerWidth+  , bctAlignments+  , bctRows -gridByCols :: [[Cell]] -> Box-gridByCols = glueBoxes . boxCells . arrayByCols+  ) where --- | Checks the input to 'gridByRows' or 'gridByCols' to ensure that--- it is safe.  True if the list of list of 'Cell' is safe for--- either of these functions; False if not.-checkGrid :: [[Cell]] -> Bool-checkGrid ls = case ls of-  [] -> True-  x:xs -> let len = length x in all ((== len) . length) xs+import Rainbox.Core+import Rainbox.BicolorTable
− lib/Rainbox/Array2d.hs 
@@ -1,216 +0,0 @@--- | Helpers for two-dimensional arrays.-module Rainbox.Array2d-  (-  -- * Tables-    Table-  , lCols-  , lRows-  , cells-  , table-  , labelCols-  , labelRows-  , mapTable-  , mapColLabels-  , mapRowLabels--  -- * Two-dimensional arrays-  , cols-  , rows-  , arrayByRows-  , arrayByCols-  ) where--import Data.Array---- * Tables---- | A Table is a two-dimensional array with two associated--- one-dimensional arrays: an array of labels for each column, and--- an array of labels for each row.-data Table lCol lRow col row a = Table-  { lCols :: Array col lCol-  -- ^ One label for each column-  , lRows :: Array row lRow-  -- ^ One label for each row-  , cells :: Array (col, row) a-  -- ^ Two-dimensional array of cells-  } deriving (Eq, Show)--instance (Ix col, Ix row) => Functor (Table lCol lRow col row) where-  fmap f t =  t { cells = fmap f . cells $ t }---- | Make a new Table.-table-  :: (Ix col, Ix row)-  => (col -> [(row, a)] -> lCol)-  -- ^ Function to generate the column labels.  It is applied to the-  -- column index and the full contents of the column.- -  -> (row -> [(col, a)] -> lRow)-  -- ^ Function to generate the row labels.  It is applied to the-  -- row index and the full contents of the row.--  -> Array (col, row) a-  -- ^ Cells of the table--  -> Table lCol lRow col row a-table fCol fRow ay = Table ayc ayr ay-  where-    ayc = labelCols fCol ay-    ayr = labelRows fRow ay---- | Given a two-dimensional array and a function that generates--- labels, return an array of column labels.-labelCols-  :: (Ix col, Ix row)-  => (col -> [(row, a)] -> lCol)-  -- ^ Function to generate the column labels.  It is applied to the-  -- column index and the full contents of the column.-  -> Array (col, row) a-  -> Array col lCol-labelCols f a = listArray (minCol, maxCol) es-  where-    ((minCol, minRow), (maxCol, maxRow)) = bounds a-    es = zipWith f ixsCols . map mkRow $ ixsCols-      where-        ixsCols = range (minCol, maxCol)-        mkRow col = zip ixsRows (map (\rw -> a ! (col, rw)) ixsRows)-          where-            ixsRows = range (minRow, maxRow)---- | Given a two-dimensional array and a function that generates--- labels, return an array of row labels.-labelRows-  :: (Ix col, Ix row)-  => (row -> [(col, a)] -> lRow)-  -- ^ Function to generate the row labels.  It is applied to the-  -- row index and the full contents of the row.-  -> Array (col, row) a-  -> Array row lRow-labelRows f a = listArray (minRow, maxRow) es-  where-    ((minCol, minRow), (maxCol, maxRow)) = bounds a-    es = zipWith f ixsRows . map mkCol $ ixsRows-      where-        ixsRows = range (minRow, maxRow)-        mkCol row = zip ixsCols (map (\cl -> a ! (cl, row)) ixsCols)-          where-            ixsCols = range (minCol, maxCol)---- | Transform the cells of the table.  Similar to the Functor--- instance, but the mapping function has access to the label and--- index of each cell in the 'Table'.-mapTable-  :: (Ix col, Ix row)-  => (lCol -> lRow -> col -> row -> a -> b)-  -- ^ Function is passed the label for the column, the label for-  -- the row, the column index, the row index, and the contents of-  -- the cell.  It returns a new cell.-  -> Table lCol lRow col row a-  -> Table lCol lRow col row b-mapTable f (Table cs rs ls) = Table cs rs ls'-  where-    ls' = listArray (bounds ls) . map g . assocs $ ls-      where-        g ((col, row), e) = f (cs ! col) (rs ! row) col row e---- | Transform the column labels.-mapColLabels-  :: (Ix col, Ix row)-  => (lCol -> col -> [(lRow, row, a)] -> lCol')-  -- ^ The function is passed the column label, column index, and-  -- the full contents of the column.-  -> Table lCol lRow col row a-  -> Table lCol' lRow col row a-mapColLabels f (Table cs rs ls) = Table cs' rs ls-  where-    ((colMin, rowMin), (colMax, rowMax)) = bounds ls-    cs' = listArray (colMin, colMax) es-      where-        es = zipWith3 f (elems cs) (indices cs) rws-          where-            rws = map mkRow . indices $ cs-              where-                mkRow idx = zipWith3 (,,) (elems rs)-                  (indices rs)-                  (map (ls !) (range ((idx, rowMin), (idx, rowMax))))---- | Transform the row labels.-mapRowLabels-  :: (Ix col, Ix row)-  => (lRow -> row -> [(lCol, col, a)] -> lRow')-  -- ^ The function is passed the row label, the row index, and the-  -- full contents of the row.-  -> Table lCol lRow col row a-  -> Table lCol lRow' col row a-mapRowLabels f (Table cs rs ls) = Table cs rs' ls-  where-    ((colMin, rowMin), (colMax, rowMax)) = bounds ls-    rs' = listArray (rowMin, rowMax) es-      where-        es = zipWith3 f (elems rs) (indices rs) cls-          where-            cls = map mkCol . indices $ rs-              where-                mkCol idx = zipWith3 (,,) (elems cs)-                  (indices cs)-                  (map (ls !) (range ((colMin, idx), (colMax, idx))))---- * Two-dimensional arrays---- | Given a two-dimensional array, return a list of columns in--- order.-cols-  :: (Ix col, Ix row)-  => Array (col, row) a-  -> [[a]]-cols ay = map getCol $ range (minCol, maxCol)-  where-    ((minCol, minRow), (maxCol, maxRow)) = bounds ay-    ixsRows = range (minRow, maxRow)-    getCol ixCol = map (\rw -> ay ! (ixCol, rw)) ixsRows---- | Given a two-dimensional array, return a list of rows in order.-rows-  :: (Ix col, Ix row)-  => Array (col, row) a-  -> [[a]]-rows ay = map getRow $ range (minRow, maxRow)-  where-    ((minCol, minRow), (maxCol, maxRow)) = bounds ay-    ixsCols = range (minCol, maxCol)-    getRow ixRow = map (\cl -> ay ! (cl, ixRow)) ixsCols---- | Generate a two-dimensional array from a list of rows.  Each row--- must be of equal length; otherwise, the generated array will have--- undefined elements.-arrayByRows-  :: [[a]]-  -> Array (Int, Int) a-arrayByRows ls = array ((0,0), (colMax, rowMax)) $ indexRows ls-  where-    rowMax = length ls - 1-    colMax = case ls of-      [] -> -1-      x:_ -> length x - 1--indexRows :: [[a]] -> [((Int, Int),a)]-indexRows = concat . map f . zip [0 ..]-  where-    f (rw, ls) = map g $ zip [0 ..] ls-      where-        g (cl, a) = ((cl, rw), a)---- | Generate a two-dimensional array from a list of columns.  Each--- column must be of equal length; otherwise, the generated array--- will have undefined elements.-arrayByCols-  :: [[a]]-  -> Array (Int, Int) a-arrayByCols ls = listArray ((0,0), (colMax, rowMax)) . concat $ ls-  where-    colMax = length ls - 1-    rowMax = case ls of-      [] -> -1-      x:_ -> length x - 1-
+ lib/Rainbox/BicolorTable.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE TemplateHaskell #-}+-- | Functions and types to build 'BicolorTable's.  Everything you should+-- typically need is exported from "Rainbox".+module Rainbox.BicolorTable where++import Control.Lens+import Data.Foldable (foldl')+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Rainbow+import qualified Rainbow.Types as R+import Rainbox.Core+import System.IO++-- | A single line within a cell in a 'BicolorTable'.  For each+-- 'Chunk', leave the 'back' as the default if you want the 'Chunk'+-- background to match '_bctEvenBackground' or '_bctOddBackground'.+-- If you specify a background color for any 'Chunk', it will for+-- that 'Chunk' override the table's background color.+type BicolorTableCellLine = Seq Chunk++-- | The set of all lines within a cell in a 'BicolorTable'.+type BicolorTableCell = Seq BicolorTableCellLine++-- | The set of all columns in a single row.  If any single row is+-- narrower than the widest row in the table, it will be padded with+-- empty cells so that it is the same width as the widest row in the+-- table.+type BicolorTableRow = Seq BicolorTableCell++-- | Description for a table with rows of alternating background colors.  For+-- instance, if designed for a terminal with a white background, the+-- row backgrounds might alternate between white and light grey.+-- The different backgrounds help with readability.+--+-- For the 'Chunk' that are in the table, simply leave the 'back'+-- color blank if you wish to use the row's background color.  Upon+-- rendering, 'bicolorTable' will render the 'Chunk' with a+-- background color that matches that of the row.  If you specify a+-- background color for a 'Chunk', it will override the background+-- color for the row.+--+-- Note that a row may contain more than one line of text.+--+-- Unlike tables built with 'tableByRows' or 'tableByColumns', all+-- tables built with 'bicolorTable' will have separator colums+-- between each column.+data BicolorTable = BicolorTable+  { _bctEvenBackground :: Radiant+  -- ^ Background color for all even-numbered rows.  Row numbering+  -- starts with zero.  To use the terminal's default background color, use+  -- 'mempty'.++  , _bctOddBackground :: Radiant+  -- ^ Background color for all odd-colored rows.  Row numbering+  -- starts with zero.  To use the terminal's default background color, use+  -- 'mempty'.++  , _bctSpacerWidth :: Int+  -- ^ The width of each column of spacer cells.++  , _bctAlignments :: Seq (Alignment Vertical)+  -- ^ Specifies the alignment for each column in the table.  If any+  -- row in '_bctRows' is longer than this 'Seq', each extra column+  -- is assumed to have an alignment 'left'.++  , _bctRows :: Seq BicolorTableRow+  -- ^ Specifies all the textual and color data for the+  -- BicolorTable.  The outermost 'Seq' is the set of all rows.+  -- These will alternate in background color bewteen+  -- '_bctEvenBackground' and '_bctOddBackground'.  This is a+  -- Russian doll of nested 'Seq'; the type synonyms help explain+  -- the types.+  } deriving Show++makeLenses ''BicolorTable++-- | Transforms a 'BicolorTable' to a 'Box'.+bicolorTableToBox :: BicolorTable -> Box Vertical+bicolorTableToBox = tableByRows . bicolorToPlainTable++-- | Creates a bi-color table and renders it to the given 'Handle'+-- using 'bicolorTable' and 'hPutBox'.+hPutBicolorTable :: Handle -> BicolorTable -> IO ()+hPutBicolorTable h = hPutBox h . bicolorTableToBox++-- | Creates a bi-color table and renders it to standard output+-- using 'hPutBicolorTable'.+putBicolorTable :: BicolorTable -> IO ()+putBicolorTable = hPutBicolorTable stdout++-- | Convert a 'Chunk' for rendering by substituting the table's+-- row background for the chunk's row background if applicable.+convertChunkForRendering+  :: Radiant+  -- ^ Background for this row+  -> Chunk+  -> Chunk+convertChunkForRendering rad chk+  = chk+  & over (R.scheme . R.style8 . R.back) newBack8+  & over (R.scheme . R.style256 . R.back) newBack256+  where+    newBack8 (R.Color Nothing) = R._color8 rad+    newBack8 x = x+    newBack256 (R.Color Nothing) = R._color256 rad+    newBack256 x = x++-- | Converts a 'BicolorTableCellLine' for rendering.+convertBicolorTableCellLineForRendering+  :: Radiant+  -> BicolorTableCellLine+  -> BicolorTableCellLine+convertBicolorTableCellLineForRendering rad = fmap (convertChunkForRendering rad)++-- | Converts a 'BicolorTableCell' for rendering.+convertBicolorTableCellForRendering+  :: Radiant+  -> BicolorTableCell+  -> BicolorTableCell+convertBicolorTableCellForRendering rad+  = fmap (convertBicolorTableCellLineForRendering rad)+++-- | Convert a BicolorTable cell to a plain Cell.  Does all necessary Chunk+-- conversions.+bicolorToPlainCell+  :: Radiant+  -- ^ Appropriate background color+  -> Alignment Vertical+  -- ^ Column alignment+  -> BicolorTableCell+  -> Cell+bicolorToPlainCell rad align bic = Cell rws top align rad+  where+    rws = convertBicolorTableCellForRendering rad bic++-- | Convert a BicolorTable row to a plain Row.  Does all necessary Chunk conversions.+-- Includes spacer cells.+bicolorToPlainRow+  :: Radiant+  -- ^ Background color for even rows+  -> Radiant+  -- ^ Background color for odd rows+  -> Int+  -- ^ Width of spacer cells+  -> Int+  -- ^ Number for this row+  -> Seq (Alignment Vertical)+  -- ^ Column alignments+  -> BicolorTableRow+  -> Seq Cell+bicolorToPlainRow bkgdEven bkgdOdd sepWidth colNum aligns+  = Seq.intersperse spcr+  . Seq.zipWith (bicolorToPlainCell bkgd) aligns+  where+    bkgd | even colNum = bkgdEven+         | otherwise = bkgdOdd+    spcr = separator bkgd sepWidth++-- | Converts a BicolorTable table to a plain table with 'Cell'.  Does all+-- necessary Chunk conversions, and includes spacer cells.+bicolorToPlainTable+  :: BicolorTable+  -> Seq (Seq Cell)+bicolorToPlainTable bct = Seq.mapWithIndex f rws+  where+    (BicolorTable bkgdEven bkgdOdd sepWidth aligns rws) = padBicolorTable bct+    f rowIdx = bicolorToPlainRow bkgdEven bkgdOdd sepWidth rowIdx aligns++-- | Pads out '_bctAlignments' so that it is as long as the longest+-- row in the table, and pads out each row in '_bctRows' so that it+-- is as long as the longest row in the table.+padBicolorTable :: BicolorTable -> BicolorTable+padBicolorTable bct+  = bct & over bctRows padRows+        & over bctAlignments padAligns+  where+    maxLen = foldl' max 0 . fmap Seq.length . _bctRows $ bct+    padRows = fmap pad+      where+        pad row = row <>+          Seq.replicate (max 0 (maxLen - Seq.length row)) Seq.empty+    padAligns aligns = aligns+      <> Seq.replicate (max 0 (maxLen - Seq.length aligns)) left
− lib/Rainbox/Box.hs 
@@ -1,341 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Working with 'Box'.------ A 'Box' is a rectangular block of text.  You can paste 'Box'--- together to create new rectangles, and you can grow or reduce--- existing 'Box' to create new 'Box'es.------ There are only six primitive functions that make a 'Box':------ * 'B.blank' - formats a blank box with nothing but a (possibly)--- colorful background.  Useful to paste to other 'Box' to provide--- white space.------ * 'B.chunks' - Makes a box out of Rainbow 'Chunk'.------ * 'B.catH' - paste 'Box' together horizontally------ * 'B.catV' - paste 'Box' together vertically------ * 'B.viewH' - view a 'Box', keeping the same height but possibly--- trimming the width------ * 'B.viewV' - view a 'Box', keeping the same width but possibly--- trimming the height------ The other functions use these building blocks to do other useful--- things.------ There are many crude diagrams in the Haddock documentation.  A--- dash means a character with data; a period means a blank--- character.  When you print your 'Box', the blank characters will--- have the appropriate background color.-module Rainbox.Box-  ( -- * Backgrounds-    Background(..)-  , defaultBackground-  , backgroundFromChunk-  , backgroundToTextSpec-  , same-  -  -- * Height and columns-  , Height(..)-  , B.height-  , Width(..)-  , B.HasWidth(..)--  -- * Alignment-  , Align-  , Vert-  , Horiz-  , B.center-  , B.top-  , B.bottom-  , B.left-  , B.right--  -- * Box properties-  , B.Bar(..)-  , B.barToBox-  , B.barsToBox-  , B.Box-  , B.unBox--  -- * Making Boxes-  , B.blank-  , blankH-  , blankV-  , B.chunks-  , chunk--  -- * Pasting Boxes together-  , B.catH-  , B.catV-  , sepH-  , sepV-  , punctuateH-  , punctuateV--  -- * Viewing Boxes-  , view-  , B.viewH-  , B.viewV--  -- * Growing Boxes-  , grow-  , growH-  , growV-  , column--  -- * Resizing-  , resize-  , resizeH-  , resizeV--  -- * Printing Boxes-  , render-  , printBox-  ) where--import Data.Monoid-import Data.List (intersperse)-import qualified Data.Text as X-import System.Console.Rainbow-import System.Console.Rainbow.Types-import System.Console.Rainbow.Colors-import qualified Rainbox.Box.Primitives as B-import Rainbox.Box.Primitives-  ( Box-  , Align-  , Horiz-  , Vert-  , Height(..)-  , Width(..)-  , Background-  , unBox-  )-import qualified System.IO as IO--backgroundFromChunk :: Chunk -> B.Background-backgroundFromChunk (Chunk ts _) = B.Background bk8 bk256-  where-    bk8 = case getLast . background8 . style8 $ ts of-      Nothing -> c8_default-      Just c -> c-    bk256 = case getLast . background256 . style256 $ ts of-      Nothing -> c256_default-      Just c -> c--backgroundToTextSpec :: B.Background -> TextSpec-backgroundToTextSpec (B.Background bk8 bk256) = TextSpec-  { style8 = mempty { background8 = Last . Just $ bk8 }-  , style256 = mempty { background256 = Last . Just $ bk256 } }---- | Use the default background colors of the current terminal.-defaultBackground :: B.Background-defaultBackground = B.Background c8_default c256_default---- | Use the same color for 8 and 256-color backgrounds.-same :: Color8 -> B.Background-same c = B.Background c (to256 c)------- # Box making------- | A blank horizontal box with a given width and no height.-blankH :: Background -> Int -> Box-blankH bk i = B.blank bk (Height 0) (Width i)---- | A blank vertical box with a given length.-blankV :: Background -> Int -> Box-blankV bk i = B.blank bk (Height i) (Width 0)---- | A Box made of a single 'Chunk'.-chunk :: Chunk -> Box-chunk = B.chunks . (:[])---- | Grow a box.  Each dimension of the result 'Box' is never smaller--- than the corresponding dimension of the input 'Box'.  Analogous to--- 'view', so you give the resulting dimensions that you want.  The--- alignment is analogous to 'view'; for instance, if you specify--- that the alignment is 'top' and 'left', the extra padding is--- added to the right and bottom sides of the resulting 'Box'.--grow-  :: Background-  -> Height-  -> Width-  -> Align Vert-  -> Align Horiz-  -> Box-  -> Box-grow bk (B.Height h) (B.Width w) av ah-  = growH bk w ah-  . growV bk h av---- | Grow a 'Box' horizontally.--growH-  :: Background-  -> Int-  -- ^ Resulting width-  -> Align Horiz-  -> Box-  -> Box-growH bk tgtW a b-  | tgtW < w = b-  | otherwise = B.catH bk B.top [lft, b, rt]-  where-    w = B.width b-    diff = tgtW - w-    (lft, rt) = (blankH bk wl, blankH bk wr)-    (wl, wr)-      | a == B.center = B.split diff-      | a == B.left = (0, diff)-      | otherwise = (diff, 0)---- | Grow a 'Box' vertically.-growV-  :: Background-  -> Int-  -- ^ Resulting height-  -> Align Vert-  -> Box-  -> Box-growV bk tgtH a b-  | tgtH < h = b-  | otherwise = B.catV bk B.left [tp, b, bt]-  where-    h = B.height b-    diff = tgtH - h-    (tp, bt) = (blankV bk ht, blankV bk hb)-    (ht, hb)-      | a == B.center = B.split diff-      | a == B.top = (0, diff)-      | otherwise = (diff, 0)---- | Returns a list of 'Box', each being exactly as wide as the--- widest 'Box' in the input list.-column-  :: Background-  -> Align Horiz-  -> [Box]-  -> [Box]-column bk ah bs = map (growH bk w ah) bs-  where-    w = maximum . (0:) . map B.width $ bs--view-  :: Height-  -> Width-  -> Align Vert-  -> Align Horiz-  -> Box-  -> Box-view h w av ah-  = B.viewH (B.unWidth w) ah-  . B.viewV (B.unHeight h) av------- # Resizing------- | Resize a 'Box'.  Will grow or trim it as necessary in order to--- reach the resulting size.  Returns an empty 'Box' if either--- 'Height' or 'Width' is less than 1.--resize-  :: Background-  -> Height-  -> Width-  -> Align Vert-  -> Align Horiz-  -> Box-  -> Box-resize bk h w av ah-  = resizeH bk (unWidth w) ah-  . resizeV bk (unHeight h) av---- | Resize horizontally.-resizeH-  :: Background-  -> Int-  -- ^ Resulting width-  -> Align Horiz-  -> Box-  -> Box-resizeH bk w a b-  | bw < w = growH bk w a b-  | bw > w = B.viewH w a b-  | otherwise = b-  where-    bw = B.width b---- | Resize vertically.-resizeV-  :: Background-  -> Int-  -- ^ Resulting height-  -> Align Vert-  -> Box-  -> Box-resizeV bk h a b-  | bh < h = growV bk h a b-  | bh > h = B.viewV h a b-  | otherwise = b-  where-    bh = B.height b------- # Glueing------- | @sepH sep a bs@ lays out @bs@ horizontally with alignment @a@,---   with @sep@ amount of space in between each.-sepH :: Background -> Int -> Align Vert -> [Box] -> Box-sepH bk sep a = punctuateH bk a bl-  where-    bl = blankH bk sep---- | @sepV sep a bs@ lays out @bs@ vertically with alignment @a@,---   with @sep@ amount of space in between each.-sepV :: Background -> Int -> Align Horiz -> [Box] -> Box-sepV bk sep a = punctuateV bk a bl-  where-    bl = blankV bk sep---- | @punctuateH a p bs@ horizontally lays out the boxes @bs@ with a---   copy of @p@ interspersed between each.-punctuateH :: Background -> Align Vert -> Box -> [Box] -> Box-punctuateH bk a sep = B.catH bk a . intersperse sep---- | A vertical version of 'punctuateH'.-punctuateV :: Background -> Align Horiz -> Box -> [Box] -> Box-punctuateV bk a sep = B.catV bk a . intersperse sep---- | Convert a 'Box' to Rainbow 'Chunk's.  You can then print it--- using 'putChunks' or the like.-render :: Box -> [Chunk]-render bx = case unBox bx of-  B.NoHeight _ -> []-  B.WithHeight rw ->-    concat . concat . map (: [["\n"]])-    . map renderRod $ rw--renderRod :: B.Rod -> [Chunk]-renderRod = map toChunk . B.unRod-  where-    toChunk = either spcToChunk id . B.unNibble-    spcToChunk ss =-      Chunk (backgroundToTextSpec (B.spcBackground ss))-            [X.replicate (B.numSpaces ss) (X.singleton ' ')]---- | Prints a Box to standard output.  If standard output is not a--- terminal, no colors are used.  Otherwise, colors are used if your--- TERM environment variable suggests they are available.-printBox :: Box -> IO ()-printBox b = do-  t <- smartTermFromEnv IO.stdout-  hPutChunks IO.stdout t . render $ b-
− lib/Rainbox/Box/Primitives.hs 
@@ -1,559 +0,0 @@--- | Box primitives.------ This module provides all functions that have access to the--- internals of a 'Box'.  There are only six functions that make a--- 'Box':------ * 'blank' - formats a blank box with nothing but a (possibly)--- colorful background.  Useful to paste to other 'Box' to provide--- white space.------ * 'chunks' - Makes a box out of Rainbow 'Chunk'.------ * 'catH' - paste 'Box' together horizontally------ * 'catV' - paste 'Box' together vertically------ * 'viewH' - view a 'Box', keeping the same height but possibly--- trimming the width------ * 'viewV' - view a 'Box', keeping the same width but possibly--- trimming the height------ There are many crude diagrams in the Haddock documentation.  A--- dash means a character with data; a period means a blank--- character.  When you print your 'Box', the blank characters will--- have the appropriate background color.-module Rainbox.Box.Primitives-  ( -- * Background-    Background(..)--  -- * Alignment-  , Align-  , Vert-  , Horiz-  , center-  , top-  , bottom-  , left-  , right--  -- * Box-  , Bar(..)-  , Rod(..)-  , barToBox-  , barsToBox-  , Nibble-  , unNibble-  , Spaces-  , numSpaces-  , spcBackground-  , BoxP(..)-  , Box-  , unBox--  -- * Height and Width-  , Height(..)-  , height-  , Width(..)-  , HasWidth(..)--  -- * Making Boxes-  , blank-  , chunks-  , catH-  , catV-  , viewH-  , viewV--  -- * Helpers-  , split--  ) where--import qualified Data.Foldable as F-import System.Console.Rainbow.Types-import Data.Monoid-import qualified Data.Text as X-import Data.String-import System.Console.Rainbow.Colors---- # Background---- | Background colors to use when inserting necessary padding.-data Background = Background-  { boxBackground8 :: Color8-  , boxBackground256 :: Color256-  } deriving (Eq, Show)---- # Box--data Spaces = Spaces-  { numSpaces :: Int-  , spcBackground :: Background-  } deriving (Eq, Show)--instance HasWidth Spaces where-  width = numSpaces--newtype Nibble = Nibble { unNibble :: Either Spaces Chunk }-  deriving (Eq, Show)--instance IsString Nibble where-  fromString = Nibble . Right . fromString--instance HasWidth Nibble where-  width = either width width . unNibble---- | Occupies a single row on screen.  The 'Chunk' you place in a--- 'Bar' should not have any control characters such as newlines or--- tabs, as rainbox assumes that each character in a 'Bar' takes up--- one screen column and that each character does not create--- newlines.  Leave newline handling up to rainbox.  However,--- rainbox will /not/ check to make sure that your inputs do not--- contain newlines, tabs, or other spurious characters.  Similarly, use of--- combining characters will create unexpected results, as Rainbox--- will see something that takes up (for instance) two characters--- and think it takes up two screen columns, when in reality it will--- take up only one screen column.  So, if you need accented--- characters, use a single Unicode code point, not two code points.--- For example, for é, use U+00E9, not U+0065 and U+0301.-newtype Bar = Bar { unBar :: [Chunk] }-  deriving (Eq, Show)--barToBox :: Bar -> Box-barToBox = chunks . unBar--barsToBox :: Background -> Align Horiz -> [Bar] -> Box-barsToBox bk ah = catV bk ah . map barToBox--instance IsString Bar where-  fromString = Bar . (:[]) . fromString--instance Monoid Bar where-  mempty = Bar []-  mappend (Bar l) (Bar r) = Bar $ l ++ r---- | A 'Box' has a width in columns and a height in rows.  Its--- height and width both are always at least zero.  It can have--- positive height even if its width is zero, and it can have--- positive width even if its height is zero.------ Each row in a 'Box' always has the same number of characters; a--- 'Box' with zero height has no characters but still has a certain--- width.--newtype Box = Box { unBox :: BoxP }-  deriving (Eq, Show)--newtype Rod = Rod { unRod :: [Nibble] }-  deriving (Eq, Show)--instance IsString Rod where-  fromString = Rod . (:[]) . fromString--instance HasWidth Rod where-  width = sum . map width . unRod---- | Box payload.  Has the data of the box.-data BoxP-  = NoHeight Int-  -- ^ A Box with width but no height.  The Int must be at least-  -- zero.  If it is zero, the Box has no height and no width.-  | WithHeight [Rod]-  -- ^ A Box that has height of at least one.  It must have at least-  -- one component Bar.-  deriving (Eq, Show)--instance HasWidth BoxP where-  width b = case b of-    NoHeight w -> w-    WithHeight ns -> sum . map width $ ns--instance IsString Box where-  fromString = Box . WithHeight . (:[]) . fromString---- # Height and Width---- | A count of rows-newtype Height = Height { unHeight :: Int }-  deriving (Eq, Ord, Show)---- | How many 'Rod' are in this 'Box'?-height :: Box -> Int-height b = case unBox b of-  NoHeight _ -> 0-  WithHeight rs -> length rs---- | A count of columns-newtype Width = Width { unWidth :: Int }-  deriving (Eq, Ord, Show)---- | How many columns are in this thing? A column is one character--- wide.  Every 'Bar' in a 'Box' always has the same number of--- columns.------ This is for things that have a single, solitary width, not things--- like columns that might have different widths at different--- points.-class HasWidth a where-  width :: a -> Int--instance HasWidth Bar where-  width = sum . map (sum . map X.length . text) . unBar--instance HasWidth Box where-  width b = case unBox b of-    NoHeight i -> i-    WithHeight rs -> case rs of-      [] -> error "cols: error"-      x:_ -> width x--instance HasWidth Chunk where-  width = sum . map X.length . text---- # Making Boxes---- | A blank 'Box'.  Useful for aligning other 'Box'.-blank-  :: Background-  -> Height-  -> Width-  -> Box-blank bk r c-  | unHeight r < 1 = Box $ NoHeight (max 0 (unWidth c))-  | otherwise = Box . WithHeight $ replicate (unHeight r) row-  where-    row | unWidth c < 1 = Rod []-        | otherwise = Rod [ blanks bk (unWidth c) ]---- | A 'Box' made of 'Chunk'.  Always one Bar tall, and has as many--- columns as there are characters in the 'Chunk'.-chunks :: [Chunk] -> Box-chunks = Box . WithHeight . (:[]) . Rod . map (Nibble . Right)---- | Alignment.-data Align a = Center | NonCenter a-  deriving (Eq, Show)---- | Vertical alignment.-data Vert = ATop | ABottom-  deriving (Eq, Show)---- | Horizontal alignment.-data Horiz = ALeft | ARight-  deriving (Eq, Show)--center :: Align a-center = Center--top :: Align Vert-top = NonCenter ATop--bottom :: Align Vert-bottom = NonCenter ABottom--left :: Align Horiz-left = NonCenter ALeft--right :: Align Horiz-right = NonCenter ARight---- | Merge several Box horizontally into one Box.  That is, with--- alignment set to ATop:------ > --- ------- ------- > --- ---------- > --------- becomes------ > ----------------- > ----------....--- > ---...........------ With alignment set to ABottom, becomes------ > ---...........--- > ----------....--- > ----------------catH :: Background -> Align Vert -> [Box] -> Box-catH bk al bs-  | null bs = Box $ NoHeight 0-  | hght == 0 = Box . NoHeight . sum . map width $ bs-  | otherwise = Box . WithHeight . mergeHoriz . map (pad . unBox) $ bs-  where-    pad = padHoriz bk al hght-    hght = F.maximum . (0:) . map height $ bs---- | Merge several Box vertically into one Box.  That is, with--- alignment set to 'left':------ > ---------- > ---------- >--- > ------ > ------ >--- > ------- > ---------- becomes------ > ---------- > ---------- > ---....--- > ---....--- > ---....--- > ----...--- > ----...------ With alignment set to 'right', becomes------ > ---------- > ---------- > ....------ > ....------ > ...------- > ...------catV :: Background -> Align Horiz -> [Box] -> Box-catV bk al bs-  | null bs = Box $ NoHeight 0-  | otherwise = Box . foldr f (NoHeight w)-      . concat . map (flatten . unBox) $ bs-  where-    w = F.maximum . (0:) . map width $ bs-    f mayR bp = case mayR of-      Nothing -> bp-      Just rw -> case bp of-        WithHeight wh -> WithHeight $ padded : wh-        _ -> WithHeight [padded]-        where-          padded = padVert bk al w rw-    flatten bp = case bp of-      NoHeight _ -> [Nothing]-      WithHeight rs -> map Just rs----- | Given the resulting height, pad a list of Height.  So, when given--- a height of 3 and an alignment of 'top':------ > ----------- > -------------- becomes------ > ----------- > ----------- > ........------ where dashes is a 'Bar' with data, and dots is a blank 'Bar'.--padHoriz :: Background -> Align Vert -> Int -> BoxP -> [Rod]-padHoriz bk a hght bp = case bp of-  NoHeight w -> map (Rod . (:[])) . replicate h $ blanks bk w-  WithHeight rs -> concat [tp, rs, bot]-    where-      nPad = max 0 $ h - length rs-      (nATop, nBot) = case a of-        Center -> split nPad-        NonCenter ATop -> (0, nPad)-        NonCenter ABottom -> (nPad, 0)-      pad = Rod [blanks bk len]-        where-          len = case rs of-            [] -> 0-            x:_ -> width x-      (tp, bot) = (replicate nATop pad, replicate nBot pad)-  where-    h = max 0 hght---- | Given the resulting width, pad a 'Bar'.  So, when given--- a width of 10 and an alignment of 'right',------ > ------------- becomes------ > ...---------padVert-  :: Background-  -> Align Horiz-  -> Int-  -> Rod-  -> Rod-padVert bk a wdth rw@(Rod cs) = Rod . concat $ [lft, cs, rght]-  where-    nPad = max 0 $ w - width rw-    (nLeft, nRight) = case a of-      Center -> split nPad-      NonCenter ALeft -> (0, nPad)-      NonCenter ARight -> (nPad, 0)-    (lft, rght) = (mkPad nLeft, mkPad nRight)-    mkPad n-      | n == 0 = []-      | otherwise = [blanks bk n]-    w = max 0 wdth----- | Merge several horizontal Height into one set of horizontal 'Bar'.--- That is:------ > ----- ----- -------- > ----- ----- -------- > ----- ----- ----------- into------ > ------------------ > ------------------ > --------------------- Strange behavior will result if each input list is not exactly--- the same length.--mergeHoriz :: [[Rod]] -> [Rod]-mergeHoriz = foldr (zipWith merge) (repeat (Rod []))-  where-    merge (Rod r1) (Rod r2) = Rod $ r1 ++ r2---- # Viewing---- | View a 'Box', possibly shrinking it.  You set the size of your--- viewport and how it is oriented relative to the 'Box' as a whole.--- The 'Box' returned may be smaller than the argument 'Box', but it--- will never be bigger.------ Examples:------ >>> :set -XOverloadedStrings--- >>> let box = catV defaultBackground top [ "ab", "cd" ]--- >>> printBox . view (Height 1) (Width 1) left top $ box--- a------ >>> printBox . view (Height 1) (Width 1) right bottom $ box--- d--viewV :: Int -> Align Vert -> Box -> Box-viewV hght a (Box b) = Box $ case b of-  WithHeight rs-    | h == 0 -> NoHeight . width . head $ rs-    | otherwise -> WithHeight $ case a of-        NonCenter ATop -> take h rs-        NonCenter ABottom -> drop extra rs-        Center -> drop nDrop . take nTake $ rs-          where-            (trimL, trimR) = split extra-            nTake = length rs - trimR-            nDrop = trimL-        where-          extra = max 0 $ length rs - h-  x -> x-  where-    h = max 0 hght--viewH :: Int -> Align Horiz -> Box -> Box-viewH wdth a (Box b) = Box $ case b of-  NoHeight nh -> NoHeight (min w nh)-  WithHeight rs -> WithHeight $ map f rs-    where-      f rw = case a of-        NonCenter ALeft -> takeChars w rw-        NonCenter ARight -> dropChars extra rw-        Center -> dropChars nDrop . takeChars nTake $ rw-          where-            (trimL, trimR) = split extra-            nTake = max 0 $ width rw - trimR-            nDrop = trimL-        where-          extra = max 0 $ width rw - w-  where-    w = max 0 wdth---dropChars :: Int -> Rod -> Rod-dropChars colsIn = Rod . go colsIn . unRod-  where-    go n cs-      | n <= 0 = cs-      | otherwise = case cs of-         [] -> []-         x:xs-           | lenX <= n -> go (n - lenX) xs-           | otherwise -> x' : xs-           where-             lenX = case unNibble x of-              Left blnk -> numSpaces blnk-              Right chk -> width chk-             x' = case unNibble x of-              Left blnk -> Nibble . Left $-                blnk { numSpaces = numSpaces blnk - n }-              Right chk -> Nibble . Right . dropChunkChars n $ chk---- | Drops the given number of characters from a Chunk.-dropChunkChars :: Int -> Chunk -> Chunk-dropChunkChars n c = c { text = go n (text c) }-  where-    go nLeft ls = case ls of-      [] -> []-      t:ts-        | len < nLeft -> go (nLeft - len) ts-        | len == nLeft -> ts-        | otherwise -> X.drop nLeft t : ts-        where-          len = X.length t--takeChars :: Int -> Rod -> Rod-takeChars colsIn = Rod . go colsIn . unRod-  where-    go n cs-      | n <= 0 = []-      | otherwise = case cs of-          [] -> []-          x:xs-            | lenX <= n -> x : go (n - lenX) xs-            | otherwise -> [x']-            where-              (lenX, x') = case unNibble x of-                Left blnk ->-                  ( numSpaces blnk,-                    Nibble . Left $ blnk { numSpaces = n } )-                Right chk ->-                  ( width chk,-                    Nibble . Right . takeChunkChars n $ chk)--takeChunkChars :: Int -> Chunk -> Chunk-takeChunkChars n c = c { text = go n (text c) }-  where-    go nLeft ls = case ls of-      [] -> []-      t:ts-        | len < nLeft -> t : go (nLeft - len) ts-        | len == nLeft -> [t]-        | otherwise -> [X.take nLeft t]-        where-          len = X.length t------- # Helpers------- | Generate spaces.-blanks-  :: Background-  -- ^ Background colors-  -> Int-  -- ^ Number of blanks-  -> Nibble-blanks bk c = Nibble (Left (Spaces c bk))---- | Split a number into two parts, so that the sum of the two parts--- is equal to the original number.-split :: Int -> (Int, Int)-split i = (r, r + rm)-  where-    (r, rm) = i `quotRem` 2-
+ lib/Rainbox/Core.hs view
@@ -0,0 +1,733 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE TemplateHaskell #-}+-- lens-simple makeLenses will not make type signatures+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_HADDOCK not-home #-}+-- | Contains the innards of 'Rainbox'.  You shouldn't need anything+-- in here.  Some functions here are partial or have undefined results+-- if their inputs don't respect particular invariants.+module Rainbox.Core where++import           Control.Monad (join)+import qualified Data.Foldable as F+import           Data.Function ((&))+import qualified Data.Map as M+import           Data.Monoid ((<>))+import           Data.Sequence (Seq, ViewL (EmptyL, (:<)), viewl, (|>))+import qualified Data.Sequence as Seq+import qualified Data.Text as X+import qualified Data.Traversable as T+import           Control.Lens (Lens', lens)+import           Rainbow ( Chunk , Radiant , chunk , back, hPutChunks)+import           Rainbow.Types (Chunk (_yarn))+import           System.IO++-- # Alignment++-- | Alignment.  Used in conjunction with 'Horizontal' and 'Vertical',+-- this determines how a payload aligns with the axis of a 'Box'.+data Alignment a = Center | NonCenter a+  deriving (Eq, Ord, Show, Functor, F.Foldable, T.Traversable)++instance Semigroup (Alignment a) where+  x <> y = case x of+    Center -> y+    NonCenter a -> case y of+      Center -> NonCenter a+      NonCenter b -> NonCenter b++-- | 'mempty' is 'center'.  'mappend' takes the rightmost non-'center'+-- value.++instance Monoid (Alignment a) where+  mempty = Center++-- # Horizontal and vertical++-- | Determines how a payload aligns with a horizontal axis.+data Horizontal = Top | Bottom+  deriving (Eq, Ord, Show)++-- | Determines how a payload aligns with a vertical axis.+data Vertical = Port | Starboard+  deriving (Eq, Ord, Show)++-- | Place this payload so that it is centered on the vertical axis or+-- horizontal axis.+center :: Alignment a+center = Center++-- | Center horizontally; like 'center', but monomorphic.+centerH :: Alignment Horizontal+centerH = center++-- | Center vertically; like 'center', but monomorphic.+centerV :: Alignment Vertical+centerV = center++-- | Place this payload's left edge on the vertical axis.+left :: Alignment Vertical+left = NonCenter Port++-- | Place this payload's right edge on the vertical axis.+right :: Alignment Vertical+right = NonCenter Starboard++-- | Place this payload's top edge on the horizontal axis.+top :: Alignment Horizontal+top = NonCenter Top++-- | Place this payload's bottom edge on the horizontal axis.+bottom :: Alignment Horizontal+bottom = NonCenter Bottom+++-- # Width and height++-- | A count of rows.+newtype Height = Height Int+  deriving (Eq, Ord, Show)++-- | A count of columns.+newtype Width = Width Int+  deriving (Eq, Ord, Show)++class HasHeight a where+  height :: a -> Int++instance HasHeight Height where+  height (Height a) = max 0 a++instance HasHeight Chunk where+  height _ = 1++instance (HasHeight a, HasHeight b) => HasHeight (Either a b) where+  height = either height height++class HasWidth a where+  width :: a -> Int++instance HasWidth Width where+  width (Width a) = max 0 a++instance HasWidth Chunk where+  width ck = X.length . _yarn $ ck++instance (HasWidth a, HasWidth b) => HasWidth (Either a b) where+  width = either width width++-- # Core++-- | A 'Core' is either a single 'Chunk' or, if the box is blank, is+-- merely a height and a width.+newtype Core = Core (Either Chunk (Height, Width))+  deriving (Eq, Ord, Show)++instance HasWidth Core where+  width (Core ei) = either width (width . snd) ei++instance HasHeight Core where+  height (Core ei) = either height (height . fst) ei++-- # Rods++-- | An intermediate type used in rendering; it consists either of+-- text 'Chunk' or of a number of spaces coupled with a background color.+newtype Rod = Rod (Either (Int, Radiant) Chunk)+  deriving (Eq, Ord, Show)++instance HasWidth Rod where+  width (Rod ei) = case ei of+    Left (i, _) -> max 0 i+    Right c -> width c++-- # RodRows++-- | A list of screen rows; each screen row is a 'Seq' of 'Rod'.+--+-- A 'RodRows' with width but no height does nothing if rendered+-- alone, but it can affect the width of other 'RodRows' if combined+-- with them.+data RodRows+  = RodRowsWithHeight (Seq (Seq Rod))+  -- ^ Each outer 'Seq' represents a single screen row.  Each 'Seq'+  -- has a height of 1.+  --+  -- The outer 'Seq' must have a length of at least 1, even if the+  -- inner 'Seq' is empty.  If the outer 'Seq' has a length of zero,+  -- undefined behavior occurs.  For a 'RodRows' with no height and no+  -- width, use 'RodRowsNoHeight'.++  | RodRowsNoHeight Int+  -- ^ A 'RodRows' that has no height.  If the 'Int' is less than 1,+  -- the 'RodRows' has no width and no height.  Otherwise, the+  -- 'RodRows' has no height but has the given width.+  deriving (Eq, Ord, Show)++instance HasHeight RodRows where+  height (RodRowsWithHeight sq) = Seq.length sq+  height (RodRowsNoHeight _) = 0++instance HasWidth RodRows where+  width (RodRowsWithHeight sq) = F.foldl' max 0 . fmap (F.sum . fmap width) $ sq+  width (RodRowsNoHeight i) = max 0 i++-- | Convert a 'Core' to a 'Seq' of 'Rod' for rendering.+rodRowsFromCore :: Radiant -> Core -> RodRows+rodRowsFromCore bk (Core ei) = case ei of+  Left ck -> RodRowsWithHeight . Seq.singleton+    . Seq.singleton . Rod . Right $ ck+  Right (Height h, Width w)+    | h < 1  -> RodRowsNoHeight w+    | otherwise -> RodRowsWithHeight . Seq.replicate h . Seq.singleton+        . Rod . Left $ (w, bk)++-- | Converts a 'RodRows' to a nested 'Seq' of 'Chunk' in+-- preparation for rendering.  Newlines are added to the end of each+-- line.+chunksFromRodRows :: RodRows -> Seq (Seq Chunk)+chunksFromRodRows rr = case rr of+  RodRowsWithHeight sq -> fmap (|> chunk "\n") . fmap (fmap chunkFromRod) $ sq+    where+      chunkFromRod (Rod ei) = case ei of+        Left (i, r) -> (chunk . X.replicate i $ " ") & back r+        Right c -> c+  RodRowsNoHeight _ -> Seq.empty+++-- # Payload++-- | A 'Payload' holds a 'RodRows', which determines the number+-- and content of the screen rows.  The 'Payload' also has an+-- 'Alignment', which specifies how the payload aligns with the axis.+-- Whether the 'Alignment' is 'Horizontal' or 'Vertical' determines+-- the orientation of the 'Payload'.  The 'Payload' also contains a+-- background color, which is type 'Radiant'.  The background color+-- extends continuously from the 'Payload' in both directions that are+-- perpendicular to the axis.++data Payload a = Payload (Alignment a) Radiant (Either RodRows Core)+  deriving (Eq, Ord, Show)++instance HasWidth (Payload a) where+  width (Payload _ _ ei) = width ei++instance HasHeight (Payload a) where+  height (Payload _ _ ei) = height ei++-- # Padding and merging++-- | Adds padding to the top and bottom of each Payload.  A Payload+-- with a Core is converted to a RodRows and has padding added; a+-- Payload with a RodRows has necessary padding added to the top and+-- bottom.  The number of elements in the resulting Seq is the same as+-- the number of elements in the input Seq; no merging is performed.++addVerticalPadding+  :: Box Horizontal+  -> Seq RodRows+addVerticalPadding bx@(Box sqnce) = fmap eqlize sqnce+  where+    maxTop = above bx+    maxBot = below bx+    eqlize bhp@(Payload _ rd ei) = case ei of+      Left rr -> eqlzeRodRows rr+      Right cre -> eqlzeRodRows (rodRowsFromCore rd cre)+      where+        eqlzeRodRows rr = case rr of+          RodRowsWithHeight sq -> RodRowsWithHeight $ tp w <> sq <> bot w+          RodRowsNoHeight i+            | maxTop + maxBot == 0 -> RodRowsNoHeight i+            | otherwise -> RodRowsWithHeight $ tp w <> bot w+          where+            w = width rr+        tp w = Seq.replicate (max 0 (maxTop - above bhp)) (pad w)+        bot w = Seq.replicate (max 0 (maxBot - below bhp)) (pad w)+        pad w = Seq.singleton . Rod . Left $ (w, rd)++-- | Merges multiple horizontal RodRows into a single RodRows.  All+-- RodRows must already have been the same height; if they are not the+-- same height, undefined behavior occurs.++horizontalMerge :: Seq RodRows -> RodRows+horizontalMerge sqn = case viewl sqn of+  EmptyL -> RodRowsNoHeight 0+  x :< xs -> case x of+    RodRowsNoHeight i -> RodRowsNoHeight $ F.foldl' comb i xs+      where+        comb acc x' = case x' of+          RodRowsNoHeight i' -> acc + i'+          RodRowsWithHeight _ -> error "horizontalMerge: error 1"+    RodRowsWithHeight sq -> RodRowsWithHeight $ F.foldl' comb sq xs+      where+        comb acc rr = case rr of+          RodRowsWithHeight sq' -> Seq.zipWith (<>) acc sq'+          RodRowsNoHeight _ -> error "horizontalMerge: error 2"++-- | Split a number into two parts, so that the sum of the two parts+-- is equal to the original number.+split :: Int -> (Int, Int)+split i = (r, r + rm)+  where+    (r, rm) = i `quotRem` 2++-- | Adds padding to the left and right of each Payload.+-- A Payload with a Core is converted to a RodRows and has padding+-- added; a Payload with a RodRows has necessary padding added to the+-- left and right.  The number of elements in the resulting Seq is+-- the same as the number of elements in the input Seq; no merging is+-- performed.++addHorizontalPadding+  :: Box Vertical+  -> Seq RodRows+addHorizontalPadding bx@(Box sqnce) = fmap eqlize sqnce+  where+    maxLeft = port bx+    maxRight = starboard bx+    eqlize (Payload a rd ei) = case ei of+      Left rr -> addLeftRight rr+      Right cre -> addLeftRight $ rodRowsFromCore rd cre+      where+        addLeftRight (RodRowsNoHeight _) = RodRowsNoHeight $ maxLeft + maxRight+        addLeftRight (RodRowsWithHeight sq) = RodRowsWithHeight $+          fmap addLeftRightToLine sq+        addLeftRightToLine lin = padder lenLft <> lin <> padder lenRgt+          where+            lenLin = F.sum . fmap width $ lin+            lenLft = case a of+              Center -> maxLeft - (fst . split $ lenLin)+              NonCenter Port -> maxLeft+              NonCenter Starboard -> maxLeft - lenLin+            lenRgt = case a of+              Center -> maxRight - (snd . split $ lenLin)+              NonCenter Port -> maxRight - lenLin+              NonCenter Starboard -> maxRight+            padder len+              | len < 1 = Seq.empty+              | otherwise = Seq.singleton . Rod . Left $ (len, rd)+++-- | Merge multiple vertical RodRows into a single RodRows.  Each+-- RodRows should already be the same width.++verticalMerge :: Seq RodRows -> RodRows+verticalMerge sqnce = case viewl sqnce of+  EmptyL -> RodRowsNoHeight 0+  x :< xs -> F.foldl' comb x xs+    where+      comb acc rr = case (acc, rr) of+        (RodRowsNoHeight w, RodRowsNoHeight _) -> RodRowsNoHeight w+        (RodRowsNoHeight _, RodRowsWithHeight sq) -> RodRowsWithHeight sq+        (RodRowsWithHeight sq, RodRowsNoHeight _) -> RodRowsWithHeight sq+        (RodRowsWithHeight sq1, RodRowsWithHeight sq2) ->+          RodRowsWithHeight $ sq1 <> sq2++-- # Box++-- | A 'Box' is the central building block.  It consists of zero or+-- more payloads; each payload has the same orientation, which is either+-- 'Horizontal' or 'Vertical'.  This orientation also determines+-- the orientation of the entire 'Box'.+--+-- A 'Box' is a 'Monoid' so you can combine them using the usual+-- monoid functions.  For a 'Box' 'Vertical', the leftmost values+-- added with 'mappend' are at the top of the 'Box'; for a 'Box'+-- 'Horizontal', the leftmost values added with 'mappend' are on the+-- left side of the 'Box'.+newtype Box a = Box (Seq (Payload a))+  deriving (Eq, Ord, Show)++instance Semigroup (Box a) where+  (Box x) <> (Box y) = Box (x <> y)++instance Monoid (Box a) where+  mempty = Box Seq.empty++-- # Orientation++-- | This typeclass is responsible for transforming a 'Box' into+-- Rainbow 'Chunk' so they can be printed to your screen.  This+-- requires adding appropriate whitespace with the right colors, as+-- well as adding newlines in the right places.+class Orientation a where+  rodRows :: Box a -> RodRows++  spacer :: Radiant -> Int -> Box a+  -- ^ Builds a one-dimensional box of the given size; its single+  -- dimension is parallel to the axis.  When added to a+  -- box, it will insert blank space of the given length.  For a 'Box'+  -- 'Horizontal', this produces a horizontal line; for a 'Box'+  -- 'Vertical', a vertical line.++  spreader :: Alignment a -> Int -> Box a+  -- ^ Builds a one-dimensional box of the given size; its single+  -- dimension is perpendicular to the axis.  This can be used to make+  -- a 'Box' 'Vertical' wider or a 'Box' 'Horizontal' taller.++instance Orientation Vertical where+  rodRows = verticalMerge . addHorizontalPadding++  spacer r i = Box . Seq.singleton $+    Payload (NonCenter Port) r (Right . Core . Right $+      (Height (max 0 i), Width 0))+  spreader a i = Box . Seq.singleton $+    Payload a mempty (Right . Core . Right $+      (Height 0, Width (max 0 i)))++instance Orientation Horizontal where+  rodRows = horizontalMerge . addVerticalPadding++  spacer r i = Box . Seq.singleton $+    Payload (NonCenter Top) r (Right . Core . Right $+      (Height 0, Width (max 0 i)))+  spreader a i = Box . Seq.singleton $+    Payload a mempty (Right . Core . Right $+      (Height (max 0 i), Width 0))++-- # port, starboard, above, below+++-- | Things that are oriented around a vertical axis.+class LeftRight a where+  -- | Length to the left of the vertical axis.+  port :: a -> Int++  -- | Length to the right of the vertical axis.+  starboard :: a -> Int++-- | Things that are oriented around a horizontal axis.+class UpDown a where+  -- | Number of lines above the horizontal axis.+  above :: a -> Int+  -- | Number of lines below the horizontal axis.+  below :: a -> Int+++instance LeftRight (Payload Vertical) where+  port (Payload a _ ei) = case a of+    NonCenter Port -> 0+    NonCenter Starboard -> width ei+    Center -> fst . split . width $ ei++  starboard (Payload a _ s3) = case a of+    NonCenter Port -> width s3+    NonCenter Starboard -> 0+    Center -> snd . split . width $ s3++instance UpDown (Payload Horizontal) where+  above (Payload a _ s3) = case a of+    NonCenter Top -> 0+    NonCenter Bottom -> height s3+    Center -> fst . split . height $ s3++  below (Payload a _ s3) = case a of+    NonCenter Top -> height s3+    NonCenter Bottom -> 0+    Center -> snd . split . height $ s3++instance LeftRight (Box Vertical) where+  port (Box sq) = F.foldl' max 0 . fmap port $ sq+  starboard (Box sq) = F.foldl' max 0 . fmap starboard $ sq++instance HasWidth (Box Vertical) where+  width b = port b + starboard b++instance HasHeight (Box Vertical) where+  height (Box sq) = F.sum . fmap height $ sq++instance UpDown (Box Horizontal) where+  above (Box sq) = F.foldl' max 0 . fmap above $ sq+  below (Box sq) = F.foldl' max 0 . fmap below $ sq++instance HasHeight (Box Horizontal) where+  height b = above b + below b++instance HasWidth (Box Horizontal) where+  width (Box sq) = F.sum . fmap width $ sq++-- # Box construction++-- | Construct a box from a single 'Chunk'.+fromChunk+  :: Alignment a+  -> Radiant+  -- ^ Background color.  The background color in the 'Chunk' is not+  -- changed; this background is used if the 'Payload' must be padded+  -- later on.+  -> Chunk+  -> Box a+fromChunk a r = Box . Seq.singleton . Payload a r  . Right . Core . Left++-- | Construct a blank box.  Useful for adding in background spacers.+-- For functions that build one-dimensional boxes, see 'spacer' and+-- 'spreader'.+blank+  :: Alignment a+  -> Radiant+  -- ^ Color for the blank area.+  -> Height+  -> Width+  -> Box a+blank a r h w =+  Box . Seq.singleton . Payload a r . Right . Core . Right $ (h, w)++-- | Wrap a 'Box' in another 'Box'.  Useful for changing a+-- 'Horizontal' 'Box' to a 'Vertical' one, or simply for putting a+-- 'Box' inside another one to control size and background color.+wrap+  :: Orientation a+  => Alignment b+  -- ^ Alignment for new 'Box'.  This also determines whether the new+  -- 'Box' is 'Horizontal' or 'Vertical'.+  -> Radiant+  -- ^ Background color for new box+  -> Box a+  -> Box b+wrap a r = Box . Seq.singleton . Payload a r . Left . rodRows++-- # Box rendering++-- | Convert a box to a 'Seq' of 'Chunk' in preparation for rendering.+-- Use 'F.toList' to convert the 'Seq' of 'Chunk' to a list so that+-- you can print it using the functions in "Rainbow".+render :: Orientation a => Box a -> Seq Chunk+render = join . chunksFromRodRows . rodRows++-- | Renders a 'Box' to the given 'Handle'.  This uses 'hPutChunks' so consult+-- that function for more details on how this works; generally it is going to+-- use the maximum number of colors possible for your terminal.+hPutBox :: Orientation a => Handle -> Box a -> IO ()+hPutBox h b = hPutChunks h (F.toList . render $ b)++-- | Uses 'hPutBox' to render the given 'Box' to standard output.+putBox :: Orientation a => Box a -> IO ()+putBox = hPutBox stdout+++-- # Tables++-- | A single cell in a spreadsheet-like grid.+data Cell = Cell+  { _rows :: Seq (Seq Chunk)+  -- ^ The cell can have multiple rows of text; there is one 'Seq' for+  -- each row of text.+  , _horizontal :: Alignment Horizontal+  -- ^ How this 'Cell' should align compared to other 'Cell' in its+  -- row.+  , _vertical :: Alignment Vertical+  -- ^ How this 'Cell' should align compared to other 'Cell' in its column.+  , _background :: Radiant+  -- ^ Background color for this cell.  The background in the+  -- individual 'Chunk' in the 'cellRows' are not affected by+  -- 'cellBackground'; instead, 'cellBackground' determines the color+  -- of necessary padding that will be added so that the cells make a+  -- uniform table.+  } deriving (Eq, Ord, Show)++rows :: Lens' Cell (Seq (Seq Chunk))+rows = lens _rows (\cel fld -> cel { _rows = fld })++horizontal :: Lens' Cell (Alignment Horizontal)+horizontal = lens _horizontal (\cel fld -> cel { _horizontal = fld })++vertical :: Lens' Cell (Alignment Vertical)+vertical = lens _vertical (\cel fld -> cel { _vertical = fld })++background :: Lens' Cell Radiant+background = lens _background (\cel fld -> cel { _background = fld })++instance Semigroup Cell where+  (Cell rx hx vx bx) <> (Cell ry hy vy by)+    = Cell (zipSeqs rx ry) (hx <> hy) (vx <> vy) (bx <> by)+    where+      zipSeqs x y = Seq.zipWith (<>) x' y'+        where+          x' = x <> Seq.replicate+            (max 0 (Seq.length y - Seq.length x)) Seq.empty+          y' = y <> Seq.replicate+            (max 0 (Seq.length x - Seq.length y)) Seq.empty+++-- | 'mappend' combines two 'Cell' horizontally so they are+-- side-by-side, left-to-right.  The '_horizontal', '_vertical', and+-- '_background' fields are combined using their respective 'Monoid'+-- instances.  'mempty' uses the respective 'mempty' value for each+-- field.+instance Monoid Cell where+  mempty = Cell mempty mempty mempty mempty++-- | Creates a blank 'Cell' with the given background color and width;+-- useful for adding separators between columns.+separator :: Radiant -> Int -> Cell+separator rd i = Cell (Seq.singleton (Seq.singleton ck)) top left rd+  where+    ck = (chunk $ X.replicate (max 0 i) " ") & back rd++-- Cells by row:+-- 0. Ensure each row is equal length+-- 1. Create one BoxV for each cell+-- 2. Create widest cell map+-- 3. Pad each BoxV to appropriate width, using cellVert alignment+-- 4. Convert each BoxV to BoxH, using cellHoriz and cellBackground+-- 5. mconcatSeq each row+-- 6. Convert each row to BoxV; use default background+--    and center alignment+-- 7. mconcatSeq the rows++-- | Create a table where each inner 'Seq' is a row of cells,+-- from left to right.  If necessary, blank cells are added to the end+-- of a row to ensure that each row has the same number of cells as+-- the longest row.+tableByRows :: Seq (Seq Cell) -> Box Vertical+tableByRows+  = mconcatSeq+  . fmap rowToBoxV+  . fmap mconcatSeq+  . fmap (fmap toBoxH)+  . uncurry padBoxV+  . addWidthMap+  . fmap (fmap cellToBoxV)+  . equalize mempty++rowToBoxV :: Box Horizontal -> Box Vertical+rowToBoxV = wrap center mempty++cellToBoxV :: Cell -> (Box Vertical, Alignment Horizontal, Radiant)+cellToBoxV (Cell rs ah av rd) = (bx, ah, rd)+  where+    bx = mconcatSeq+       . fmap (wrap av rd)+       . fmap (mconcatSeq . fmap (fromChunk top rd))+       $ rs++toBoxH+  :: (Box Vertical, Alignment Horizontal, Radiant)+  -> Box Horizontal+toBoxH (bv, ah, rd) = wrap ah rd bv++addWidthMap+  :: Seq (Seq (Box Vertical, b, c))+  -> (M.Map Int (Int, Int), Seq (Seq (Box Vertical, b, c)))+addWidthMap sqnce = (m, sqnce)+  where+    m = widestCellMap . fmap (fmap (\(a, _, _) -> a)) $ sqnce++padBoxV+  :: M.Map Int (Int, Int)+  -> Seq (Seq (Box Vertical, a, b))+  -> Seq (Seq (Box Vertical, a, b))+padBoxV mp = fmap (Seq.mapWithIndex f)+  where+    f idx (bx, a, b) = (bx <> padLeft <> padRight, a, b)+      where+        (lenL, lenR) = mp M.! idx+        padLeft = spreader right lenL+        padRight = spreader left lenR+++widestCellMap :: Seq (Seq (Box Vertical)) -> M.Map Int (Int, Int)+widestCellMap = F.foldl' outer M.empty+  where+    outer mpOuter = Seq.foldlWithIndex inner mpOuter+      where+        inner mpInner idx bx = case M.lookup idx mpInner of+          Nothing -> M.insert idx (port bx, starboard bx) mpInner+          Just (pOld, sOld) -> M.insert idx+            (max pOld (port bx), max sOld (starboard bx)) mpInner++-- Table by columns:+--+-- 0.  Equalize columns+-- 1.  Create one BoxH for each cell+-- 2.  Create tallest cell map+-- 3.  Pad each BoxH to appropriate height, using cellHeight alignment+-- 4.  Convert each BoxH to BoxV, using cellVert and cellBackground+-- 5.  mconcatSeq each column+-- 6.  Convert each column to BoxH+-- 7.  mconcatSeq the columns++-- | Create a table where each inner 'Seq' is a column of cells,+-- from top to bottom.  If necessary, blank cells are added to the end+-- of a column to ensure that each column has the same number of cells+-- as the longest column.+tableByColumns :: Seq (Seq Cell) -> Box Horizontal+tableByColumns+  = mconcatSeq+  . fmap rowToBoxH+  . fmap mconcatSeq+  . fmap (fmap toBoxV)+  . uncurry padBoxH+  . addHeightMap+  . fmap (fmap cellToBoxH)+  . equalize mempty+++rowToBoxH :: Box Vertical -> Box Horizontal+rowToBoxH = wrap top mempty+++cellToBoxH :: Cell -> (Box Horizontal, Alignment Vertical, Radiant)+cellToBoxH (Cell rs ah av rd) = (bx, av, rd)+  where+    bx = wrap ah rd+       . mconcatSeq+       . fmap (wrap av rd)+       . fmap (mconcatSeq . fmap (fromChunk top rd))+       $ rs++addHeightMap+  :: Seq (Seq (Box Horizontal, b, c))+  -> (M.Map Int (Int, Int), Seq (Seq (Box Horizontal, b, c)))+addHeightMap sqnce = (m, sqnce)+  where+    m = tallestCellMap . fmap (fmap (\(a, _, _) -> a)) $ sqnce++tallestCellMap :: Seq (Seq (Box Horizontal)) -> M.Map Int (Int, Int)+tallestCellMap = F.foldl' outer M.empty+  where+    outer mpOuter = Seq.foldlWithIndex inner mpOuter+      where+        inner mpInner idx bx = case M.lookup idx mpInner of+          Nothing -> M.insert idx (above bx, below bx) mpInner+          Just (aOld, bOld) -> M.insert idx+            (max aOld (above bx), max bOld (below bx)) mpInner+++padBoxH+  :: M.Map Int (Int, Int)+  -> Seq (Seq (Box Horizontal, a, b))+  -> Seq (Seq (Box Horizontal, a, b))+padBoxH mp = fmap (Seq.mapWithIndex f)+  where+    f idx (bx, a, b) = (bx <> padTop <> padBot, a, b)+      where+        (lenT, lenB) = mp M.! idx+        padTop = spreader bottom lenT+        padBot = spreader top lenB+++toBoxV+  :: (Box Horizontal, Alignment Vertical, Radiant)+  -> Box Vertical+toBoxV (bh, av, rd) = wrap av rd bh+++-- | Ensures that each inner 'Seq' is the same length by adding the+-- given empty element where needed.+equalize :: a -> Seq (Seq a) -> Seq (Seq a)+equalize emp sqnce = fmap adder sqnce+  where+    maxLen = F.foldl' max 0 . fmap Seq.length $ sqnce+    adder sq = sq <> pad+      where+        pad = Seq.replicate (max 0 (maxLen - Seq.length sq)) emp++mconcatSeq :: Monoid a => Seq a -> a+mconcatSeq = F.foldl' (<>) mempty+
− lib/Rainbox/Reader.hs 
@@ -1,293 +0,0 @@--- | 'Box' with many functions in a 'Reader' monad.------ The advantage of this module over "Rainbox" is that many of the--- functions have fewer arguments because they are instead carried--- in the 'Reader' monad.  This also allows you to use four infix--- operators to easily join up 'Box'.  The disadvantage is that--- using the 'Reader' monad adds a layer of indirection.-module Rainbox.Reader-  ( -- * Backgrounds-    B.Background(..)-  , R.defaultBackground-  , R.same--  -- * Box properties-  , B.Bar(..)-  , B.Box-  , B.unBox--  -- * Height and columns-  , B.Height(..)-  , B.height-  , B.Width(..)-  , B.HasWidth(..)--  -- * Alignment-  , B.Align-  , B.Vert-  , B.Horiz-  , B.center-  , B.top-  , B.bottom-  , B.left-  , B.right--  -- * Reader monad-  , Specs(..)-  , Env-  , runEnv--  -- * Making Boxes-  , B.blank-  , blankH-  , blankV-  , B.chunks-  , R.chunk--  -- * Pasting Boxes together-  , catH-  , catV-  , sepH-  , sepV-  , punctuateH-  , punctuateV-  , (<->)-  , (<+>)-  , (/-/)-  , (/+/)--  -- * Viewing Boxes-  , view-  , viewH-  , viewV--  -- * Growing Boxes-  , grow-  , growH-  , growV-  , column--  -- * Resizing-  , resize-  , resizeH-  , resizeV--  -- * Printing Boxes-  , R.render-  , R.printBox-  ) where---import Control.Monad.Trans.Reader-import Data.Functor.Identity-import qualified Rainbox.Box.Primitives as B-import qualified Rainbox.Box as R-import Rainbox.Box.Primitives-  ( Box-  , Height-  , Width-  , Align-  , Horiz-  , Vert-  )--data Specs = Specs-  { background :: B.Background-  , alignH :: Align Horiz-  , alignV :: Align Vert-  , spaceH :: Int-  -- ^ Amount of intervening space for horizontal joins-  , spaceV :: Int-  --  ^ Amount of intervening space for vertical joins-  } deriving (Eq, Show)--type Env = ReaderT Specs--runEnv :: Specs -> Env Identity a -> a-runEnv s = runIdentity . ($ s) . runReaderT--blankH :: Monad m => Int -> Env m Box-blankH i = do-  b <- asks background-  return $ R.blankH b i--blankV :: Monad m => Int -> Env m Box-blankV i = do-  b <- asks background-  return $ R.blankV b i--catH :: Monad m => [Box] -> Env m Box-catH bxs = do-  bk <- asks background-  al <- asks alignV-  return $ B.catH bk al bxs--catV :: Monad m => [Box] -> Env m Box-catV bxs = do-  bk <- asks background-  al <- asks alignH-  return $ B.catV bk al bxs--grow :: Monad m => Height -> Width -> Box -> Env m Box-grow r c bx = do-  b <- asks background-  h <- asks alignH-  v <- asks alignV-  return $ R.grow b r c v h bx--growH :: Monad m => Int -> Box -> Env m Box-growH i bx = do-  b <- asks background-  h <- asks alignH-  return $ R.growH b i h bx--growV :: Monad m => Int -> Box -> Env m Box-growV i bx = do-  b <- asks background-  v <- asks alignV-  return $ R.growV b i v bx--column :: Monad m => [Box] -> Env m [Box]-column bs = do-  bk <- asks background-  ah <- asks alignH-  return $ R.column bk ah bs--resize-  :: Monad m => Height-  -> Width-  -> Box-  -> Env m Box-resize r c bx = do-  b <- asks background-  h <- asks alignH-  v <- asks alignV-  return $ R.resize b r c v h bx--resizeH-  :: Monad m => Int-  -> Box-  -> Env m Box-resizeH i bx = do-  b <- asks background-  h <- asks alignH-  return $ R.resizeH b i h bx--resizeV-  :: Monad m => Int-  -> Box-  -> Env m Box-resizeV i bx = do-  b <- asks background-  v <- asks alignV-  return $ R.resizeV b i v bx--sepH-  :: Monad m => Int-  -> [Box]-  -> Env m Box-sepH i bx = do-  b <- asks background-  v <- asks alignV-  return $ R.sepH b i v bx--sepV-  :: Monad m => Int-  -> [Box]-  -> Env m Box-sepV i bx = do-  b <- asks background-  h <- asks alignH-  return $ R.sepV b i h bx--punctuateH-  :: Monad m => Box-  -> [Box]-  -> Env m Box-punctuateH bx bxs = do-  b <- asks background-  v <- asks alignV-  return $ R.punctuateH b v bx bxs--punctuateV-  :: Monad m => Box-  -> [Box]-  -> Env m Box-punctuateV bx bxs = do-  b <- asks background-  h <- asks alignH-  return $ R.punctuateV b h bx bxs--view-  :: Monad m-  => Height-  -> Width-  -> Box-  -> Env m Box-view h w b = do-  av <- asks alignV-  ah <- asks alignH-  return $ R.view h w av ah b--viewH-  :: Monad m-  => Int-  -> Box-  -> Env m Box-viewH h b = do-  ah <- asks alignH-  return $ B.viewH h ah b--viewV-  :: Monad m-  => Int-  -> Box-  -> Env m Box-viewV h b = do-  av <- asks alignV-  return $ B.viewV h av b---- | Paste two 'Box' together horizontally with no intervening--- space.  Left fixity, precedence 5.-(<->) :: Monad m => Box -> Box -> Env m Box-(<->) l r = do-  b <- asks background-  a <- asks alignV-  return $ B.catH b a [l, r]--infixl 5 <->---- | Paste two 'Box' together horizontally.  Intervening space is--- determined by 'spaceH'.--- Left fixity, precedence 5.-(<+>) :: Monad m => Box -> Box -> Env m Box-(<+>) l r = do-  bk <- asks background-  a <- asks alignV-  sp <- asks spaceH-  bx <- blankH sp-  return $ B.catH bk a [ l, bx, r ]--infixl 5 <+>---- | Paste two 'Box' together vertically with no intervening space.--- Left fixity, precedence 6.-(/-/) :: Monad m => Box -> Box -> Env m Box-(/-/) h l = do-  b <- asks background-  a <- asks alignH-  return $ B.catV b a [ h, l ]--infixl 6 /-/---- | Paste two 'Box' together vertically.  Intervening space is--- determined by 'spaceV'.  Left fixity, precedence 6.-(/+/) :: Monad m => Box -> Box -> Env m Box-(/+/) h l = do-  bk <- asks background-  a <- asks alignH-  sp <- asks spaceV-  bx <- blankV sp-  return $ B.catV bk a [ h, bx, l ]--infixl 6 /+/
+ lib/Rainbox/Tutorial.hs view
@@ -0,0 +1,570 @@+-- Modules might be imported solely so Haddock can hyperlink the+-- identifiers++{-# OPTIONS_GHC -fno-warn-unused-imports #-}+{-# LANGUAGE OverloadedStrings #-}++{-| The Rainbox tutorial++Rainbox helps you create arrangements of (possibly) colorful text+boxes. This module contains a tutorial.  Typically the "Rainbox"+module contains all you need.  There is also a "Rainbox.Core" module+which contains all the innards of Rainbox, but ordinarily you won't+need it.++The basic building block of Rainbox is known as a @core@.  A core is+either a single 'Chunk' or a blank box of arbitrary size.  A core made+of a single 'Chunk' should not contain any newlines.  Leave newline+handling up to Rainbox.  However, Rainbox will not check to ensure+that your 'Chunk' does not contain any newline characters.  If it does+contain newlines, your boxes will not look right.  Also, Rainbox needs+to know how wide your 'Chunk' are, in columns.  To measure width,+Rainbox simply counts the number of characters in the 'Chunk'.+Therefore, if you need accented characters, be sure to use a single+character, not composed characters.  That is, to get á, use U+00E1,+not U+00B4 and U+0061.++Many things in Rainbox have height and width.  Both the height and+width of an object can be zero, but never less than zero.  A @core@+made from a 'Chunk' always has a height of 1, and its width is equal+to the number of characters in the 'Text's that make up the 'Chunk'.+A @core@ made from a blank box has the height and width that you give+it, though neither its height nor its width is ever smaller than zero.++The next biggest building block after the @core@ is @payload@.  There+are two different types of payloads: vertical payloads and horizontal+ones.  A vertical payload aligns itself next to other vertical+payloads on a vertical axis, creating a chain of payloads.  The+vertical payload also has an alignment.  The alignment determines+whether the payload lines up along the axis on its left side, right+side, or in the center of the payload.++The vertical payload also has a background color, which has type+'Radiant'.  Think of the background color as extending infinitely from+both the left and right side of the vertical payload.  When the+vertical payload is combined with other vertical payloads into a 'Box'+'Vertical', this background color is used as necessary so that the+'Box' 'Vertical' forms a rectangle.++The horizontal payload is similar to the vertical payload, but the+axis is horizontal rather than vertical.  The alignment determines+whether the payload aligns the axis along the top, center, or bottom+of the payload.  A horizontal payload also contains a background+color; it extends infinitely from both the top and bottom of the+horizontal payload.++Finally, the biggest building block of Rainbox is the box.  There are+two types of boxes: a 'Box' 'Horizontal', which holds zero or more horizontal+payloads, and a 'Box' 'Vertical', which holds zero or more vertical payloads.+Each kind of box is a 'Monoid', so you can combine it using the usual+monoid functions.  So, to give a visual, a 'Box' 'Vertical' with five payloads+might look like this:++@++-- function: 'box1'++           V Vertical axis++           +----++           | v1 |+           |    |+           +----+--------++           |     v2      |+           |             |+  +--------+-------------++  |        |+  |  v3    |+  |        |+  |        |+  +--------+----------++           |    v4    |+      +----+----+-----++      | v5      |+      |         |+      +---------+++@++Each payload is marked in the middle with @v1@, @v2@, etc.  Note how+each payload has a different size.  @v1@ and @v2@, and @v4@ have a+'left' alignment, as their left edge is lined up with the vertical+axis.  @v3@ has a 'right' alignment.  @v5@ has a 'center' alignment.+Think of each payload has having a background color extending+infinitely off of its left and right sides.  These five payloads put+together make a 'Box' 'Vertical'.  Since 'Box' 'Vertical' is a monoid,+you can combine various 'Box' 'Vertical'.  Indeed, the pictured 'Box'+'Vertical' can be built only by combining smaller 'Box' 'Vertical', as+when you create payloads they are always given to you as a single+payload wrapped in a 'Box' 'Vertical'.++Now, you want to render your 'Box' 'Vertical'.  You use the 'render' function,+which makes a sequence of Rainbow 'Chunk'.  This turns your 'Box' 'Vertical'+into a nice rectangle for on-screen rendering:++@++-- function: 'renderBox1'++  +--------+----+--------++  |        | v1 |        |+  |        |    |        |+  +--------+----+--------++  |        |     v2      |+  |        |             |+  +--------+-------------++  |        |             |+  |  v3    |             |+  |        |             |+  |        |             |+  +--------+----------+--++  |        |    v4    |  |+  +---+----+----+-----+--++  |   | v5      |        |+  |   |         |        |+  +---+---------+--------+++@++The spaces to the left and right of each payload are filled in with+the appropriate background color, which is the background+color of the adjoining payload.+++What if you want to place the 'Box' 'Vertical' alongside another box?  If you+want to put it next to another 'Box' 'Vertical', just use 'mappend' or '<>'. But+what if you want to put it next to a 'Box' 'Horizontal'?  Let's suppose you have a+'Box' 'Horizontal' that looks like this:++@++-- function: 'box2'++                        +----++                        | h1 |+                        |    |+Horizontal Axis >       +----+----------++                             |          |+                             |   h2     |+                             |          |+                             +----------+++@++The @h1@ payload has alignment 'bottom', because its bottom edge is+lined up along the horizontal axis.  The @h2@ payload has alignment+'top'.  You want to connect this 'Box' 'Horizontal' with the 'Box'+'Vertical' made above.  You can't connect them directly because they+are different types.  You can, however, take a complete 'Box' and wrap+it inside another 'Box'.  This allows you to wrap a 'Box' 'Vertical'+inside of a 'Box' 'Horizontal', and vice versa, or even wrap a 'Box'+'Horizontal' inside of another 'Box' 'Horizontal'.  You do this with+the 'wrap' function, which is applied to the alignment for the new+box, its background color, and the box you want to wrap.  ao, let's+say you take the 'Box' 'Vertical' created above and wrap it inside a+'Box' 'Horizontal' with 'top' alignment and a background color, and+then you combine it with the 'Box' 'Horizontal' created above.  The+result:++@++-- function: 'box3'++                         +----++                         | h1 |+                         |    |+  +--------+----+--------+----+----------++  |        | v1 |        |    |          |+  |        |    |        |    |    h2    |+  +--------+----+--------+    |          |+  |        |     v2      |    +----------++  |        |             |+  +--------+-------------++  |        |             |+  |  v3    |             |+  |        |             |+  |        |             |+  +--------+----------+--++  |        |    v4    |  |+  +---+----+----+-----+--++  |   | v5      |        |+  |   |         |        |+  +---+---------+--------+++@++The old 'Box' 'Vertical', which is now wrapped in a 'Box'+'Horizontal', now has a background color which extends infinitely from+the top and bottom of the box.  It is now just a payload inside of the+'Box' 'Horizontal'.  The other two payloads in the 'Box' 'Horizontal',+@h1@ and @h2@, also have background colors extending from their tops+and bottoms.++So, when you render this 'Box' 'Horizontal' with 'render', you get this:+++@++-- function: 'renderBox3'++  +----------------------+----+----------++  |                      | h1 |          |+  |                      |    |          |+  +--------+----+--------+----+----------++  |        | v1 |        |    |          |+  |        |    |        |    |    h2    |+  +--------+----+--------+    |          |+  |        |     v2      |    +----------++  |        |             |    |          |+  +--------+-------------+    |          |+  |        |             |    |          |+  |  v3    |             |    |          |+  |        |             |    |          |+  |        |             |    |          |+  +--------+----------+--+    |          |+  |        |    v4    |  |    |          |+  +---+----+----+-----+--+    |          |+  |   | v5      |        |    |          |+  |   |         |        |    |          |+  +---+---------+--------+----+----------+++@++The area above the old 'Box' 'Vertical' has the background color that we used in+the application of 'convert'.  The area below the @h1@ payload has its+background color, and the area above and below the @h2@ payload has+its background color.++What if you just want to create an empty space?  You can create entire+blank boxes with 'blank', but often it is enough to use 'spacer',+which gives you a one-dimensional 'Box' 'Horizontal' or 'Box'+'Vertical'.  If you are creating a 'Box' 'Horizontal', 'spacer' gives+you a box with width, but no height; for a 'Box' 'Vertical', you get a+box with height, but no width.  So, to return to the example 'Box'+'Horizontal', let's say you want to add a blank space a few columns+wide on the right side.  You 'mappend' a 'Box' 'Horizontal' created+with 'spacer' to get this:++@++-- function: 'box4'++                        +----++                        | h1 |+                        |    |+Horizontal Axis >       +----+----------+--++                             |          |+                             |   h2     |+                             |          |+                             +----------++@++On the right side you now have a payload with width, but no height.+But it does have a background color.  So when you 'render' the box, you+get this:+++@++-- function: 'renderBox4'++                        +----+----------+--++                        | h1 |          |  |+                        |    |          |  |+                        +----+----------+  |+                        |    |          |  |+                        |    |   h2     |  |+                        |    |          |  |+                        +----+----------+--+++@++You can also use 'spreader' to make a 'Box' 'Horizontal' taller or a+'Box' 'Vertical' wider.  'spreader' creates a one-dimensional 'Box'+that is perpendicular to the axis.  Pay attention to the alignment of+the 'spreader' as this will determine how your box expands.  Let's say+I want to take the 'Box' that contains the @h1@ and @h2@ payloads as+created above, but I also want to make sure the box is at least 12+rows tall.  To do this, 'mappend' a 'spreader' that is 12 rows tall.+The result upon 'render'ing is:++@+                        +-- functions: 'box5' 'renderBox5'++                        +----+----------+--++                        |    |          |  |+                        +----+          |  |+                        | h1 |          |  |+                        |    |          |  |+                        +----+----------+  |+                        |    |          |  |+                        |    |   h2     |  |+                        |    |          |  |+                        |    +----------+  |+                        |    |          |  |+                        +----+----------+--++@++Those are the basics of the Rainbox model, which should be enough to+get you started.  Also helpful are the 'tableByRows' and+'tableByColumns' functions, which will help you build a simple grid+that resembles a spreadsheet; see its documentation for hints to get+started with that.  You will also find an example using the+'tableByRows', as well as code to produce all of the examples shown+above, in the source code below.++== Why the use of 'Seq' everywhere, rather than lists?++Rainbox uses 'Seq' from "Data.Sequence" because lists can be+infinite.  Practically every function in Rainbox will not accept+infinite inputs, because Rainbox needs to know exactly how long and+wide various payloads and boxes are in order to line them up+correctly.  Use of the 'Seq' most accurately reflects the fact that+Rainbox does not work on infinite inputs.++-}+module Rainbox.Tutorial where++import Data.Foldable (toList)+import Data.Function ((&))+import Data.List (intersperse)+import Data.Monoid ((<>))+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Text (Text)+import qualified Data.Text as X+import qualified Rainbow+import qualified Rainbox++-- | Create a 'Box' for the given text.  The default foreground and+-- background colors of the terminal are used for the 'Text'; the+-- given background is used as the background color for any added+-- padding.+textBox :: Rainbow.Radiant -> Text -> Rainbox.Box a+textBox r = Rainbox.fromChunk Rainbox.center r . Rainbow.chunk++-- | Centers the given 'Box' within a larger 'Box' that has the given+-- height and width and background color.  The larger 'Box' has the+-- given 'Alignment'.+within+  :: Rainbox.Orientation a+  => Rainbox.Alignment a+  -> Int+  -- ^ Number of rows+  -> Int+  -- ^ Number of columns+  -> Rainbow.Radiant+  -- ^ Background color+  -> Rainbox.Box a+  -> Rainbox.Box a+within a r c b+  = Rainbox.wrap a b+  . mappend (Rainbox.spreader Rainbox.center r)+  . Rainbox.wrap Rainbox.centerH b+  . mappend (Rainbox.spreader Rainbox.center c)+  . Rainbox.wrap Rainbox.centerV b++-- | Puts the given text in the center of a box.  The resulting box is+-- center aligned.+textWithin+  :: Rainbox.Orientation a+  => Rainbox.Alignment a+  -> Int+  -- ^ Number of rows+  -> Int+  -- ^ Number of columns+  -> Rainbow.Radiant+  -- ^ Background color for smaller box+  -> Rainbow.Radiant+  -- ^ Background color for larger box+  -> Text+  -> Rainbox.Box a+textWithin a r c bs bl = Rainbox.wrap a bl . within a r c bs . textBox bs++box1 :: Rainbox.Box Rainbox.Vertical+box1 = mconcat+  [ textWithin Rainbox.left   4 6  Rainbow.blue      Rainbow.green   "v1"+  , textWithin Rainbox.left   4 15 Rainbow.red       Rainbow.magenta "v2"+  , textWithin Rainbox.right  6 10 Rainbow.yellow    Rainbow.blue    "v3"+  , textWithin Rainbox.left   3 12 Rainbow.green     Rainbow.red     "v4"+  , textWithin Rainbox.center 4 11 Rainbow.magenta   Rainbow.blue    "v5"+  ]++renderBox1 :: IO ()+renderBox1 = mapM_ Rainbow.putChunk . toList . Rainbox.render $ box1++box2 :: Rainbox.Box Rainbox.Horizontal+box2 = mconcat+  [ textWithin Rainbox.bottom 4 6  Rainbow.magenta Rainbow.green "h1"+  , textWithin Rainbox.top    5 12 Rainbow.blue    Rainbow.yellow "h2"+  ]++renderBox2 :: IO ()+renderBox2 = mapM_ Rainbow.putChunk . toList . Rainbox.render $ box2++box3 :: Rainbox.Box Rainbox.Horizontal+box3 = mconcat+  [ Rainbox.wrap Rainbox.top Rainbow.yellow box1+  , box2+  ]++renderBox3 :: IO ()+renderBox3 = mapM_ Rainbow.putChunk . toList . Rainbox.render $ box3++box4 :: Rainbox.Box Rainbox.Horizontal+box4 = box2 <> Rainbox.spacer Rainbow.cyan 3++renderBox4 :: IO ()+renderBox4 = mapM_ Rainbow.putChunk . toList . Rainbox.render $ box4++box5 :: Rainbox.Box Rainbox.Horizontal+box5 = box4 <> Rainbox.spreader Rainbox.center 12++renderBox5 :: IO ()+renderBox5 = mapM_ Rainbow.putChunk . toList . Rainbox.render $ box5++-- Sample code for 'tableByRows'+--+-- Here is a simple data type representing stations in the+-- Washington DC Metrorail system.++data Line+  = Red+  | Blue+  | Orange+  | Green+  | Yellow+  | Silver+  deriving (Eq, Ord, Show, Enum)++data Station = Station+  { name :: Text+  , metroLines :: [Line]+  , address :: [Text]+  , underground :: Bool+  }++nameCell :: Rainbow.Radiant -> Text -> Rainbox.Cell+nameCell bk nm = Rainbox.Cell cks Rainbox.top Rainbox.center bk+  where+    cks = Seq.singleton . Seq.singleton $ (Rainbow.chunk nm & Rainbow.back bk)++linesCell :: Rainbow.Radiant -> [Line] -> Rainbox.Cell+linesCell bk lns = Rainbox.Cell cks Rainbox.top Rainbox.center bk+  where+    cks = Seq.fromList . fmap (lineRow bk) $ lns++lineRow :: Rainbow.Radiant -> Line -> Seq Rainbow.Chunk+lineRow bk li = Seq.singleton ck+  where+    ck = Rainbow.chunk (X.pack . show $ li) & Rainbow.fore clr & Rainbow.back bk+    clr = case li of+      Red -> Rainbow.red+      Blue -> Rainbow.blue+      Orange -> Rainbow.yellow <> Rainbow.color256 220+      Green -> Rainbow.green+      Yellow -> Rainbow.yellow+      Silver -> Rainbow.white <> Rainbow.grey+++addressCell :: Rainbow.Radiant -> [Text] -> Rainbox.Cell+addressCell bk lns = Rainbox.Cell cks Rainbox.top Rainbox.center bk+  where+    cks = Seq.fromList . fmap addrRow $ lns+    addrRow txt = Seq.singleton $ Rainbow.chunk txt & Rainbow.back bk++undergroundCell :: Rainbow.Radiant -> Bool -> Rainbox.Cell+undergroundCell bk bl+  = Rainbox.Cell (Seq.singleton . Seq.singleton $ ck) Rainbox.top Rainbox.left bk+  where+    ck = (Rainbow.chunk $ if bl then "Yes" else "No") & Rainbow.back bk++stations :: [Station]+stations =+  [ Station "Metro Center" [Red, Orange, Silver, Blue]+            ["607 13th St NW", "Washington, DC 20005"] True++  , Station "L'Enfant Plaza" [Orange, Silver, Blue, Green, Yellow]+            ["600 Maryland Ave SW", "Washington, DC 20024"] True++  , Station "Silver Spring" [Red]+            ["8400 Colesville Rd", "Silver Spring, MD 20910"] False++  , Station "Court House" [Silver, Orange]+            ["2100 Wilson Blvd", "Arlington, VA 22201"] True++  , Station "Prince George's Plaza" [Green, Yellow]+            ["3575 East-West Hwy", "Hyattsville, MD 20782"] True+  ]++coloredBack :: Rainbow.Radiant+coloredBack = Rainbow.color256 195++-- | Converts a 'Station' to a list of 'Cell'.++stationRow :: Rainbow.Radiant -> Station -> [Rainbox.Cell]+stationRow bk st =+  [ nameCell bk . name $ st+  , linesCell bk . metroLines $ st+  , addressCell bk . address $ st+  , undergroundCell bk . underground $ st+  ]++-- Building a table of stations on a row-by-row basis.++allStationRows :: [[Rainbox.Cell]]+allStationRows+  = zipWith stationRowWithSpacers (cycle [coloredBack, mempty]) stations+  where+    stationRowWithSpacers bk+      = intersperse (Rainbox.separator bk 1)+      . stationRow bk++verticalStationTable :: Rainbox.Box Rainbox.Vertical+verticalStationTable+  = Rainbox.tableByRows+  . Seq.fromList+  . fmap Seq.fromList+  $ allStationRows++renderVerticalStationTable :: IO ()+renderVerticalStationTable+  = mapM_ Rainbow.putChunk . toList . Rainbox.render $ verticalStationTable++-- Building a table of stations on a column-by-column basis.++stationColumn :: Station -> [Rainbox.Cell]+stationColumn st =+  [ nameCell coloredBack . name $ st+  , linesCell bland . metroLines $ st+  , addressCell coloredBack . address $ st+  , undergroundCell bland . underground $ st+  ]+  where+    bland = mempty++allStationColumns :: [[Rainbox.Cell]]+allStationColumns+  = intersperse spacerColumn+  . map stationColumn+  $ stations+  where+   spacerColumn = take 4 (cycle backgrounds)+    where+      backgrounds =+        [ Rainbox.separator coloredBack 1+        , Rainbox.separator mempty 1+        ]++horizontalStationTable :: Rainbox.Box Rainbox.Horizontal+horizontalStationTable+  = Rainbox.tableByColumns+  . Seq.fromList+  . fmap Seq.fromList+  $ allStationColumns+++renderHorizontalStationTable :: IO ()+renderHorizontalStationTable+  = mapM_ Rainbow.putChunk . toList . Rainbox.render $ horizontalStationTable
− lib/Rainbox/Tutorial.lhs 
@@ -1,174 +0,0 @@-Rainbox tutorial - introduction-===============================--Rainbox (that is, *Rain*bow and *box*) helps you create colorful,-nicely formatted text boxes.  It is based on the `rainbow` package,-which provides all the color support, so read the [documentation for-that](http://hackage.haskell.org/package/rainbow) before continuing.--[boxes](http://hackage.haskell.org/package/boxes) is a similar-package but without color support.--This file is written in literate Haskell, so it compile and run for-you.  It also means that the compiler checks the examples, which-keeps them accurate.  However, HsColour does not fare so well with-literate Haskell, so this file will not look good from the-hyperlinked source in Haddock.  You're better off viewing it from a-text editor or through [the Gihub-website](http://www.github.com/massysett/rainbox).--A grid of boxes-===============--`Rainbox` is built on `Rainbox.Box`, which contains the building-blocks to create rectangular boxes of text.  Each box is justified-as appropriate and is filled in with a background color to make it-rectangular.--If your needs are complex, use `Rainbox.Box`.  Using it you can-patch boxes together into sort of a crazy quilt.  For simpler needs-you can use `Rainbox`, which only allows you to create grids of-boxes, like a spreadsheet.  This tutorial will show you how to use-the `Rainbox` module.  Everything you need from this package will be-available from the `Rainbox` module.  You will also need to import-packages from `rainbow`:--> {-# LANGUAGE OverloadedStrings #-}-> -- | If you are viewing this module in Haddock, note-> -- that the tutorial is contained in the source code of the-> -- module, which is written in literate Haskell.-> -- It is best viewed in your text editor or through-> -- Github at-> ---> -- <https://github.com/massysett/rainbox/blob/master/lib/Rainbox/Tutorial.lhs>--> module Rainbox.Tutorial where->-> import Data.List (intersperse)-> import Data.Monoid-> import Data.String-> import System.Console.Rainbow-> import Rainbox---Making a table of name data-===========================--For this example, we'll print a table of names, addresses, and-account balances.  This type holds the data we're interested in:--> data Record = Record->   { firstName :: String->   , lastName :: String->   , address :: [String]->   , phone :: String->   , email :: String->   , balance :: String->   } deriving Show--And let's make a list of some sample data:--> records :: [Record]-> records =->   [ Record->       { firstName = "Nell"->       , lastName = "Langston"->       , address = [ "Owings Mills, MD 21117" ]->       , phone = "800-588-2300"->       , email = "NellJLangston@dayrep.com"->       , balance = "0"->       }-> ->   , Record->       { firstName = "Sharon"->       , lastName = "Sutton"->       , address = [ "37 Church Street", "Flushing, NY 11354" ]->       , phone = "312-555-8100"->       , email = "SharonJSutton@teleworm.us"->       , balance = "1033.54"->       }-> ->   , Record->       { firstName = "Barack"->       , lastName = "Obama"->       , address = [ "1600 Pennsylvania Ave NW", "Washington, DC" ]->       , phone = "877-CASH-NOW"->       , email = "president@whitehouse.gov"->       , balance = "23562.00"->       }-> ->   , Record->       { firstName = "Bert and Ernie"->       , lastName = "Sesame"->       , address = [ "123 Sesame Street", "Lower Level",->                     "Sesame, WN V6B432" ]->       , phone = "+45-123-4567"->       , email = "lower@rhyta.com"->       , balance = "100,451.05"->       }->->   , Record->       { firstName = "Vip"->       , lastName = "Vipperman"->       , address = [ "10000 Smiley Lane", "Denver, CO 80266" ]->       , phone = "303-555-1212"->       , email = "vipperman@rhyta.com"->       , balance = "301.00"->       }->   ]--Building each row of cells-==========================--`Rainbox` works with rows of `Cell`s.  You build one list of `Cell`-for each row in your grid.  Here we will make the last name bold,-and the rest of the text will be plain.  We will also alternate each-row--every even row (starting with the first row) will be the-default color, and the odd rows will be yellow.  We'll make a-function that takes a `Record` and returns another function that,-when applied to a `Chunk` that contains the color for the row,-returns a list of `Cell`.  First let's make a small function that-will make a function that returns a `Cell` with our desired-defaults:--> cell :: [Chunk] -> Chunk -> Cell-> cell cks back = Cell brs left top (backgroundFromChunk back)->   where->     brs = map Bar . map ((:[]) . (<> back)) $ cks---> recordToCells :: Record -> Chunk -> [Cell]-> recordToCells r ck = map ($ ck) $->   [ cell . (:[]) . fromString . firstName $ r->   , cell . (:[]) $ (fromString (lastName r) <> bold)->   , cell . map fromString . address $ r->   , cell . (:[]) . fromString . phone $ r->   , cell . (:[]) . fromString . email $ r->   , cell . (:[]) . fromString . balance $ r->   ]--Zipping to get rows of cells-============================--> cellRows :: [[Cell]]-> cellRows = zipWith recordToCells records (cycle [mempty, f_yellow])--Adding white space between columns-==================================--If we print the table like it is now, there will be no whitespace,-as `Rainbox` does not add whitespace for you.  Fortunately this is-easy to add.  The string literal, " ", becomes a Cell due to the use-of the Overloaded Strings extension; the cell will have the default-background color.--> spacedOutCells :: [[Cell]]-> spacedOutCells = map (intersperse " ") cellRows--Printing the cells-==================--To see the result, run this function in ghci:--> printSampleBox :: IO ()-> printSampleBox = printBox . gridByRows $ spacedOutCells
− minimum-versions.txt 
@@ -1,60 +0,0 @@-This package was tested to work with these dependency-versions and compiler version.-These are the minimum versions given in the .cabal file.-Tested as of: 2014-06-14 02:31:26.107979 UTC-Path to compiler: ghc-7.4.1-Compiler description: 7.4.1--/opt/ghc/7.4.1/lib/ghc-7.4.1/package.conf.d:-    Cabal-1.14.0-    array-0.4.0.0-    base-4.5.0.0-    bin-package-db-0.0.0.0-    binary-0.5.1.0-    bytestring-0.9.2.1-    containers-0.4.2.1-    deepseq-1.3.0.0-    directory-1.1.0.2-    extensible-exceptions-0.1.1.4-    filepath-1.3.0.0-    (ghc-7.4.1)-    ghc-prim-0.2.0.0-    (haskell2010-1.1.0.1)-    (haskell98-2.0.0.1)-    hoopl-3.8.7.3-    hpc-0.5.1.1-    integer-gmp-0.4.0.0-    old-locale-1.0.0.4-    old-time-1.1.0.0-    pretty-1.1.1.0-    process-1.1.0.1-    rts-1.0-    template-haskell-2.7.0.0-    time-1.4-    unix-2.5.1.0--/home/massysett/rainbox/sunlight-8257/db:-    QuickCheck-2.7-    ansi-terminal-0.6.1.1-    ansi-wl-pprint-0.6.7.1-    async-2.0.1.5-    mtl-2.1.3.1-    optparse-applicative-0.9.0-    parsec-3.1.5-    primitive-0.5.3.0-    rainbow-0.14.0.0-    rainbox-0.4.0.4-    random-1.0.0.0-    regex-base-0.93.2-    regex-tdfa-1.2.0-    stm-2.4.3-    tagged-0.7.2-    tasty-0.8-    tasty-quickcheck-0.8.1-    terminfo-0.4.0.0-    text-0.11.3.1-    tf-random-0.5-    transformers-0.3.0.0-    transformers-compat-0.3.3.3-    unbounded-delays-0.1.0.7-
+ package.yaml view
@@ -0,0 +1,56 @@+# hpack package description.+# See+# https://github.com/sol/hpack+name: rainbox+synopsis: Two-dimensional box pretty printing, with colors+description: Please see README.md+version: 0.26.0.0+license: BSD3+license-file: LICENSE+copyright: Copyright 2014-2020 Omari Norman+author: Omari Norman+maintainer: omari@smileystation.com+stability: Experimental+homepage: https://www.github.com/massysett/rainbox+bug-reports: https://www.github.com/massysett/rainbox/issues+category: System+extra-source-files:+  - README.md+  - package.yaml+  - stack.yaml+  - changelog+verbatim:+  x-curation: uncurated++dependencies:+  - base >= 4.11 && < 5+  - text+  - bytestring+  - containers+  - rainbow+  - text+  - lens++ghc-options: -Wall+other-extensions: TemplateHaskell+source-dirs: lib+github: massysett/rainbox++library: {}++tests:+  rainbox-properties:+    main: rainbox-properties.hs+    source-dirs: test+    dependencies:+      - QuickCheck+      - tasty+      - tasty-quickcheck+  rainbox-visual:+    main: rainbox-visual.hs+    source-dirs: test+    dependencies:+      - QuickCheck+      - tasty+      - tasty-quickcheck+
rainbox.cabal view
@@ -1,161 +1,109 @@--- This Cabal file generated using the Cartel library.--- Cartel is available at:--- http://www.github.com/massysett/cartel+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.2. ----- Script name used to generate: genCabal.hs--- Generated on: 2014-06-13 22:45:04.610521 EDT--- Cartel library version: 0.10.0.2-name: rainbox-version: 0.4.0.4-cabal-version: >= 1.14-build-type: Simple-license: BSD3-license-file: LICENSE-copyright: Copyright 2014 Omari Norman-author: Omari Norman-maintainer: omari@smileystation.com-stability: Experimental-homepage: http://www.github.com/massysett/rainbox-bug-reports: http://www.github.com/massyett/rainbox/issues-synopsis: Two-dimensional box pretty printing, with colors-description:-  Prints boxes in two dimensions, with colors.  Boxes are-  automatically padded with necessary whitespace.-  .-  For more information, please see the Haddock documentation and-  .-  <http://www.github.com/massysett/rainbox-category: Text-tested-with: GHC == 7.4.1, GHC == 7.6.3, GHC == 7.8.2+-- see: https://github.com/sol/hpack+--+-- hash: 193ccd0b7369b9e4c418620fcc9b26fc75f29e88edb4dad7b788f1a44827f352++name:           rainbox+version:        0.26.0.0+synopsis:       Two-dimensional box pretty printing, with colors+description:    Please see README.md+category:       System+stability:      Experimental+homepage:       https://www.github.com/massysett/rainbox+bug-reports:    https://www.github.com/massysett/rainbox/issues+author:         Omari Norman+maintainer:     omari@smileystation.com+copyright:      Copyright 2014-2020 Omari Norman+license:        BSD3+license-file:   LICENSE+build-type:     Simple extra-source-files:     README.md-  , sunlight-test.hs-  , minimum-versions.txt-  , current-versions.txt-  , changelog+    package.yaml+    stack.yaml+    changelog+x-curation:     uncurated  source-repository head   type: git-  location: git://github.com/massysett/rainbox.git-  branch: master--Flag mosaic-  Description: Build the rainbox-mosaic executable-  Default: False-  Manual: True+  location: https://github.com/massysett/rainbox -Library+library   exposed-modules:       Rainbox-    , Rainbox.Array2d-    , Rainbox.Box-    , Rainbox.Box.Primitives-    , Rainbox.Reader-    , Rainbox.Tutorial-  default-language: Haskell2010-  ghc-options:-      -Wall+      Rainbox.BicolorTable+      Rainbox.Core+      Rainbox.Tutorial+  other-modules:+      Paths_rainbox   hs-source-dirs:       lib+  other-extensions: TemplateHaskell+  ghc-options: -Wall   build-depends:-      base ((> 4.5.0.0 || == 4.5.0.0) && < 4.8.0.0)-    , rainbow ((> 0.14.0.0 || == 0.14.0.0) && < 0.15)-    , text ((> 0.11.3.1 || == 0.11.3.1) && < 1.2.0.0)-    , transformers ((> 0.3.0.0 || == 0.3.0.0) && < 0.5.0.0)-    , array ((> 0.4.0.0 || == 0.4.0.0) && < 0.6.0.0)--Executable rainbox-mosaic-  main-is: rainbox-mosaic.hs-  if flag(mosaic)-    ghc-options:-        -Wall-    other-modules:-        Rainbox-      , Rainbox.Array2d-      , Rainbox.Box-      , Rainbox.Box.Primitives-      , Rainbox.Reader-      , Rainbox.Tutorial-      , Rainbox.Array2dTests-      , Rainbox.Box.PrimitivesTests-      , Rainbox.BoxDir-      , Rainbox.BoxTests-      , Rainbox.ReaderTests-      , RainboxDir-      , RainboxTests-      , Test.Rainbow.Generators-      , Visual-    hs-source-dirs:-        test-      , lib-    default-language: Haskell2010-    build-depends:-        base ((> 4.5.0.0 || == 4.5.0.0) && < 4.8.0.0)-      , rainbow ((> 0.14.0.0 || == 0.14.0.0) && < 0.15)-      , text ((> 0.11.3.1 || == 0.11.3.1) && < 1.2.0.0)-      , transformers ((> 0.3.0.0 || == 0.3.0.0) && < 0.5.0.0)-      , array ((> 0.4.0.0 || == 0.4.0.0) && < 0.6.0.0)-    build-depends:-        tasty ((> 0.8 || == 0.8) && < 0.9)-      , tasty-quickcheck ((> 0.8.1 || == 0.8.1) && < 0.9)-      , QuickCheck ((> 2.7 || == 2.7) && < 2.8)-      , random ((> 1.0.0.0 || == 1.0.0.0) && < 1.1)-  else-    buildable: False+      base >=4.11 && <5+    , bytestring+    , containers+    , lens+    , rainbow+    , text+  default-language: Haskell2010 -Test-Suite rainbox-test-  ghc-options:-      -Wall+test-suite rainbox-properties   type: exitcode-stdio-1.0+  main-is: rainbox-properties.hs+  other-modules:+      Rainbox+      Rainbox.BicolorTable+      Rainbox.Core+      Rainbox.Tutorial+      Rainbow.Instances+      Rainbox.Instances+      Paths_rainbox   hs-source-dirs:+      lib       test-    , lib-  default-language: Haskell2010-  build-depends:-      base ((> 4.5.0.0 || == 4.5.0.0) && < 4.8.0.0)-    , rainbow ((> 0.14.0.0 || == 0.14.0.0) && < 0.15)-    , text ((> 0.11.3.1 || == 0.11.3.1) && < 1.2.0.0)-    , transformers ((> 0.3.0.0 || == 0.3.0.0) && < 0.5.0.0)-    , array ((> 0.4.0.0 || == 0.4.0.0) && < 0.6.0.0)-  main-is: rainbox-test.hs+  other-extensions: TemplateHaskell+  ghc-options: -Wall   build-depends:-      tasty ((> 0.8 || == 0.8) && < 0.9)-    , tasty-quickcheck ((> 0.8.1 || == 0.8.1) && < 0.9)-    , QuickCheck ((> 2.7 || == 2.7) && < 2.8)+      QuickCheck+    , base >=4.11 && <5+    , bytestring+    , containers+    , lens+    , rainbow+    , tasty+    , tasty-quickcheck+    , text+  default-language: Haskell2010 -Test-Suite rainbox-visual+test-suite rainbox-visual   type: exitcode-stdio-1.0-  ghc-options:-      -Wall+  main-is: rainbox-visual.hs   other-modules:       Rainbox-    , Rainbox.Array2d-    , Rainbox.Box-    , Rainbox.Box.Primitives-    , Rainbox.Reader-    , Rainbox.Tutorial-    , Rainbox.Array2dTests-    , Rainbox.Box.PrimitivesTests-    , Rainbox.BoxDir-    , Rainbox.BoxTests-    , Rainbox.ReaderTests-    , RainboxDir-    , RainboxTests-    , Test.Rainbow.Generators-    , Visual-  main-is: rainbox-visual.hs+      Rainbox.BicolorTable+      Rainbox.Core+      Rainbox.Tutorial+      Rainbow.Instances+      Rainbox.Instances+      Paths_rainbox   hs-source-dirs:+      lib       test-    , lib-  default-language: Haskell2010-  build-depends:-      base ((> 4.5.0.0 || == 4.5.0.0) && < 4.8.0.0)-    , rainbow ((> 0.14.0.0 || == 0.14.0.0) && < 0.15)-    , text ((> 0.11.3.1 || == 0.11.3.1) && < 1.2.0.0)-    , transformers ((> 0.3.0.0 || == 0.3.0.0) && < 0.5.0.0)-    , array ((> 0.4.0.0 || == 0.4.0.0) && < 0.6.0.0)+  other-extensions: TemplateHaskell+  ghc-options: -Wall   build-depends:-      tasty ((> 0.8 || == 0.8) && < 0.9)-    , tasty-quickcheck ((> 0.8.1 || == 0.8.1) && < 0.9)-    , QuickCheck ((> 2.7 || == 2.7) && < 2.8)-    , random ((> 1.0.0.0 || == 1.0.0.0) && < 1.1)+      QuickCheck+    , base >=4.11 && <5+    , bytestring+    , containers+    , lens+    , rainbow+    , tasty+    , tasty-quickcheck+    , text+  default-language: Haskell2010
+ stack.yaml view
@@ -0,0 +1,3 @@+resolver: lts-14.14+extra-deps:+  - rainbow-0.34.0.0
− sunlight-test.hs 
@@ -1,15 +0,0 @@-module Main where--import Test.Sunlight--inputs = TestInputs-  { tiDescription = Nothing-  , tiCabal = "cabal"-  , tiLowest = ("7.4.1", "ghc-7.4.1", "ghc-pkg-7.4.1")-  , tiDefault = [ ("7.4.1", "ghc-7.4.1", "ghc-pkg-7.4.1")-                , ("7.6.3", "ghc-7.6.3", "ghc-pkg-7.6.3")-                , ("7.8.2", "ghc-7.8.2", "ghc-pkg-7.8.2") ]-  , tiTest = []-  }--main = runTests inputs
+ test/Rainbow/Instances.hs view
@@ -0,0 +1,104 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances, DeriveGeneric, StandaloneDeriving #-}++-- | QuickCheck instances for all of Rainbow.  Currently Rainbow does+-- not use these instances itself; they are only here for+-- cut-and-paste for other libraries that may need them.  There is an+-- executable in Rainbow that is built solely to make sure this module+-- compiles without any errors.+--+-- To use these instances, just drop them into your own project+-- somewhere.  They are not packaged as a library because there are+-- orphan instances.++module Rainbow.Instances where++import Test.QuickCheck+import Rainbow.Types+import qualified Data.Text as X++instance Arbitrary a => Arbitrary (Color a) where+  arbitrary = Color <$> arbitrary+  shrink = genericShrink++instance CoArbitrary a => CoArbitrary (Color a) where+  coarbitrary (Color a) = coarbitrary a++varInt :: Int -> Gen b -> Gen b+varInt = variant++instance Arbitrary Enum8 where+  arbitrary = elements [E0, E1, E2, E3, E4, E5, E6, E7]+  shrink = genericShrink++instance CoArbitrary Enum8 where+  coarbitrary x = case x of+    E0 -> varInt 0+    E1 -> varInt 1+    E2 -> varInt 2+    E3 -> varInt 3+    E4 -> varInt 4+    E5 -> varInt 5+    E6 -> varInt 6+    E7 -> varInt 7++instance Arbitrary Format where+  arbitrary+    = Format <$> g <*> g <*> g <*> g <*> g <*> g <*> g <*> g+    where+      g = arbitrary+  shrink = genericShrink++instance CoArbitrary Format where+  coarbitrary (Format x0 x1 x2 x3 x4 x5 x6 x7)+    = coarbitrary x0+    . coarbitrary x1+    . coarbitrary x2+    . coarbitrary x3+    . coarbitrary x4+    . coarbitrary x5+    . coarbitrary x6+    . coarbitrary x7++instance Arbitrary a => Arbitrary (Style a) where+  arbitrary = Style <$> arbitrary <*> arbitrary <*> arbitrary+  shrink = genericShrink++instance CoArbitrary a => CoArbitrary (Style a) where+  coarbitrary (Style a b c)+    = coarbitrary a+    . coarbitrary b+    . coarbitrary c+++instance Arbitrary Scheme where+  arbitrary = Scheme <$> arbitrary <*> arbitrary+  shrink = genericShrink++instance CoArbitrary Scheme where+  coarbitrary (Scheme a b) = coarbitrary a . coarbitrary b++instance Arbitrary Chunk where+  arbitrary = Chunk <$> arbitrary <*> arbitrary+  shrink = genericShrink++instance CoArbitrary Chunk where+  coarbitrary (Chunk a b)+    = coarbitrary a+    . coarbitrary b++instance Arbitrary Radiant where+  arbitrary = Radiant <$> arbitrary <*> arbitrary+  shrink = genericShrink++instance CoArbitrary Radiant where+  coarbitrary (Radiant a b) = coarbitrary a . coarbitrary b++instance Arbitrary X.Text where+  arbitrary = fmap X.pack $ listOf genChar+    where+      genChar = elements ['a'..'z']+  shrink = fmap X.pack . shrink . X.unpack++instance CoArbitrary X.Text where+  coarbitrary = coarbitrary . X.unpack
− test/Rainbox/Array2dTests.hs 
@@ -1,389 +0,0 @@-module Rainbox.Array2dTests where--import Test.Tasty-import Test.QuickCheck-import Test.Tasty.QuickCheck (testProperty)-import Data.Array-import Rainbox.Array2d---- | Generates a two-dimensional array of Int.  The size of the--- array depends on the size parameter.-genArray :: Gen (Array (Int, Int) Int)-genArray = do-  bnds <- genBounds-  let nElems = rangeSize bnds-  es <- vectorOf nElems arbitraryBoundedIntegral-  return $ listArray bnds es---- | Generates array bounds.  The size of the bounds depends on the--- size parameter.-genBounds :: Gen ((Int, Int), (Int, Int))-genBounds = do-  w:x:y:z:[] <- vectorOf 4 arbitrarySizedIntegral-  let (minC, maxC) | w < x = (w, x)-                   | otherwise = (x, w)-      (minR, maxR) | y < z = (y, z)-                   | otherwise = (z, y)-  return ((minC, minR), (maxC, maxR))--genTable :: Gen (Table (Int, [(Int, Int)]) (Int, [(Int, Int)]) Int Int Int)-genTable = do-  ay <- genArray-  return $ table (,) (,) ay--type LabelF-  = (Int, [(Int, Int)])-  -> (Int, [(Int, Int)])-  -> Int -> Int -> Int -> Int--type ChangeLabelF-  = (Int, [(Int, Int)])-  -> Int-  -> [((Int, [(Int, Int)]), Int, Int)]-  -> Int--genLabelF :: Gen LabelF-genLabelF = arbitrary--genChangeLabelF :: Gen ChangeLabelF-genChangeLabelF = arbitrary---- # Properties---- | Bounds of columns in a Table matches those of the cells-propTableColsBounds-  :: (Ix col, Ix row)-  => Table lCol lRow col row a-  -> Bool-propTableColsBounds tbl = bounds cls == tgtBounds-  where-    cls = lCols tbl-    ((minC, _), (maxC, _)) = bounds . cells $ tbl-    tgtBounds = (minC, maxC)---- | Bounds of rows in a Table matches those of the cells-propTableRowsBounds-  :: (Ix col, Ix row)-  => Table lCol lRow col row a-  -> Bool-propTableRowsBounds tbl = bounds rws == tgtBounds-  where-    rws = lRows tbl-    ((_, minR), (_, maxR)) = bounds . cells $ tbl-    tgtBounds = (minR, maxR)---- | Generating a table using the contents of the rows as labels--- allows reconstruction of the original array--propGenRebuildByRow-  :: (Ix col, Ix row, Eq a)-  => Array (col, row) a-  -> Bool-propGenRebuildByRow ay = ay == ay'-  where-    ay' = array (bounds ay) . concat . elems . lRows-      . table (\_ _ -> ()) fRow $ ay-    fRow rw ls = map g ls-      where-        g (col, a) = ((col, rw), a)---- | Generating a table using the contents of the columns as labels--- allows reconstruction of the original array--propGenRebuildByCol-  :: (Ix col, Ix row, Eq a)-  => Array (col, row) a-  -> Bool-propGenRebuildByCol ay = ay == ay'-  where-    ay' = array (bounds ay) . concat . elems . lCols-      . table fCol (\_ _ -> ()) $ ay-    fCol cl ls = map g ls-      where-        g (rw, a) = ((cl, rw), a)---- | Round-tripping through rows and arrayByRows-propRoundTripRows-  :: Eq a-  => Array (Int, Int) a-  -> Bool-propRoundTripRows ay = sameShape ay ay'-  where-    ay' = arrayByRows . rows $ ay---- | Round-tripping through columns and arrayByCols-propRoundTripCols-  :: (Eq a, Show a)-  => Array (Int, Int) a-  -> Bool-propRoundTripCols ay = sameShape ay ay'-  where-    ay' = arrayByCols . cols $ ay---- | True if both arrays have the same shape; that is, the same--- number of rows and the same number of columns and the same--- elements.--sameShape-  :: (Ix col, Ix row, Eq a)-  => Array (col, row) a-  -> Array (col, row) a-  -> Bool-sameShape x y = rx == ry && cx == cy && ex == ey-  where-    ((minCx, minRx), (maxCx, maxRx)) = bounds x-    ((minCy, minRy), (maxCy, maxRy)) = bounds y-    rx = rangeSize (minRx, maxRx)-    ry = rangeSize (minRy, maxRy)-    cx = rangeSize (minCx, maxCx)-    cy = rangeSize (minCy, maxCy)-    ex = elems x-    ey = elems y---- # mapTable properties---- | mapTable does not change lCols-mapTableNoChangeCols-  :: (Ix col, Ix row, Eq lCol)-  => (lCol -> lRow -> col -> row -> a -> b)-  -> Table lCol lRow col row a-  -> Bool-mapTableNoChangeCols f t = lCols t == lCols t'-  where-    t' = mapTable f t---- | mapTable does not change lRows-mapTableNoChangeRows-  :: (Ix col, Ix row, Eq lRow)-  => (lCol -> lRow -> col -> row -> a -> b)-  -> Table lCol lRow col row a-  -> Bool-mapTableNoChangeRows f t = lRows t == lRows t'-  where-    t' = mapTable f t---- | mapTable allows rebuild of original array-mapTableRebuildNoIndices-  :: (Ix col, Ix row, Eq a)-  => Table lCol lRow col row a-  -> Bool-mapTableRebuildNoIndices tbl = cells tbl == ay'-  where-    ay' = listArray (bounds . cells $ tbl) . elems . cells-        . mapTable f $ tbl-    f _ _ _ _ a = a--mapTableRebuildWithIndices-  :: (Ix col, Ix row, Eq a)-  => Table lCol lRow col row a-  -> Bool-mapTableRebuildWithIndices tbl = cells tbl == ay'-  where-    ay' = array (bounds . cells $ tbl) . elems . cells-      . mapTable f $ tbl-    f _ _ cl rw a = ((cl, rw), a)---- # labelRows and labelCols properties---- | labelCols allows rebuild of original array-propLabelColsRebuild-  :: (Ix col, Ix row, Eq a)-  => Array (col, row) a-  -> Bool-propLabelColsRebuild ay = ay == ay'-  where-    ay' = array (bounds ay) . concat . elems-      . labelCols f $ ay-    f cl ls = map g ls-      where-        g (rw, a) = ((cl, rw), a)---- | labelRows allows rebuild of original array-propLabelRowsRebuild-  :: (Ix col, Ix row, Eq a)-  => Array (col, row) a-  -> Bool-propLabelRowsRebuild ay = ay == ay'-  where-    ay' = array (bounds ay) . concat . elems-      . labelRows f $ ay-    f rw ls = map g ls-      where-        g (cl, a) = ((cl, rw), a)---- # mapRowLabels properties---- | mapRowLabels does not change column labels-propMapRowLabelsCols-  :: (Ix col, Ix row, Eq lCol)-  => (lRow -> row -> [(lCol, col, a)] -> lRow')-  -> Table lCol lRow col row a-  -> Bool-propMapRowLabelsCols f tb = lbls == lbls'-  where-    lbls = lCols tb-    tb' = mapRowLabels f tb-    lbls' = lCols tb'---- | mapRowLabels does not change cells-propMapRowLabelsCells-  :: (Ix col, Ix row, Eq a, Eq lCol)-  => (lRow -> row -> [(lCol, col, a)] -> lRow')-  -> Table lCol lRow col row a-  -> Bool-propMapRowLabelsCells f tb = ay == ay'-  where-    ay = cells tb-    tb' = mapRowLabels f tb-    ay' = cells tb'---- | mapRowLabels permits reconstruction of original array-propMapRowLabelsRebuild-  :: (Ix col, Ix row, Eq a)-  => Table lCol lRow col row a-  -> Bool-propMapRowLabelsRebuild t = ay == ay'-  where-    ay = cells t-    ay' = array (bounds ay) . concat . elems-      . lRows . mapRowLabels f $ t-    f _ rw ls = map g ls-      where-        g (_, cl, a) = ((cl, rw), a)---- | mapRowLabels gives the original row labels-propMapRowLabelsRelabel-  :: (Ix col, Ix row, Eq a, Eq lRow, Eq lCol)-  => Table lCol lRow col row a-  -> Bool-propMapRowLabelsRelabel t = t == t'-  where-    t' = mapRowLabels (\r _ _ -> r) t---- # mapColLabels properties---- | mapColLabels does not change row labels-propMapColLabelsCols-  :: (Ix col, Ix row, Eq lRow)-  => (lCol -> col -> [(lRow, row, a)] -> lCol')-  -> Table lCol lRow col row a-  -> Bool-propMapColLabelsCols f tb = lbls == lbls'-  where-    lbls = lRows tb-    tb' = mapColLabels f tb-    lbls' = lRows tb'---- | mapColLabels does not change cells-propMapColLabelsCells-  :: (Ix col, Ix row, Eq a, Eq lCol)-  => (lCol -> col -> [(lRow, row, a)] -> lCol')-  -> Table lCol lRow col row a-  -> Bool-propMapColLabelsCells f tb = ay == ay'-  where-    ay = cells tb-    tb' = mapColLabels f tb-    ay' = cells tb'---- | mapColLabels permits reconstruction of original array-propMapColLabelsRebuild-  :: (Ix col, Ix row, Eq a)-  => Table lCol lRow col row a-  -> Bool-propMapColLabelsRebuild t = ay == ay'-  where-    ay = cells t-    ay' = array (bounds ay) . concat . elems-      . lCols . mapColLabels f $ t-    f _ cl ls = map g ls-      where-        g (_, rw, a) = ((cl, rw), a)---- | mapColLabels gives the original row labels-propMapColLabelsRelabel-  :: (Ix col, Ix row, Eq a, Eq lRow, Eq lCol)-  => Table lCol lRow col row a-  -> Bool-propMapColLabelsRelabel t = t == t'-  where-    t' = mapColLabels (\r _ _ -> r) t--tests :: TestTree-tests = testGroup "Array2d"-  [ testProperty "bounds of columns in Table matches those of cells" $-    forAll genTable $-    propTableColsBounds--  , testProperty "bounds of rows in Table matches those of cells" $-    forAll genTable $-    propTableRowsBounds--  , testProperty "propGenRebuildByRow" $-    forAll genArray propGenRebuildByRow--  , testProperty "propGenRebuildByCol" $-    forAll genArray propGenRebuildByCol--  , testProperty "propRoundTripRows" $-    forAll genArray propRoundTripRows--  , testProperty "propRoundTripCols" $-    forAll genArray propRoundTripCols--  , testProperty "mapTableNoChangeCols" $-    forAll genLabelF $ \f ->-    forAll genTable $ \t ->-    mapTableNoChangeCols f t--  , testProperty "mapTableNoChangeRows" $-    forAll genLabelF $ \f ->-    forAll genTable $ \t ->-    mapTableNoChangeRows f t--  , testProperty "mapTableRebuildNoIndices" $-    forAll genTable mapTableRebuildNoIndices--  , testProperty "mapTableRebuildWithIndices" $-    forAll genTable mapTableRebuildWithIndices--  , testProperty "propLabelColsRebuild" $-    forAll genArray propLabelColsRebuild--  , testProperty "propLabelRowsRebuild" $-    forAll genArray propLabelRowsRebuild--  , testProperty "propMapRowLabelsCols" $-    forAll genChangeLabelF $ \f ->-    forAll genTable $ \t ->-    propMapRowLabelsCols f t--  , testProperty "propMapRowLabelsCells" $-    forAll genChangeLabelF $ \f ->-    forAll genTable $ \t ->-    propMapRowLabelsCells f t--  , testProperty "propMapRowLabelsRebuild" $-    forAll genTable propMapRowLabelsRebuild--  , testProperty "propMapRowLabelsRelabel" $-    forAll genTable propMapRowLabelsRelabel--  , testProperty "propMapColLabelsCols" $-    forAll genChangeLabelF $ \f ->-    forAll genTable $ \t ->-    propMapColLabelsCols f t--  , testProperty "propMapColLabelsCells" $-    forAll genChangeLabelF $ \f ->-    forAll genTable $ \t ->-    propMapColLabelsCells f t--  , testProperty "propMapColLabelsRebuild" $-    forAll genTable propMapColLabelsRebuild--  , testProperty "propMapColLabelsRelabel" $-    forAll genTable propMapColLabelsRelabel--  ]-
− test/Rainbox/Box/PrimitivesTests.hs 
@@ -1,222 +0,0 @@-module Rainbox.Box.PrimitivesTests where--import Control.Monad-import Control.Applicative-import Test.Tasty-import Test.Tasty.QuickCheck (testProperty)-import Test.QuickCheck-import System.Console.Rainbow-import qualified Data.Text as X-import qualified Test.Rainbow.Generators as G-import Rainbox.Box.Primitives-import Rainbox.Box (backgroundToTextSpec)--genText :: Gen X.Text-genText = fmap X.pack $ listOf c-  where-    c = elements ['0'..'Z']--genChunk :: Gen Chunk-genChunk = listOf genText >>= G.chunk--genHeight :: Gen Height-genHeight = fmap Height $ frequency [(3, nonNeg), (1, neg)]-  where-    nonNeg = fmap getNonNegative arbitrarySizedIntegral-    neg = fmap (negate . abs) arbitrarySizedIntegral--genWidth :: Gen Width-genWidth = fmap Width $ frequency [(3, nonNeg), (1, neg)]-  where-    nonNeg = fmap abs arbitrarySizedIntegral-    neg = fmap (negate . abs) arbitrarySizedIntegral--genBackground :: Gen Background-genBackground = liftM2 Background G.colors8 G.colors256---- | Generates blank Box.-genBlankBox :: Gen Box-genBlankBox = liftM3 blank genBackground rw cl-  where-    rw = fmap (Height . abs) arbitrarySizedIntegral-    cl = fmap (Width . abs) arbitrarySizedIntegral---- | Generates a box using chunks.-genChunkBox :: Gen Box-genChunkBox = fmap chunks $ listOf genChunk---- | Generates a box using catH.-genCatHBox :: Gen Box-genCatHBox = sized $ \s -> do-  bk <- genBackground-  av <- genAlignVert-  bs <- listOf (resize (s `div` 2) genBox)-  return $ catH bk av bs---- | Generates a box using catV.-genCatVBox :: Gen Box-genCatVBox = sized $ \s -> do-  bk <- genBackground-  ah <- genAlignHoriz-  bs <- listOf (resize (s `div` 2) genBox)-  return $ catV bk ah bs---- | Generates a random box.-genBox :: Gen Box-genBox = oneof [ genBlankBox, genCatHBox, genCatVBox, genChunkBox ]--genChunkLen :: Background -> Int -> Gen Chunk-genChunkLen bk l = do-  let ts = backgroundToTextSpec bk-  txt <- fmap X.pack $ vectorOf l (elements ['0'..'Z'])-  return $ Chunk ts [txt]---- | Generates a box of text; its horizontal and vertical size--- depends on the size parameter.-genTextBox :: Gen Box-genTextBox = do-  w <- fmap abs arbitrarySizedIntegral-  h <- fmap abs arbitrarySizedIntegral-  bk <- genBackground-  cks <- vectorOf h (genChunkLen bk w)-  let bxs = map (chunks . (:[])) cks-  bk' <- genBackground-  return $ catV bk' left bxs------ # Alignment--genAlignVert :: Gen (Align Vert)-genAlignVert = elements-  [ center, top, bottom ]--genAlignHoriz :: Gen (Align Horiz)-genAlignHoriz = elements [ center, left, right ]--validBox :: Box -> Bool-validBox box = case unBox box of-  NoHeight i -> i > -1-  WithHeight rw -> case rw of-    [] -> False-    x:xs -> all (== width x) . map width $ xs--biggest :: Int -> Gen a -> Gen a-biggest m g = sized $ \s -> resize (min s m) g--data Inputs = Inputs-  { iChunks :: [Chunk]-  , iBackground :: Background-  , iHeight :: Height-  , iWidth :: Width-  , iVert :: Align Vert-  , iHoriz :: Align Horiz-  , iBoxes :: [Box]-  , iBox :: Box-  , iChunk :: Chunk-  } deriving Show--instance Arbitrary Inputs where-  arbitrary = Inputs-    <$> listOf genChunk-    <*> genBackground-    <*> genHeight-    <*> genWidth-    <*> genAlignVert-    <*> genAlignHoriz-    <*> listOf genBlankBox-    <*> genBlankBox-    <*> genChunk--tests :: TestTree-tests = testGroup "BoxTests"-  [ testGroup "blank"-    [ testProperty "makes valid Box" $ \i ->-      validBox $ blank (iBackground i) (iHeight i)-        (iWidth i)--    , testProperty "has right number of rows" $ \i ->-      let ht = unHeight . iHeight $ i-      in (== max 0 ht) . height $ blank (iBackground i)-            (iHeight i) (iWidth i)--    , testProperty "has right number of columns" $ \i ->-      let wt = unWidth . iWidth $ i-      in (== max 0 wt) . width $ blank (iBackground i)-            (iHeight i) (iWidth i)-    ]--  , testGroup "chunks"-    [ testProperty "makes valid Box" $-      validBox . chunks . iChunks--    , testProperty "makes Box whose height is 1" $-      (== 1) . height . chunks . iChunks--    , testProperty "makes Box with cols == number of characters" $ \i ->-      let cks = iChunks i-          nChars = sum . map X.length . concat . map text $ cks-      in (== nChars) . width $ chunks cks-    ]--  , testGroup "catH"-    [ testProperty "makes valid Box" $ \i ->-      validBox $ catH (iBackground i) (iVert i) (iBoxes i)--    , testProperty "is as tall as tallest box" $ \i ->-      let h = maximum . (0 :) . map height $ bs-          bs = iBoxes i-      in (== h) . height $ catH (iBackground i) (iVert i) bs--    , testProperty "is as wide as sum of all widths" $ \i ->-      let s = sum . map width $ bs-          bs = iBoxes i-      in (== s) . width $ catH (iBackground i) (iVert i) bs-    ]--  , testGroup "catV"-    [ testProperty "makes a valid Box" $ \i ->-      validBox $ catV (iBackground i) (iHoriz i) (iBoxes i)--    , testProperty "is as tall as the sum of all heights" $ \i ->-      let h = sum . map height $ bs-          bs = iBoxes i-      in (== h) . height $ catV (iBackground i) (iHoriz i) bs--    , testProperty "is as wide as the widest box" $ \i ->-      let w = maximum . (0:) . map width $ bs-          bs = iBoxes i-      in (== w) . width $ catV (iBackground i) (iHoriz i) bs-    ]--  , testGroup "viewH"-    [ testProperty "makes a valid Box" $ \i ->-      validBox $ viewH (unWidth . iWidth $ i) (iHoriz i) (iBox i)--    , testProperty "number of rows does not change" $ \i ->-      let b = iBox i-      in (== height b) . height $ viewH (unWidth . iWidth $ i)-                                    (iHoriz i) b--    , testProperty "number of columns <= number requested" $ \i ->-      let c = unWidth . iWidth $ i-          tgt = max 0 c-      in (<= tgt) . width $ viewH c (iHoriz i) (iBox i)-    ]--  , testGroup "viewV"-    [ testProperty "makes a valid Box" $ \i ->-      validBox $ viewV (unHeight . iHeight $ i) (iVert i) (iBox i)--    , testProperty "width does not change" $ \i ->-      let b = iBox i-      in (== width b) . width $ viewV (unHeight . iHeight $ i)-                                    (iVert i) b--    , testProperty "number of rows <= number requested" $ \i ->-      let r = unHeight . iHeight $ i-          tgt = max 0 r-      in (<= tgt) . height $ viewV r (iVert i) (iBox i)-    ]-  ]-
− test/Rainbox/BoxDir.hs 
@@ -1,7 +0,0 @@-module Rainbox.BoxDir where--import qualified Rainbox.Box.PrimitivesTests-import Test.Tasty--tests :: TestTree-tests = testGroup "Box" [ Rainbox.Box.PrimitivesTests.tests ]
− test/Rainbox/BoxTests.hs 
@@ -1,207 +0,0 @@-module Rainbox.BoxTests where--import Rainbox.Box-import Rainbox.Box.PrimitivesTests-import qualified Data.Text as X-import Test.Tasty.QuickCheck (testProperty)-import Test.Tasty-import System.Console.Rainbow-import Test.QuickCheck hiding (resize)--tests :: TestTree-tests = testGroup "RainboxTests"-  [ testGroup "blankH"-    [ testProperty "makes Box with no height" $ \i ->-      (== 0) . height $ blankH (iBackground i) (unWidth . iWidth $ i)--    , testProperty "makes Box with correct width" $ \i ->-      let w = unWidth . iWidth $ i-          tgt = max 0 w-      in (== tgt) . width $ blankH (iBackground i) w-    ]--  , testGroup "blankV"-    [ testProperty "makes Box with no width" $ \i ->-      (== 0) . width $ blankV (iBackground i) (unHeight . iHeight $ i)--    , testProperty "makes Box with correct height" $ \i ->-      let h = unHeight . iHeight $ i-          tgt = max 0 h-      in (== tgt) . height $ blankV (iBackground i) h-    ]--  , testGroup "chunk"-    [ testProperty "makes Box one high" $-      (== 1) . height . chunk . iChunk--    , testProperty "makes Box as wide as characters in chunk" $ \i ->-      let cs = sum . map X.length . text . iChunk $ i-      in (== cs) . width . chunk . iChunk $ i-    ]--  , testGroup "growH"-    [ testProperty "does not change height" $ \i ->-      let bx = iBox i-      in (== height bx) . height $ growH (iBackground i)-            (unWidth . iWidth $ i) (iHoriz i) bx--    , testProperty "new Box is of correct width" $ \i ->-      let bx = iBox i-          tgt = max wdth (width bx)-          wdth = unWidth . iWidth $ i-      in (== tgt) . width $-            growH (iBackground i) wdth (iHoriz i) bx--    , testProperty "new Box is at least as wide as old Box" $ \i ->-      let bx = iBox i-      in (>= width bx) . width $ growH (iBackground i)-            (unWidth . iWidth $ i) (iHoriz i) bx-    ]--  , testGroup "growV"-    [ testProperty "does not change width" $ \i ->-      let bx = iBox i-      in (== width bx) . width $ growV (iBackground i)-            (unWidth . iWidth $ i) (iVert i) bx--    , testProperty "new Box is of correct height" $ \i ->-      let bx = iBox i-          tgt = max (height bx) hght-          hght = unHeight . iHeight $ i-      in (== tgt) . height $-            growV (iBackground i) hght (iVert i) bx--    , testProperty "new Box is at least as tall as old Box" $ \i ->-      let bx = iBox i-      in (>= height bx) . height $ growV (iBackground i)-            (unWidth . iWidth $ i) (iVert i) bx-    ]--  , testGroup "grow"-    [  testProperty "new Box is of correct width" $ \i ->-      let bx = iBox i-          tgt = unWidth . iWidth $ i-      in (\w -> w == width bx || w == tgt) . width $-            growH (iBackground i) tgt (iHoriz i) bx--    , testProperty "new Box is at least as wide as old Box" $ \i ->-      let bx = iBox i-      in (>= width bx) . width $ grow (iBackground i) (iHeight i)-            (iWidth i) (iVert i) (iHoriz i) (iBox i)--    , testProperty "new Box is of correct height" $ \i ->-      let bx = iBox i-          tgt = unHeight . iHeight $ i-      in (\h -> h == height bx || h == tgt) . height $-            grow (iBackground i) (iHeight i) (iWidth i)-                 (iVert i) (iHoriz i) (iBox i)--    , testProperty "new Box is at least as tall as old Box" $ \i ->-      let bx = iBox i-      in (>= height bx) . height $ grow (iBackground i)-            (iHeight i) (iWidth i) (iVert i) (iHoriz i) (iBox i)-    ]--  , testGroup "column"-    [ testProperty "number of inputs == number of outputs" $ \i ->-      let bs = iBoxes i-      in (== length bs) . length $ column (iBackground i) (iHoriz i) bs--    , testProperty "width of outputs is identical" $ \i ->-      case column (iBackground i) (iHoriz i) (iBoxes i) of-        [] -> True-        x:xs -> all (== width x) . map width $ xs--    , testProperty "width of output is as wide as widest input" $ \i ->-      let r = column (iBackground i) (iHoriz i) (iBoxes i)-      in case iBoxes i of-        [] -> null r-        xs -> width (head r) == (maximum . map width $ xs)-    ]--  , testGroup "resizeH"-    [ testProperty "height of resulting Box unchanged" $ \i ->-      let bx = iBox i-      in (== height bx) . height $ resizeH (iBackground i)-            (unWidth . iWidth $ i) (iHoriz i) bx--    , testProperty "result has desired width" $ \i ->-      let tgt = max 0 . unWidth . iWidth $ i-      in (== tgt) . width $ resizeH (iBackground i)-            (unWidth . iWidth $ i) (iHoriz i) (iBox i)-    ]--  , testGroup "resizeV"-    [ testProperty "width of resulting Box unchanged" $ \i ->-      let bx = iBox i-      in (== width bx) . width $ resizeV (iBackground i)-            (unHeight . iHeight $ i) (iVert i) bx--    , testProperty "result has desired height" $ \i ->-      let tgt = max 0 . unHeight . iHeight $ i-      in (== tgt) . height $ resizeV (iBackground i)-            (unHeight . iHeight $ i) (iVert i) (iBox i)-    ]--  , testGroup "resize"-    [ testProperty "result has desired height" $ \i ->-      let tgt = max 0 . unHeight . iHeight $ i-      in (== tgt) . height $ resize (iBackground i)-            (iHeight i) (iWidth i)-            (iVert i) (iHoriz i) (iBox i)--    , testProperty "result has desired width" $ \i ->-      let tgt = max 0 . unWidth . iWidth $ i-      in (== tgt) . width $ resize (iBackground i)-            (iHeight i) (iWidth i) (iVert i) (iHoriz i)-            (iBox i)-    ]--  , testGroup "punctuateH"-    [ testProperty "result has desired width" $ \i ->-      let tgt = (sum . map width $ bs)-            + width bx * (max 0 $ len - 1)-          len = length bs-          bs = iBoxes i-          bx = iBox i-      in (== tgt) . width $ punctuateH (iBackground i)-          (iVert i) bx bs-    ]--  , testGroup "punctuateV"-    [ testProperty "result has desired height" $ \i ->-      let tgt = (sum . map height $ bs)-            + height bx * (max 0 $ len - 1)-          len = length bs-          bs = iBoxes i-          bx = iBox i-      in (== tgt) . height $ punctuateV (iBackground i)-          (iHoriz i) bx bs-    ]--  -- Have to cap size on this one, which is not satisfying.  There-  -- are no apparent bugs.  Apparently what is taking so long is the-  -- Text.replicate in Box.blanks, which is applied from-  -- Box.padHoriz.-  , testGroup "sepH"-    [ testProperty "result has correct width" $-      forAll arbitrarySizedIntegral $ \len ->-      forAll arbitrary $ \i ->-      let tgt = (sum . map width $ bs)-            + max 0 len * max 0 (length bs - 1)-          bs = iBoxes i-      in (== tgt) . width $ sepH (iBackground i) len-          (iVert i) (iBoxes i)-    ]--  , testGroup "sepV"-    [ testProperty "result has correct height" $-      forAll arbitrarySizedIntegral $ \len ->-      forAll arbitrary $ \i ->-      let tgt = (sum . map height $ bs)-            + max 0 len * max 0 (length bs - 1)-          bs = iBoxes i-      in (== tgt) . height $ sepV (iBackground i) len-          (iHoriz i) (iBoxes i)-    ]-  ]
+ test/Rainbox/Instances.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Rainbox.Instances where++import Control.Monad+import Test.QuickCheck+import Rainbox.Core+import Rainbox.BicolorTable+import Rainbow.Instances ()+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq++instance Arbitrary a => Arbitrary (Alignment a) where+  arbitrary = oneof [ return Center, fmap NonCenter arbitrary ]++instance Arbitrary Horizontal where+  arbitrary = elements [ Top, Bottom ]++instance Arbitrary Vertical where+  arbitrary = elements [ Port, Starboard ]++instance Arbitrary Height where+  arbitrary = fmap Height $ frequency+    [ (3, fmap getNonNegative arbitrary)+    , (1, arbitrary)+    ]++instance Arbitrary Width where+  arbitrary = fmap Width $ frequency+    [ (3, fmap getNonNegative arbitrary)+    , (1, arbitrary)+    ]++instance Arbitrary Core where+  arbitrary = fmap Core arbitrary++instance Arbitrary Rod where+  arbitrary = fmap Rod arbitrary++newtype NonEmptySeq a = NonEmptySeq { getNonEmptySeq :: Seq a }+  deriving Show++instance Arbitrary a => Arbitrary (NonEmptySeq a) where+  arbitrary = do+    NonEmpty xs <- arbitrary+    return . NonEmptySeq . Seq.fromList $ xs++instance Arbitrary RodRows where+  arbitrary = sized $ \s -> resize (s `div` 10) $ oneof+    [ fmap (RodRowsWithHeight . getNonEmptySeq) arbitrary+    , frequency [ (1, fmap RodRowsNoHeight arbitrary)+                , (3, fmap (RodRowsNoHeight . getNonNegative) arbitrary)+                ]+    ]++instance Arbitrary a => Arbitrary (Payload a) where+  arbitrary = liftM3 Payload arbitrary arbitrary arbitrary++instance Arbitrary a => Arbitrary (Box a) where+  arbitrary = fmap Box arbitrary++instance Arbitrary Cell where+  arbitrary = liftM4 Cell arbitrary arbitrary arbitrary arbitrary++instance Arbitrary BicolorTable where+  arbitrary = BicolorTable <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
− test/Rainbox/ReaderTests.hs 
@@ -1,133 +0,0 @@-module Rainbox.ReaderTests where--import qualified Rainbox.Box as R-import Rainbox.Reader-import Rainbox.Box.PrimitivesTests-import Test.QuickCheck hiding (resize)-import Test.Tasty.QuickCheck (testProperty)-import Test.Tasty-import Data.Functor.Identity--tests :: TestTree-tests = testGroup "ReaderTests"-  [ testProperty "blankH" $ \(SpecPair i s) ->-    let p = R.blankH (iBackground i) (unWidth . iWidth $ i)-    in testEq s (blankH (unWidth . iWidth $ i)) p--  , testProperty "blankV" $ \(SpecPair i s) ->-    let p = R.blankV (iBackground i) (unHeight . iHeight $ i)-    in testEq s (blankV (unHeight . iHeight $ i)) p--  , testProperty "catH" $ \(SpecPair i s) ->-    let p = R.catH (iBackground i) (iVert i) (iBoxes i)-    in testEq s (catH (iBoxes i)) p--  , testProperty "catV" $ \(SpecPair i s) ->-    let p = R.catV (iBackground i) (iHoriz i) (iBoxes i)-    in testEq s (catV (iBoxes i)) p--  , testProperty "grow" $ \(SpecPair i s) ->-    let p = R.grow (iBackground i) (iHeight i) (iWidth i)-          (iVert i) (iHoriz i) (iBox i)-    in testEq s (grow (iHeight i) (iWidth i) (iBox i)) p--  , testProperty "growH" $ \(SpecPair i s) ->-    let p = R.growH (iBackground i) (unWidth . iWidth $ i)-          (iHoriz i) (iBox i)-    in testEq s (growH (unWidth . iWidth $ i)-        (iBox i)) p--  , testProperty "growV" $ \(SpecPair i s) ->-    let p = R.growV (iBackground i) (unHeight . iHeight $ i)-          (iVert i) (iBox i)-    in testEq s (growV (unHeight . iHeight $ i)-        (iBox i)) p--  , testProperty "column" $ \(SpecPair i s) ->-    let p = R.column (iBackground i) (iHoriz i) (iBoxes i)-    in testEq s (column (iBoxes i)) p--  , testProperty "resize" $ \(SpecPair i s) ->-    let p = R.resize (iBackground i) (iHeight i) (iWidth i)-          (iVert i) (iHoriz i) (iBox i)-    in testEq s (resize (iHeight i) (iWidth i) (iBox i)) p--  , testProperty "resizeH" $ \(SpecPair i s) ->-    let p = R.resizeH (iBackground i) (unWidth . iWidth $ i)-          (iHoriz i) (iBox i)-    in testEq s (resizeH (unWidth . iWidth $ i) (iBox i)) p--  , testProperty "resizeV" $ \(SpecPair i s) ->-    let p = R.resizeV (iBackground i) (unHeight . iHeight $ i)-          (iVert i) (iBox i)-    in testEq s (resizeV (unHeight . iHeight $ i) (iBox i)) p--  , testProperty "sepH" $ \(SpecPair i s) ->-    let p = R.sepH (iBackground i) (spaceH s) (iVert i) (iBoxes i)-    in testEq s (sepH (spaceH s) (iBoxes i)) p--  , testProperty "sepV" $ \(SpecPair i s) ->-    let p = R.sepV (iBackground i) (spaceV s) (iHoriz i) (iBoxes i)-    in testEq s (sepV (spaceV s) (iBoxes i)) p--  , testProperty "punctuateH" $ \(SpecPair i s) ->-    let p = R.punctuateH (iBackground i) (iVert i) (iBox i) (iBoxes i)-    in testEq s (punctuateH (iBox i) (iBoxes i)) p--  , testProperty "punctuateV" $ \(SpecPair i s) ->-    let p = R.punctuateV (iBackground i) (iHoriz i) (iBox i) (iBoxes i)-    in testEq s (punctuateV (iBox i) (iBoxes i)) p--  , testProperty "viewH" $ \(SpecPair i s) ->-    let p = R.viewH (unWidth . iWidth $ i) (iHoriz i) (iBox i)-    in testEq s (viewH (unWidth . iWidth $ i) (iBox i)) p--  , testProperty "viewV" $ \(SpecPair i s) ->-    let p = R.viewV (unHeight . iHeight $ i) (iVert i) (iBox i)-    in testEq s (viewV (unHeight . iHeight $ i) (iBox i)) p--  , testProperty "view" $ \(SpecPair i s) ->-    let p = R.view (iHeight i) (iWidth i) (iVert i) (iHoriz i)-          (iBox i)-    in testEq s (view (iHeight i) (iWidth i) (iBox i)) p-  ]--testEq :: Eq a => Specs -> Env Identity a -> a -> Bool-testEq s e a = r == a-  where-    r = runEnv s e--specs-  :: Int-  -- ^ Space for horizontal joins-  -> Int-  -- ^ Space for vertical joins-  -> Inputs-  -> Specs-specs h v i = Specs-  { background = iBackground i-  , alignH = iHoriz i-  , alignV = iVert i-  , spaceH = h-  , spaceV = v-  }--genSpecs :: Gen (Inputs, Specs)-genSpecs = do-  h <- frequency [(3, fmap getPositive arbitrarySizedIntegral),-                  (1, arbitrarySizedIntegral)]-  v <- frequency [(3, fmap getPositive arbitrarySizedIntegral),-                  (1, arbitrarySizedIntegral)]-  i <- arbitrary-  let ss = specs h v i-  return (i, ss)--data SpecPair = SpecPair-  { spInputs :: Inputs-  , spSpecs :: Specs-  } deriving Show--instance Arbitrary SpecPair where-  arbitrary = do-    (i, s) <- genSpecs-    return $ SpecPair i s
− test/RainboxDir.hs 
@@ -1,13 +0,0 @@-module RainboxDir where--import qualified Rainbox.BoxTests-import qualified Rainbox.BoxDir-import qualified Rainbox.ReaderTests-import qualified Rainbox.Array2dTests-import Test.Tasty--tests :: TestTree-tests = testGroup "RainboxDir" [ Rainbox.BoxTests.tests-                               , Rainbox.BoxDir.tests-                               , Rainbox.ReaderTests.tests-                               , Rainbox.Array2dTests.tests ]
− test/RainboxTests.hs 
@@ -1,7 +0,0 @@-module RainboxTests where--import Test.Tasty--- import Rainbox--tests :: TestTree-tests = testGroup "Rainbox" []
− test/Test/Rainbow/Generators.hs 
@@ -1,82 +0,0 @@-module Test.Rainbow.Generators where--import qualified Data.Text as X-import Prelude hiding (last)-import Control.Monad-import Data.Monoid-import Test.QuickCheck-import System.Console.Rainbow.Colors-import System.Console.Rainbow hiding-  (textSpec)-import System.Console.Rainbow.Types hiding-  (style8, style256, textSpec)---- | Generates one of the valid colors for an 8-color terminal,--- including the default color.-colors8 :: Gen Color8-colors8 = elements $ c8_default : map snd c8_all---- | Generates one of the valid colors for an 256-color terminal,--- including the default color.-colors256 :: Gen Color256-colors256 = elements $ c256_default : map snd c256_all---- | Generates a foreground color chunk for 8-color terminals.-fgColorChunk8 :: Gen Chunk-fgColorChunk8 = fmap fc8 colors8---- | Generates a foreground color chunk for 256-color terminals.-fgColorChunk256 :: Gen Chunk-fgColorChunk256 = fmap fc256 colors256---- | Generates a background color chunk for 8-color terminals.-bgColorChunk8 :: Gen Chunk-bgColorChunk8 = fmap bc8 colors8---- | Generates a background color chunk for 256-color terminals.-bgColorChunk256 :: Gen Chunk-bgColorChunk256 = fmap bc256 colors256---- | Generates a color chunk (half foreground, half background) for--- 8-color terminals.-colorChunk8 :: Gen Chunk-colorChunk8 = oneof [ fgColorChunk8, bgColorChunk8 ]---- | Generates a color chunk (half foreground, half background) for--- 256-color terminals.-colorChunk256 :: Gen Chunk-colorChunk256 = oneof [ fgColorChunk256, bgColorChunk256 ]---- | Generates a color chunk (half for 8-color, half for 256-color).-colorChunk :: Gen Chunk-colorChunk = oneof [ colorChunk8, colorChunk256 ]--last :: a -> Gen (Last a)-last a = frequency [ (3, return $ Last (Just a)),-                     (1, return $ Last Nothing)]--styleCommon :: Gen StyleCommon-styleCommon = liftM4 StyleCommon g g g g-  where-    g = arbitrary >>= last--style8 :: Gen Style8-style8 = liftM3 Style8-  (colors8 >>= last) (colors8 >>= last) styleCommon--style256 :: Gen Style256-style256 = liftM3 Style256-  (colors256 >>= last) (colors256 >>= last) styleCommon--textSpec :: Gen TextSpec-textSpec = liftM2 TextSpec style8 style256--chunk :: [X.Text] -> Gen Chunk-chunk x = liftM2 Chunk textSpec (return x)---- | Generates one Chunk for each list of Text in the list and--- combines them into one Chunk.-combinedChunks :: [[X.Text]] -> Gen Chunk-combinedChunks ls = do-  cs <- mapM chunk ls-  return $ foldl (<>) mempty cs
− test/Visual.hs 
@@ -1,154 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}-module Visual where--import Control.Monad-import Rainbox.Box-import System.Console.Rainbow-import System.Console.Rainbow.Colors-import Data.Monoid-import Test.QuickCheck.Gen hiding (resize)-import Test.QuickCheck.Random-import Rainbox.Box.PrimitivesTests-import Data.Maybe (fromJust)-import Data.String--colors = f_yellow <> b_blue--narrow = "narrow box" <> colors--midwidth = "medium width box" <> colors--wide = "a wide box, see how wide I am?" <> colors--greenBack = same c8_green--yellowBack = same c8_yellow--all3 = [narrow, midwidth, wide]--short = chunk narrow--midheight = catV greenBack left . map chunk $ [narrow, midwidth]--tall = catV greenBack left . map chunk $ [narrow, midwidth, wide]--sizeParam = 7--putBox b = do-  term <- termFromEnv-  putChunks term . render $ b--describe s b = do-  putStrLn (s ++ ":")-  putBox b-  putStrLn ""--testCompound :: String -> (Background -> [Box] -> Box) -> IO ()-testCompound d f = do-  g <- newQCGen-  let bxs = unGen (replicateM 5 genTextBox) g sizeParam -      bk = unGen genBackground g sizeParam-  describe d $ f bk bxs--testVert-  :: String-  -> (Background -> Align Vert -> [Box] -> Box)-  -> IO ()-testVert d f = do-  testCompound (d ++ ", top align") (\bk bxs -> f bk top bxs)-  testCompound (d ++ ", center align") (\bk bxs -> f bk center bxs)-  testCompound (d ++ ", bottom align") (\bk bxs -> f bk bottom bxs)--testHoriz-  :: String-  -> (Background -> Align Horiz -> [Box] -> Box)-  -> IO ()-testHoriz d f = do-  testCompound (d ++ ", left align") (\bk bxs -> f bk left bxs)-  testCompound (d ++ ", center align") (\bk bxs -> f bk center bxs)-  testCompound (d ++ ", right align") (\bk bxs -> f bk right bxs)---- | Makes a 10x10 test box.-testBox :: Box-testBox = catV defaultBackground left . map mkLine $ clrs-  where-    mkLine clr = chunk $ txt <> clr-    txt = fromString ['0'..'9']-    lkp k = bc256 . fromJust . lookup k $ c256_all-    clrs = map lkp . take 10 . iterate (+6) $ 160--singleH-  :: String-  -> (Align Horiz -> Box)-  -> IO ()-singleH desc f = do-  describe (desc ++ ", left") (f left)-  describe (desc ++ ", center") (f center)-  describe (desc ++ ", right") (f right)--singleV-  :: String-  -> (Align Vert -> Box)-  -> IO ()-singleV desc f = do-  describe (desc ++ ", top") (f top)-  describe (desc ++ ", center") (f center)-  describe (desc ++ ", bottom") (f bottom)--single-  :: String-  -> (Align Vert -> Align Horiz -> Box)-  -> IO ()-single desc f = do-  singleV (desc ++ ", left") (\av -> f av left)-  singleV (desc ++ ", center") (\av -> f av center)-  singleV (desc ++ ", right") (\av -> f av right)--  singleH (desc ++ ", top") (f top)-  singleH (desc ++ ", center") (f center)-  singleH (desc ++ ", bottom") (f bottom)---tests :: IO ()-tests = do-  describe "narrow box" . chunk $ narrow-  describe "medium box" . chunk $ midwidth-  describe "wide box" . chunk $ wide--  testHoriz "catV" catV-  testVert "catH" catH--  testVert "sepH" (\bk av bxs -> sepH bk 1 av bxs)-  testHoriz "sepV" (\bk ah bxs -> sepV bk 1 ah bxs)--  testVert "punctuateH" (\bk av bxs -> punctuateH bk av " " bxs)-  testHoriz "punctuateV" (\bk ah bxs -> punctuateV bk ah " " bxs)--  let green = backgroundFromChunk b_green--  testHoriz "column" (\bk ah bxs -> catV defaultBackground left-                        (column bk ah bxs))--  describe "original box for following tests, 10x10" testBox--  single "view, 3x3"-    (\av ah -> view (Height 3) (Width 3) av ah testBox)-  singleH "viewH, 3" (\ah -> viewH 3 ah testBox)-  singleV "viewV, 3" (\av -> viewV 3 av testBox)--  single "grow, 13x13"-    (\av ah -> grow green (Height 13) (Width 13) av ah testBox)-  singleH "growH, 13" (\ah -> growH green 13 ah testBox)-  singleV "growV, 13" (\av -> growV green 13 av testBox)--  single "resize, 13x13"-    (\av ah -> resize green (Height 13) (Width 13) av ah testBox)-  singleH "resizeH, 13" (\ah -> resizeH green 13 ah testBox)-  singleV "resizeV, 13" (\av -> resizeV green 13 av testBox)--  single "resize, 7x7"-    (\av ah -> resize green (Height 7) (Width 7) av ah testBox)-  singleH "resizeH, 7" (\ah -> resizeH green 7 ah testBox)-  singleV "resizeV, 7" (\av -> resizeV green 7 av testBox)-
− test/rainbox-mosaic.hs 
@@ -1,20 +0,0 @@--- | Usage:------ Input the size parameter as $1.  Will generate a random box and print--- it out. Always uses colors.-module Main where--import Test.QuickCheck.Gen-import Rainbox.Box.PrimitivesTests-import System.Environment-import System.Random-import Rainbox.Box-import System.Console.Rainbow--main :: IO ()-main = do-  g <- newStdGen-  s:[] <- getArgs-  let bx = unGen genBox g (read s)-  e <- termFromEnv-  putChunks e . render $ bx
+ test/rainbox-properties.hs view
@@ -0,0 +1,157 @@+module Main where++import Rainbox.Core+import Rainbox.BicolorTable+import Rainbox.Instances ()+import Rainbow.Types+import Test.Tasty+import Test.Tasty.QuickCheck+import Data.Sequence (Seq, viewl, ViewL(..))+import qualified Data.Sequence as Seq+import qualified Data.Foldable as F+import qualified Data.Text as X+import Control.Monad++main :: IO ()+main = defaultMain . testGroup "Rainbox tests" $+  [ testGroup "split" $+    [ testProperty "sum is equal to original number" $ \a ->+      let (x, y) = split a+      in x + y == a+    ]++  , testGroup "HasHeight" $+    [ testGroup "never returns less than zero" $+      let go a = let h = height a in classify (h > 2) "h > 2" (h >= 0) in+      [ testProperty "RodRows" $+          \a -> go (a `asTypeOf` (undefined :: RodRows))+      , testProperty "Core" $+          \a -> go (a `asTypeOf` (undefined :: Core))+      , testProperty "Box Vertical" $+          \a -> go (a `asTypeOf` (undefined :: Box Vertical))+      , testProperty "Box Horizontal" $+          \a -> go (a `asTypeOf` (undefined :: Box Horizontal))+      , testProperty "Payload Vertical" $+          \a -> go (a `asTypeOf` (undefined :: Payload Vertical))+      , testProperty "Payload Horizontal" $+          \a -> go (a `asTypeOf` (undefined :: Payload Horizontal))+      ]+    ]++  , testGroup "HasWidth" $+    [ testGroup "never returns less than zero" $+      let go a = let w = width a in classify (w > 2) "w > 2" (w >= 0) in+      [ testProperty "Chunk" $+          \a -> go (a `asTypeOf` (undefined :: Chunk))+      , testProperty "RodRows" $+          \a -> go (a `asTypeOf` (undefined :: RodRows))+      , testProperty "Rod" $+          \a -> go (a `asTypeOf` (undefined :: Rod))+      , testProperty "Core" $+          \a -> go (a `asTypeOf` (undefined :: Core))+      , testProperty "Box Vertical" $+          \a -> go (a `asTypeOf` (undefined :: Box Vertical))+      , testProperty "Box Horizontal" $+          \a -> go (a `asTypeOf` (undefined :: Box Horizontal))+      , testProperty "Payload Vertical" $+          \a -> go (a `asTypeOf` (undefined :: Payload Vertical))+      , testProperty "Payload Horizontal" $+          \a -> go (a `asTypeOf` (undefined :: Payload Horizontal))+      ]+    ]++  , testGroup "chunk" $+    [ testProperty "height is always 1" $ \c ->+      let _types = c :: Chunk in height c == 1+    , testProperty "width is sum of number of characters" $ \c@(Chunk _ t) ->+      let _types = c :: Chunk in width c == X.length t+    ]++  , testGroup "addVerticalPadding"+    [ testProperty "all RodRows same height" $+      allRodRowsSameHeight . addVerticalPadding+    ]++  , testGroup "UpDown"+    [ testGroup "above + below is same as height" $+      let sameAsHeight a = above a + below a == height a in+      [ testProperty "Box Horizontal"+          (\a -> sameAsHeight (a `asTypeOf` (undefined :: Box Horizontal)))+      , testProperty "Payload Horizontal"+          (\a -> sameAsHeight (a `asTypeOf` (undefined :: Payload Horizontal)))+      ]+    ]++  , testGroup "horizontalMerge"+    [ testProperty "Resulting RodRows has same height as inputs" $+      \rr i ->+      let lenR = case rr of+            RodRowsNoHeight _ -> 0+            RodRowsWithHeight sq -> Seq.length sq+      in height (horizontalMerge (Seq.replicate (getPositive i) rr)) == lenR+    ]++  , testGroup "addHorizontalPadding"+    [ testProperty "all RodRows same width" $+      allRodRowsSameWidth . addHorizontalPadding+    ]++  , testGroup "verticalMerge"+    [ testProperty "resulting RodRows same width as inputs" $ \rr i ->+      let lenR = width rr+          mrge = verticalMerge (Seq.replicate (getPositive i) rr)+          wdth = width mrge+      in counterexample (show (mrge, wdth, lenR)) $ wdth == lenR+    ]++    , testGroup "BicolorTable"+      [ testGroup "padBicolorTable"+        [ testProperty "all rows are the same length" $ \bct ->+          let padded = padBicolorTable bct+          in case Seq.viewl . _bctRows $ padded of+              EmptyL -> True+              a :< as -> all (\sq -> Seq.length sq == Seq.length a) as++        , testProperty "length of _bctAlignment is at least as long as a row" $ \bct ->+          let padded = padBicolorTable bct+          in case Seq.viewl . _bctRows $ padded of+              EmptyL -> True+              a :< _ -> Seq.length (_bctAlignments padded) >= Seq.length a+        ]+      ]+++  ]++allRodRowsSameHeight :: Seq RodRows -> Bool+allRodRowsSameHeight sqnce = case viewl sqnce of+  EmptyL -> True+  x :< xs -> F.all (== height x) . fmap height $ xs++allRodRowsSameWidth :: Seq RodRows -> Property+allRodRowsSameWidth sqnce = +  case viewl sqnce of+    EmptyL -> property True+    x :< _ -> counterexample (show (sqnce, lengths, height1))+      $ F.all (== height1) lengths+      where+        lengths = join . fmap toLengths $ sqnce+        height1 = case x of+          RodRowsNoHeight w -> w+          RodRowsWithHeight sqn -> case viewl sqn of+            EmptyL -> 0+            y :< _ -> F.sum . fmap width $ y+        toLengths (RodRowsNoHeight w) = Seq.singleton w+        toLengths (RodRowsWithHeight sq) = fmap (F.sum . fmap width) sq++rodsLength :: Seq Rod -> Int+rodsLength = F.sum . fmap width++rodRowsLengths :: Seq (Seq Rod) -> Seq Int+rodRowsLengths = fmap rodsLength++seqRodsRowsLengths :: Seq RodRows -> Seq (Seq Int)+seqRodsRowsLengths sq = fmap calc sq+  where+    calc (RodRowsNoHeight w) = Seq.singleton (max 0 w)+    calc (RodRowsWithHeight sqn) = rodRowsLengths sqn
− test/rainbox-test.hs 
@@ -1,11 +0,0 @@-module Main where--import qualified RainboxDir-import qualified RainboxTests-import Test.Tasty--main :: IO ()-main = defaultMain $ testGroup "rainbox"-  [ RainboxDir.tests-  , RainboxTests.tests-  ]
test/rainbox-visual.hs view
@@ -1,10 +1,92 @@--- | Rainbox visual tests.------ Tests that are intended to be run and then examined visually.+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedLists #-}+-- | Prints all the boxes in the tutorial.  The output must be+-- visually inspected.  module Main where -import Visual+import Data.Function ((&))+import Rainbow+import Rainbox+import Rainbox.Tutorial +bicolorStationBox :: BicolorTable+bicolorStationBox = BicolorTable+  { _bctEvenBackground = cyan <> color256 254+  , _bctOddBackground = mempty+  , _bctSpacerWidth = 2+  , _bctAlignments = [left, center, right]+  , _bctRows =+  [ [ [ [ "Red" & fore red ]+      , [ "Orange" & fore (yellow <> color256 220) ]+      , [ "Silver" & fore (white <> grey) ]+      , [ "Blue" & fore blue ]+      ]+    , [ [ "Metro Center" ] ]+    , [ [ "607 13th St NW" ]+      , [ "Washington, ", "DC" & fore red & back white, " 20005" ]+      ]+    ]++  , [ [ [ "Orange" & fore (yellow <> color256 220) ]+      , [ "Silver" & fore (white <> grey) ]+      , [ "Blue" & fore blue ]+      , [ "Green" & fore green ]+      , [ "Yellow" & fore yellow ]+      ]+    , [ [ "L'Enfant Plaza" ] ]+    , [ [ "600 Maryland Ave SW" ]+      , [ "Washington, " , "DC" & fore red & back white, " 20024" ]+      ]+    ]++  , [ [ [ "Red" & fore red ]+      ]+    , [ [ "Silver Spring" ] ]+    , [ [ "8400 Colesville Rd" ]+      , [ "Silver Spring, ", "MD" & fore yellow & back black, " 20910" ]+      ]+    ]++  , [ [ [ "Orange" & fore (yellow <> color256 220) ]+      , [ "Silver" & fore (white <> grey) ]+      ]+    , [ [ "Court House" ] ]+    , [ [ "2100 Wilson Blvd" ]+      , [ "Arlington, " , "VA" & fore cyan & back grey, " 22201" ]+      ]+    ]++  , [ [ [ "Green" & fore green ]+      , [ "Yellow" & fore yellow ]+      ]+    , [ [ "Prince George's Plaza" ]+      ]+    , [ [ "3575 East-West Hwy" ]+      , [ "Hyattsville, ", "MD" & fore yellow & back black, " 20782" ]+      ]+    ]+  ]+  }++++printBox :: String -> IO () -> IO ()+printBox lbl act = do+  putStrLn $ replicate 50 '='+  putStrLn ""+  putStrLn $ lbl ++ ":"+  putStrLn ""+  act+  putStrLn ""+ main :: IO ()-main = Visual.tests+main = do+  printBox "box1" renderBox1+  printBox "box2" renderBox2+  printBox "box3" renderBox3+  printBox "box4" renderBox4+  printBox "box5" renderBox5+  printBox "verticalStationTable" renderVerticalStationTable+  printBox "horizontalStationTable" renderHorizontalStationTable+  printBox "bicolor station table" (putBicolorTable bicolorStationBox)