diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,23 +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.lhs). 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. +[Rainbow](http://hackage.haskell.org/package/rainbow) which is only +tested on UNIX-like systems. Tests ===== @@ -29,7 +29,7 @@ cabal configure --enable-tests cabal build - dist/build/rainbox-test/rainbox-test + dist/build/rainbox-properties/rainbox-properties dist/build/rainbox-visual/rainbox-visual The last test, `rainbox-visual`, relies on you to examine the output @@ -42,8 +42,8 @@ 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. +At this time, Rainbox is verified to work with GHC versions in the 7.8 series +and the 7.10 series. License ======= diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +0.12.0.0 + + * rewrote API to use monoids + 0.6.0.0 * update to work with newer version of Rainbow diff --git a/lib/Rainbox.hs b/lib/Rainbox.hs --- a/lib/Rainbox.hs +++ b/lib/Rainbox.hs @@ -1,147 +1,53 @@ --- | 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 - ( - -- * Alignment - Align - , Horiz - , Vert - , top - , bottom + ( -- * Alignment and Boxes + Alignment + , Horizontal + , Vertical + , center , left , right - , center - - -- * Bar - , Bar(..) - - -- * Cell and Box - , Cell(..) + , top + , bottom + , centerH + , centerV , Box - - -- * Creating Box and gluing them together + , Orientation ( spacer, spreader ) - -- | For simple needs you will only need 'gridByRows' or - -- 'gridByCols'; 'boxCells' and 'glueBoxes' are provided for more - -- complex needs. - , gridByRows - , gridByCols - , boxCells - , glueBoxes + -- * Box construction + , fromChunk + , blank + , wrap -- * Rendering , render - , printBox - ) where -import Rainbow.Colors -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 :: Radiant - -- ^ 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 background of 'noColorRadianat'. 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 noColorRadiant - --- | Returns the width of each 'Bar' in the 'Cell'. -cellWidths :: Cell -> [Int] -cellWidths = map width . bars - --- | 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 - --- | 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 noColorRadiant top - . map (catV noColorRadiant left) - . cols - --- | 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. All rows will be --- the same length as the first row. Any row that is longer than the --- first row will have cells lopped off of the end, and any row that --- is shorter than the first row will be padded with empty cells on --- the end. - -gridByRows :: [[Cell]] -> Box -gridByRows = glueBoxes . boxCells . arrayByRows padCell - --- | 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. --- All columns will be the same height as the first column. Any --- column that is longer than the first column will have cells lopped --- off the bottom, and any column that is shorter than the first --- column will be padded on the bottom with blank cells. + -- * Tables + , Cell(..) + , tableByRows + , tableByColumns + , separator -gridByCols :: [[Cell]] -> Box -gridByCols = glueBoxes . boxCells . arrayByCols padCell + -- * Utilities + , intersperse + ) where -padCell :: Cell -padCell = Cell [] left top noColorRadiant +import Rainbox.Core diff --git a/lib/Rainbox/Array2d.hs b/lib/Rainbox/Array2d.hs deleted file mode 100644 --- a/lib/Rainbox/Array2d.hs +++ /dev/null @@ -1,249 +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. Every --- row's length will be equal to the length of the first row; any rows --- after the first row that are shorter than the first row will have --- extra columns appended to the end. Therefore, the resulting --- 'Array' will have no undefined values. -arrayByRows - :: a - -- ^ Append this empty value to rows that are too short. - -> [[a]] - -- ^ One list per row - -> Array (Int, Int) a -arrayByRows empty ls - = array ((0,0), (colMax, rowMax)) - . indexRows - . padder empty - $ ls - where - rowMax = length ls - 1 - colMax = case ls of - [] -> -1 - x:_ -> length x - 1 - --- | Returns a list where every row is the same length as the first --- row. Subsequent rows are padded on the end or have elements --- removed from the end, as needed. -padder - :: a - -- ^ Empty element - -> [[a]] - -> [[a]] -padder emp input = case input of - [] -> [] - x:xs -> x : map adjust xs - where - len = length x - adjust ls = take len $ ls ++ repeat emp - -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. Every --- column will be the same height as the first column; subsequent --- colums will be padded or truncated on the bottom, as needed. --- Therefore the resulting 'Array' will have no undefined elements. -arrayByCols - :: a - -- ^ Append this value to columns that are too short. - -> [[a]] - -- ^ One list per column; the head of each list is the top of the - -- column. - -> Array (Int, Int) a -arrayByCols empty ls - = listArray ((0,0), (colMax, rowMax)) - . concat - . padder empty - $ ls - where - colMax = length ls - 1 - rowMax = case ls of - [] -> -1 - x:_ -> length x - 1 - diff --git a/lib/Rainbox/Box.hs b/lib/Rainbox/Box.hs deleted file mode 100644 --- a/lib/Rainbox/Box.hs +++ /dev/null @@ -1,351 +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 - ( - -- * 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 Rainbow -import qualified Rainbox.Box.Primitives as B -import Rainbox.Box.Primitives - ( Box - , Align - , Horiz - , Vert - , Height(..) - , Width(..) - , unBox - ) -import qualified Data.ByteString as BS - --- --- # Box making --- - --- | A blank horizontal box with a given width and no height. -blankH - :: Radiant - -- ^ Background colors - -> Int - -- ^ Box width - -> Box -blankH bk i = B.blank bk (Height 0) (Width i) - --- | A blank vertical box with a given length. -blankV - :: Radiant - -- ^ Background colors - -> Int - -- ^ Box height - -> 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 - :: Radiant - -- ^ Background colors - -> 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 - :: Radiant - -- ^ Background colors - -> 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 - :: Radiant - -- ^ Background colors - -> 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 - :: Radiant - -- ^ Background colors - -> 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 - :: Radiant - -- ^ Background colors - -> 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 - :: Radiant - -- ^ Background colors - -> 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 - :: Radiant - -- ^ Background colors - -> 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 - :: Radiant - -- ^ Background colors - -> Int - -- ^ Number of separating spaces - -> 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 - :: Radiant - -- ^ Background colors - -> Int - -- ^ Number of separating spaces - -> 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 - :: Radiant - -- ^ Background colors - -> Align Vert - -> Box - -> [Box] - -> Box -punctuateH bk a sep = B.catH bk a . intersperse sep - --- | A vertical version of 'punctuateH'. -punctuateV - :: Radiant - -- ^ Background colors - -> 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, as --- described in "Rainbow". -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 = - chunkFromText (X.replicate (B.numSpaces ss) (X.singleton ' ')) - <> back (B.spcBackground ss) - --- | Prints a Box to standard output. The highest number of available --- colors are used, using 'byteStringMakerFromEnvironment' from --- "Rainbow". -printBox :: Box -> IO () -printBox b = do - mkr <- byteStringMakerFromEnvironment - mapM_ BS.putStr . chunksToByteStrings mkr . 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,572 +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 - ( - -- * 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 Rainbow -import Rainbow.Types -import Data.Monoid -import qualified Data.Text as X -import Data.String - --- # Box - -data Spaces = Spaces - { numSpaces :: Int - , spcBackground :: Radiant - } 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's 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 - :: Radiant - -- ^ Background colors - -> 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 . chunkTexts) . 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 . chunkTexts - --- # Making Boxes - --- | A blank 'Box'. Useful for aligning other 'Box'. -blank - :: Radiant - -- ^ Background colors - -> 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 - :: Radiant - -- ^ Background colors - -> 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 - :: Radiant - -- ^ Background colors - -> 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 - :: Radiant - -- ^ Background colors - -> 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 - :: Radiant - -- ^ Background colors - -> 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 { chunkTexts = go n (chunkTexts 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 { chunkTexts = go n (chunkTexts 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 - :: Radiant - -- ^ 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,683 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# 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 Rainbow +import Control.Monad (join) +import Data.Monoid +import Rainbow.Types (Chunk(..)) +import Data.Sequence (Seq, ViewL(..), viewl, (|>), (<|)) +import qualified Data.Foldable as F +import qualified Data.Sequence as Seq +import qualified Data.Text as X +import qualified Data.Map as M + +-- # 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) + +-- # Horizontal and vertical + +-- | Determines how a payload aligns with a horizontal axis. +data Horizontal = ATop | ABottom + deriving (Eq, Ord, Show) + +-- | Determines how a payload aligns with a vertical axis. +data Vertical = ALeft | ARight + 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 ALeft + +-- | Place this payload's right edge on the vertical axis. +right :: Alignment Vertical +right = NonCenter ARight + +-- | Place this payload's top edge on the horizontal axis. +top :: Alignment Horizontal +top = NonCenter ATop + +-- | Place this payload's bottom edge on the horizontal axis. +bottom :: Alignment Horizontal +bottom = NonCenter ABottom + + +-- # 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 (Chunk _ ts) = F.sum . fmap X.length $ ts + +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 (|> "\n") . fmap (fmap chunkFromRod) $ sq + where + chunkFromRod (Rod ei) = case ei of + Left (i, r) -> (chunkFromText . 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" + +-- | 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 ALeft -> maxLeft + NonCenter ARight -> maxLeft - lenLin + lenRgt = case a of + Center -> maxRight - (snd . split $ lenLin) + NonCenter ALeft -> maxRight - lenLin + NonCenter ARight -> 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 Monoid (Box a) where + mempty = Box Seq.empty + mappend (Box x) (Box y) = Box (x <> y) + +-- # 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 ALeft) r (Right . Core . Right $ + (Height (max 0 i), Width 0)) + spreader a i = Box . Seq.singleton $ + Payload a noColorRadiant (Right . Core . Right $ + (Height 0, Width (max 0 i))) + +instance Orientation Horizontal where + rodRows = horizontalMerge . addVerticalPadding + + spacer r i = Box . Seq.singleton $ + Payload (NonCenter ATop) r (Right . Core . Right $ + (Height 0, Width (max 0 i))) + spreader a i = Box . Seq.singleton $ + Payload a noColorRadiant (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 ALeft -> 0 + NonCenter ARight -> width ei + Center -> fst . split . width $ ei + + starboard (Payload a _ s3) = case a of + NonCenter ALeft -> width s3 + NonCenter ARight -> 0 + Center -> snd . split . width $ s3 + +instance UpDown (Payload Horizontal) where + above (Payload a _ s3) = case a of + NonCenter ATop -> 0 + NonCenter ABottom -> height s3 + Center -> fst . split . height $ s3 + + below (Payload a _ s3) = case a of + NonCenter ATop -> height s3 + NonCenter ABottom -> 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 + + +-- # Tables + +-- | A single cell in a spreadsheet-like grid. +data Cell = Cell + { cellRows :: Seq (Seq Chunk) + -- ^ The cell can have multiple rows of text; there is one 'Seq' for + -- each row of text. + , cellHoriz :: Alignment Horizontal + -- ^ How this 'Cell' should align compared to other 'Cell' in its + -- row. + , cellVert :: Alignment Vertical + -- ^ How this 'Cell' should align compared to other 'Cell' in its column. + , cellBackground :: 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. + } + +-- | 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 = (chunkFromText $ X.replicate (max 0 i) " ") <> back rd + +emptyCell :: Cell +emptyCell = Cell Seq.empty center center noColorRadiant + + +-- 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 emptyCell + +rowToBoxV :: Box Horizontal -> Box Vertical +rowToBoxV = wrap center noColorRadiant + +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 emptyCell + + +rowToBoxH :: Box Vertical -> Box Horizontal +rowToBoxH = wrap top noColorRadiant + + +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 + + +-- # Utilities + +-- | Like 'Data.List.intersperse' in "Data.List", but works on 'Seq'. +intersperse :: a -> Seq a -> Seq a +intersperse new sq = case viewl sq of + EmptyL -> Seq.empty + x :< xs -> x <| go xs + where + go sqnce = case viewl sqnce of + EmptyL -> Seq.empty + a :< as -> new <| a <| go as + +-- | 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/Reader.hs b/lib/Rainbox/Reader.hs deleted file mode 100644 --- a/lib/Rainbox/Reader.hs +++ /dev/null @@ -1,290 +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 - ( - -- * 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 - ) -import Rainbow - -data Specs = Specs - { background :: Radiant - , 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,521 @@ +-- 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 as 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.Monoid +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Text (Text) +import qualified Data.Text as X +import Rainbow +import 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 :: Radiant -> Text -> Box a +textBox r = fromChunk center r . chunkFromText + +-- | 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 + :: Orientation a + => Alignment a + -> Int + -- ^ Number of rows + -> Int + -- ^ Number of columns + -> Radiant + -- ^ Background color + -> Box a + -> Box a +within a r c b + = wrap a b + . mappend (spreader center r) + . wrap centerH b + . mappend (spreader center c) + . wrap centerV b + +-- | Puts the given text in the center of a box. The resulting box is +-- center aligned. +textWithin + :: Orientation a + => Alignment a + -> Int + -- ^ Number of rows + -> Int + -- ^ Number of columns + -> Radiant + -- ^ Background color for smaller box + -> Radiant + -- ^ Background color for larger box + -> Text + -> Box a +textWithin a r c bs bl = wrap a bl . within a r c bs . textBox bs + +box1 :: Box Vertical +box1 = mconcat + [ textWithin left 4 6 blue green "v1" + , textWithin left 4 15 red magenta "v2" + , textWithin right 6 10 yellow blue "v3" + , textWithin left 3 12 green red "v4" + , textWithin center 4 11 magenta blue "v5" + ] + +renderBox1 :: IO () +renderBox1 = mapM_ putChunk . toList . render $ box1 + +box2 :: Box Horizontal +box2 = mconcat + [ textWithin bottom 4 6 magenta green "h1" + , textWithin top 5 12 blue yellow "h2" + ] + +renderBox2 :: IO () +renderBox2 = mapM_ putChunk . toList . render $ box2 + +box3 :: Box Horizontal +box3 = mconcat + [ wrap top yellow box1 + , box2 + ] + +renderBox3 :: IO () +renderBox3 = mapM_ putChunk . toList . render $ box3 + +box4 :: Box Horizontal +box4 = box2 <> spacer cyan 3 + +renderBox4 :: IO () +renderBox4 = mapM_ putChunk . toList . render $ box4 + +box5 :: Box Horizontal +box5 = box4 <> spreader center 12 + +renderBox5 :: IO () +renderBox5 = mapM_ putChunk . toList . 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 :: Radiant -> Text -> Cell +nameCell bk nm + = Cell (Seq.singleton . Seq.singleton $ (chunkFromText nm <> back bk)) + top left bk + +linesCell :: Radiant -> [Line] -> Cell +linesCell bk lns = Cell (Seq.fromList . fmap (lineRow bk) $ lns) + top right bk + +lineRow :: Radiant -> Line -> Seq Chunk +lineRow bk li = Seq.singleton ck + where + ck = chunkFromText (X.pack . show $ li) <> fore clr <> back bk + clr = case li of + Red -> red + Blue -> blue + Orange -> Radiant yellow8 (Just . Color256 . Just $ 220) + Green -> green + Yellow -> yellow + Silver -> Radiant white8 (Just grey) + + +addressCell :: Radiant -> [Text] -> Cell +addressCell bk lns = Cell (Seq.fromList . fmap addrRow $ lns) top center bk + where + addrRow txt = Seq.singleton $ chunkFromText txt <> back bk + +undergroundCell :: Radiant -> Bool -> Cell +undergroundCell bk bl + = Cell (Seq.singleton . Seq.singleton $ ck) top left bk + where + ck = (if bl then "Yes" else "No") <> back bk + +-- | Converts a 'Station' to a list of 'Cell'. + +stationCells :: Radiant -> Station -> [Cell] +stationCells b st = + [ nameCell b . name $ st + , linesCell b . metroLines $ st + , addressCell b . address $ st + , undergroundCell b . underground $ st + ] + +stationTable :: Box Vertical +stationTable + = tableByRows + . Seq.fromList + . zipWith stationRow (cycle [coloredBack, noColorRadiant]) + $ stations + where + coloredBack = Radiant noColor8 (Just . Color256 . Just $ 195) + stationRow bk + = intersperse (separator bk 1) + . Seq.fromList + . stationCells bk + +renderStationTable :: IO () +renderStationTable = mapM_ putChunk . toList . render $ stationTable + +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 + ] diff --git a/lib/Rainbox/Tutorial.lhs b/lib/Rainbox/Tutorial.lhs deleted file mode 100644 --- a/lib/Rainbox/Tutorial.lhs +++ /dev/null @@ -1,173 +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 you can compile and run -it. 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 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] -> Radiant -> Cell -> cell cks bck = Cell brs left top bck -> where -> brs = map Bar . map ((:[]) . (<> back bck)) $ cks - - -> recordToCells :: Record -> Radiant -> [Cell] -> recordToCells r rad = map ($ rad) $ -> [ 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 [noColorRadiant, 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/rainbox.cabal b/rainbox.cabal --- a/rainbox.cabal +++ b/rainbox.cabal @@ -3,12 +3,12 @@ -- http://www.github.com/massysett/cartel -- -- Script name used to generate: genCabal.hs --- Generated on: 2015-03-22 11:44:44.05559 EDT --- Cartel library version: 0.14.2.0 +-- Generated on: 2015-04-14 07:08:21.967655 EDT +-- Cartel library version: 0.14.2.6 name: rainbox -version: 0.10.0.2 -cabal-version: >= 1.14 +version: 0.12.0.0 +cabal-version: >= 1.18 license: BSD3 license-file: LICENSE build-type: Simple @@ -34,10 +34,7 @@ Library exposed-modules: Rainbox - Rainbox.Array2d - Rainbox.Box - Rainbox.Box.Primitives - Rainbox.Reader + Rainbox.Core Rainbox.Tutorial default-language: Haskell2010 ghc-options: @@ -45,147 +42,62 @@ hs-source-dirs: lib build-depends: - base >= 4.5.0.0 && < 4.8.0.0 + base >= 4.5.0.0 && < 4.9.0.0 , rainbow >= 0.22 && < 0.23 , bytestring >= 0.10 && < 0.11 + , containers >= 0.5.5 && < 0.6 , text >= 0.11.3.1 && < 1.3.0.0 - , transformers >= 0.3.0.0 && < 0.5.0.0 - , array >= 0.4.0.0 && < 0.6.0.0 -Test-Suite rainbox-visual - type: exitcode-stdio-1.0 +source-repository head + type: git + location: https://github.com/massysett/rainbox.git + +Test-Suite rainbox-properties + main-is: rainbox-properties.hs + build-depends: + base >= 4.5.0.0 && < 4.9.0.0 + , rainbow >= 0.22 && < 0.23 + , bytestring >= 0.10 && < 0.11 + , containers >= 0.5.5 && < 0.6 + , text >= 0.11.3.1 && < 1.3.0.0 + , tasty >= 0.10.1 && < 0.11 + , tasty-quickcheck >= 0.8.1 && < 0.9 + , QuickCheck >= 2.7 && < 2.9 ghc-options: -Wall + default-language: Haskell2010 + hs-source-dirs: + lib + test other-modules: Rainbox - Rainbox.Array2d - Rainbox.Box - Rainbox.Box.Primitives - Rainbox.Reader + Rainbox.Core Rainbox.Tutorial Rainbow.Instances - Rainbox.Array2dTests - Rainbox.Box.Instances - Rainbox.Box.PrimitivesTests - Rainbox.BoxDir - Rainbox.BoxTests Rainbox.Instances - Rainbox.ReaderTests - RainboxDir - RainboxTests - Visual + type: exitcode-stdio-1.0 + +Test-Suite rainbox-visual main-is: rainbox-visual.hs - hs-source-dirs: - test - lib - default-language: Haskell2010 build-depends: - base >= 4.5.0.0 && < 4.8.0.0 + base >= 4.5.0.0 && < 4.9.0.0 , rainbow >= 0.22 && < 0.23 , bytestring >= 0.10 && < 0.11 + , containers >= 0.5.5 && < 0.6 , text >= 0.11.3.1 && < 1.3.0.0 - , transformers >= 0.3.0.0 && < 0.5.0.0 - , array >= 0.4.0.0 && < 0.6.0.0 , tasty >= 0.10.1 && < 0.11 , tasty-quickcheck >= 0.8.1 && < 0.9 , QuickCheck >= 2.7 && < 2.9 - , ChasingBottoms >= 1.3.0 && < 1.4 - -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 - Rainbow.Instances - Rainbox.Array2dTests - Rainbox.Box.Instances - Rainbox.Box.PrimitivesTests - Rainbox.BoxDir - Rainbox.BoxTests - Rainbox.Instances - Rainbox.ReaderTests - RainboxDir - RainboxTests - Visual - hs-source-dirs: - test - lib - default-language: Haskell2010 - build-depends: - base >= 4.5.0.0 && < 4.8.0.0 - , rainbow >= 0.22 && < 0.23 - , bytestring >= 0.10 && < 0.11 - , text >= 0.11.3.1 && < 1.3.0.0 - , transformers >= 0.3.0.0 && < 0.5.0.0 - , array >= 0.4.0.0 && < 0.6.0.0 - , tasty >= 0.10.1 && < 0.11 - , tasty-quickcheck >= 0.8.1 && < 0.9 - , QuickCheck >= 2.7 && < 2.9 - , ChasingBottoms >= 1.3.0 && < 1.4 - else - buildable: False - -Test-Suite rainbox-test ghc-options: -Wall - type: exitcode-stdio-1.0 + default-language: Haskell2010 hs-source-dirs: - test lib - default-language: Haskell2010 - build-depends: - base >= 4.5.0.0 && < 4.8.0.0 - , rainbow >= 0.22 && < 0.23 - , bytestring >= 0.10 && < 0.11 - , text >= 0.11.3.1 && < 1.3.0.0 - , transformers >= 0.3.0.0 && < 0.5.0.0 - , array >= 0.4.0.0 && < 0.6.0.0 - , tasty >= 0.10.1 && < 0.11 - , tasty-quickcheck >= 0.8.1 && < 0.9 - , QuickCheck >= 2.7 && < 2.9 - , ChasingBottoms >= 1.3.0 && < 1.4 - main-is: rainbox-test.hs - -source-repository head - type: git - location: https://github.com/massysett/rainbox.git - -Executable rainbox-grid - main-is: rainbox-grid.hs - if flag(grid) - ghc-options: - -Wall - hs-source-dirs: - test - lib - default-language: Haskell2010 - build-depends: - base >= 4.5.0.0 && < 4.8.0.0 - , rainbow >= 0.22 && < 0.23 - , bytestring >= 0.10 && < 0.11 - , text >= 0.11.3.1 && < 1.3.0.0 - , transformers >= 0.3.0.0 && < 0.5.0.0 - , array >= 0.4.0.0 && < 0.6.0.0 - , tasty >= 0.10.1 && < 0.11 - , tasty-quickcheck >= 0.8.1 && < 0.9 - , QuickCheck >= 2.7 && < 2.9 - , ChasingBottoms >= 1.3.0 && < 1.4 - else - buildable: False - -Flag grid - description: Build the rainbox-grid executable - default: False - manual: True - -Flag mosaic - description: Build the rainbox-mosaic executable - default: False - manual: True + test + other-modules: + Rainbox + Rainbox.Core + Rainbox.Tutorial + Rainbow.Instances + Rainbox.Instances + type: exitcode-stdio-1.0 diff --git a/test/Rainbox/Array2dTests.hs b/test/Rainbox/Array2dTests.hs deleted file mode 100644 --- a/test/Rainbox/Array2dTests.hs +++ /dev/null @@ -1,402 +0,0 @@ -module Rainbox.Array2dTests where - -import Test.Tasty -import Test.QuickCheck -import Test.Tasty.QuickCheck (testProperty) -import Data.Array -import Rainbox.Array2d -import Test.ChasingBottoms - --- | 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 undefined . 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 undefined . 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 - -arrayHasNoBottoms :: Ix i => Array i e -> Bool -arrayHasNoBottoms = all (not . isBottom) . elems - -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 "arrayHasNoBottoms fails on arrays with a bottom" $ - expectFailure $ arrayHasNoBottoms (listArray (0 :: Int, 0) []) - - , testProperty "arrayByRows returns arrays with no bottoms" $ - \ls -> arrayHasNoBottoms (arrayByRows () ls) - - , testProperty "arrayByCols returns arrays with no bottoms" $ - \ls -> arrayHasNoBottoms (arrayByCols () ls) - - , testProperty "mapTableNoChangeCols" $ - forAll (fmap Blind genLabelF) $ \(Blind f) -> - forAll genTable $ \t -> - mapTableNoChangeCols f t - - , testProperty "mapTableNoChangeRows" $ - forAll (fmap Blind genLabelF) $ \(Blind 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 (fmap Blind genChangeLabelF) $ \(Blind f) -> - forAll genTable $ \t -> - propMapRowLabelsCols f t - - , testProperty "propMapRowLabelsCells" $ - forAll (fmap Blind genChangeLabelF) $ \(Blind f) -> - forAll genTable $ \t -> - propMapRowLabelsCells f t - - , testProperty "propMapRowLabelsRebuild" $ - forAll genTable propMapRowLabelsRebuild - - , testProperty "propMapRowLabelsRelabel" $ - forAll genTable propMapRowLabelsRelabel - - , testProperty "propMapColLabelsCols" $ - forAll (fmap Blind genChangeLabelF) $ \(Blind f) -> - forAll genTable $ \t -> - propMapColLabelsCols f t - - , testProperty "propMapColLabelsCells" $ - forAll (fmap Blind genChangeLabelF) $ \(Blind f) -> - forAll genTable $ \t -> - propMapColLabelsCells f t - - , testProperty "propMapColLabelsRebuild" $ - forAll genTable propMapColLabelsRebuild - - , testProperty "propMapColLabelsRelabel" $ - forAll genTable propMapColLabelsRelabel - - ] - diff --git a/test/Rainbox/Box/Instances.hs b/test/Rainbox/Box/Instances.hs deleted file mode 100644 --- a/test/Rainbox/Box/Instances.hs +++ /dev/null @@ -1,5 +0,0 @@ -module Rainbox.Box.Instances where - -import Rainbow.Instances () -import Test.QuickCheck - 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,218 +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 Rainbow -import Rainbow.Instances () -import Rainbow.Types -import qualified Data.Text as X -import Rainbox.Box.Primitives - -genText :: Gen X.Text -genText = fmap X.pack $ listOf c - where - c = elements ['0'..'Z'] - -genChunk :: Gen Chunk -genChunk = arbitrary - -genHeight :: Gen Height -genHeight = fmap Height $ frequency [(3, nonNeg), (1, neg)] - where - nonNeg = fmap abs 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 - --- | Generates blank Box. -genBlankBox :: Gen Box -genBlankBox = liftM3 blank arbitrary 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 <- arbitrary - 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 <- arbitrary - 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 :: Radiant -> Int -> Gen Chunk -genChunkLen bk l = do - txt <- fmap X.pack $ vectorOf l (elements ['0'..'Z']) - return $ (chunkFromText txt) <> back bk - --- | 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 <- arbitrary - cks <- vectorOf h (genChunkLen bk w) - let bxs = map (chunks . (:[])) cks - bk' <- arbitrary - 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 :: Radiant - , 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 - <*> arbitrary - <*> 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 chunkTexts $ 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 Rainbow.Types -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 . chunkTexts . 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 --- a/test/Rainbox/Instances.hs +++ b/test/Rainbox/Instances.hs @@ -1,33 +1,64 @@ -{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} - --- | QuickCheck instances for all Rainbox modules. module Rainbox.Instances where import Control.Monad import Test.QuickCheck +import Rainbox.Core import Rainbow.Instances () -import Rainbox -import Rainbox.Box +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 [ ATop, ABottom ] + +instance Arbitrary Vertical where + arbitrary = elements [ ALeft, ARight ] + instance Arbitrary Height where - arbitrary = fmap Height arbitrary + arbitrary = fmap Height $ frequency + [ (3, fmap getNonNegative arbitrary) + , (1, arbitrary) + ] instance Arbitrary Width where - arbitrary = fmap Width arbitrary + arbitrary = fmap Width $ frequency + [ (3, fmap getNonNegative arbitrary) + , (1, arbitrary) + ] -instance Arbitrary (Align Vert) where - arbitrary = elements [center, top, bottom] +instance Arbitrary Core where + arbitrary = fmap Core arbitrary -instance Arbitrary (Align Horiz) where - arbitrary = elements [center, left, right] +instance Arbitrary Rod where + arbitrary = fmap Rod arbitrary -instance Arbitrary Bar where - arbitrary = fmap Bar arbitrary +instance Arbitrary a => Arbitrary (Seq a) where + arbitrary = fmap Seq.fromList arbitrary --- | Creates a non-nested Box. -instance Arbitrary Box where - arbitrary = liftM3 barsToBox arbitrary arbitrary 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 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 abs arbitrarySizedIntegral), - (1, arbitrarySizedIntegral)] - v <- frequency [(3, fmap abs 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/Visual.hs b/test/Visual.hs deleted file mode 100644 --- a/test/Visual.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Visual where - -import Control.Monad -import Rainbox.Box -import Rainbow -import Test.QuickCheck hiding (resize) -import Test.QuickCheck.Gen hiding (resize) -import Test.QuickCheck.Random -import Rainbox.Box.PrimitivesTests -import Rainbow.Instances () -import Data.String - -colors = fore yellow <> back blue - -narrow = "narrow box" <> colors - -midwidth = "medium width box" <> colors - -wide = "a wide box, see how wide I am?" <> colors - -all3 = [narrow, midwidth, wide] - -short = chunk narrow - -midheight = catV green left . map chunk $ [narrow, midwidth] - -tall = catV green left . map chunk $ [narrow, midwidth, wide] - -sizeParam = 7 - -describe s b = do - putStrLn (s ++ ":") - printBox b - putStrLn "" - -testCompound :: String -> (Radiant -> [Box] -> Box) -> IO () -testCompound d f = do - g <- newQCGen - let bxs = unGen (replicateM 5 genTextBox) g sizeParam - bk = unGen arbitrary g sizeParam - describe d $ f bk bxs - -testVert - :: String - -> (Radiant -> 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 - -> (Radiant -> 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 noColorRadiant left . map mkLine $ clrs - where - mkLine clr = chunk $ txt <> clr - txt = fromString ['0'..'9'] - clrs = map back . take 10 . iterate (+6) $ (160 :: Word8) - -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) - - testHoriz "column" (\bk ah bxs -> catV noColorRadiant 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-grid.hs b/test/rainbox-grid.hs deleted file mode 100644 --- a/test/rainbox-grid.hs +++ /dev/null @@ -1,13 +0,0 @@ --- | Prints a random grid using the main Rainbox module. Ignores all --- command line arguments. - -module Main where - -import Test.QuickCheck -import Rainbox.Instances () -import Rainbox - -main :: IO () -main = do - rows <- generate (resize 5 arbitrary) - printBox $ gridByRows rows diff --git a/test/rainbox-mosaic.hs b/test/rainbox-mosaic.hs deleted file mode 100644 --- a/test/rainbox-mosaic.hs +++ /dev/null @@ -1,16 +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 -import Rainbox.Box.PrimitivesTests -import System.Environment -import Rainbox.Box - -main :: IO () -main = do - s:[] <- getArgs - bx <- generate (Test.QuickCheck.resize (read s) genBox) - printBox 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,153 @@ +module Main where + +import Rainbox.Core +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 "intersperse" $ + [ testProperty "makes no change to empty Seq" $ + intersperse undefined Seq.empty == (Seq.empty :: Seq ()) + + , testProperty "makes no change to singleton Seq" $ + intersperse undefined (Seq.singleton ()) == Seq.singleton () + + , testProperty "lengthens other Seq by length - 1" $ \i -> + i > 1 ==> + Seq.length (intersperse undefined (Seq.replicate i ())) == + i + (i - 1) + ] + + , 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) -> + width c == F.sum (fmap 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 + ] + + + ] + +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,24 @@ --- | Rainbox visual tests. --- --- Tests that are intended to be run and then examined visually. +-- | Prints all the boxes in the tutorial. The output must be +-- visually inspected. module Main where -import Visual +import Rainbox.Tutorial +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 "stationTable" renderStationTable