diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014, Omari Norman +Copyright (c) 2014 - 2020 Omari Norman All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 ======= diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -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 diff --git a/current-versions.txt b/current-versions.txt deleted file mode 100644 --- a/current-versions.txt +++ /dev/null @@ -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 - diff --git a/lib/Rainbox.hs b/lib/Rainbox.hs --- a/lib/Rainbox.hs +++ b/lib/Rainbox.hs @@ -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 -- --- +-- -- 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 diff --git a/lib/Rainbox/Array2d.hs b/lib/Rainbox/Array2d.hs deleted file mode 100644 --- a/lib/Rainbox/Array2d.hs +++ /dev/null @@ -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 - diff --git a/lib/Rainbox/BicolorTable.hs b/lib/Rainbox/BicolorTable.hs new file mode 100644 --- /dev/null +++ b/lib/Rainbox/BicolorTable.hs @@ -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 diff --git a/lib/Rainbox/Box.hs b/lib/Rainbox/Box.hs deleted file mode 100644 --- a/lib/Rainbox/Box.hs +++ /dev/null @@ -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 - diff --git a/lib/Rainbox/Box/Primitives.hs b/lib/Rainbox/Box/Primitives.hs deleted file mode 100644 --- a/lib/Rainbox/Box/Primitives.hs +++ /dev/null @@ -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 - diff --git a/lib/Rainbox/Core.hs b/lib/Rainbox/Core.hs new file mode 100644 --- /dev/null +++ b/lib/Rainbox/Core.hs @@ -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 + diff --git a/lib/Rainbox/Reader.hs b/lib/Rainbox/Reader.hs deleted file mode 100644 --- a/lib/Rainbox/Reader.hs +++ /dev/null @@ -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 /+/ diff --git a/lib/Rainbox/Tutorial.hs b/lib/Rainbox/Tutorial.hs new file mode 100644 --- /dev/null +++ b/lib/Rainbox/Tutorial.hs @@ -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 diff --git a/lib/Rainbox/Tutorial.lhs b/lib/Rainbox/Tutorial.lhs deleted file mode 100644 --- a/lib/Rainbox/Tutorial.lhs +++ /dev/null @@ -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 -> -- -> -- - -> 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 diff --git a/minimum-versions.txt b/minimum-versions.txt deleted file mode 100644 --- a/minimum-versions.txt +++ /dev/null @@ -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 - diff --git a/package.yaml b/package.yaml new file mode 100644 --- /dev/null +++ b/package.yaml @@ -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 + diff --git a/rainbox.cabal b/rainbox.cabal --- a/rainbox.cabal +++ b/rainbox.cabal @@ -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 - . - 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 diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,3 @@ +resolver: lts-14.14 +extra-deps: + - rainbow-0.34.0.0 diff --git a/sunlight-test.hs b/sunlight-test.hs deleted file mode 100644 --- a/sunlight-test.hs +++ /dev/null @@ -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 diff --git a/test/Rainbow/Instances.hs b/test/Rainbow/Instances.hs new file mode 100644 --- /dev/null +++ b/test/Rainbow/Instances.hs @@ -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 diff --git a/test/Rainbox/Array2dTests.hs b/test/Rainbox/Array2dTests.hs deleted file mode 100644 --- a/test/Rainbox/Array2dTests.hs +++ /dev/null @@ -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 - - ] - diff --git a/test/Rainbox/Box/PrimitivesTests.hs b/test/Rainbox/Box/PrimitivesTests.hs deleted file mode 100644 --- a/test/Rainbox/Box/PrimitivesTests.hs +++ /dev/null @@ -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) - ] - ] - diff --git a/test/Rainbox/BoxDir.hs b/test/Rainbox/BoxDir.hs deleted file mode 100644 --- a/test/Rainbox/BoxDir.hs +++ /dev/null @@ -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 ] diff --git a/test/Rainbox/BoxTests.hs b/test/Rainbox/BoxTests.hs deleted file mode 100644 --- a/test/Rainbox/BoxTests.hs +++ /dev/null @@ -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) - ] - ] diff --git a/test/Rainbox/Instances.hs b/test/Rainbox/Instances.hs new file mode 100644 --- /dev/null +++ b/test/Rainbox/Instances.hs @@ -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 diff --git a/test/Rainbox/ReaderTests.hs b/test/Rainbox/ReaderTests.hs deleted file mode 100644 --- a/test/Rainbox/ReaderTests.hs +++ /dev/null @@ -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 diff --git a/test/RainboxDir.hs b/test/RainboxDir.hs deleted file mode 100644 --- a/test/RainboxDir.hs +++ /dev/null @@ -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 ] diff --git a/test/RainboxTests.hs b/test/RainboxTests.hs deleted file mode 100644 --- a/test/RainboxTests.hs +++ /dev/null @@ -1,7 +0,0 @@ -module RainboxTests where - -import Test.Tasty --- import Rainbox - -tests :: TestTree -tests = testGroup "Rainbox" [] diff --git a/test/Test/Rainbow/Generators.hs b/test/Test/Rainbow/Generators.hs deleted file mode 100644 --- a/test/Test/Rainbow/Generators.hs +++ /dev/null @@ -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 diff --git a/test/Visual.hs b/test/Visual.hs deleted file mode 100644 --- a/test/Visual.hs +++ /dev/null @@ -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) - diff --git a/test/rainbox-mosaic.hs b/test/rainbox-mosaic.hs deleted file mode 100644 --- a/test/rainbox-mosaic.hs +++ /dev/null @@ -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 diff --git a/test/rainbox-properties.hs b/test/rainbox-properties.hs new file mode 100644 --- /dev/null +++ b/test/rainbox-properties.hs @@ -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 diff --git a/test/rainbox-test.hs b/test/rainbox-test.hs deleted file mode 100644 --- a/test/rainbox-test.hs +++ /dev/null @@ -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 - ] diff --git a/test/rainbox-visual.hs b/test/rainbox-visual.hs --- a/test/rainbox-visual.hs +++ b/test/rainbox-visual.hs @@ -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)