diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,21 @@ Brick changelog --------------- +0.71 +---- + +Package changes: + * Increased `vty` lower bound to `5.36`. + +API changes: + * Added `tests/Render.hs` to provide a simple test of + `Brick.Main.renderWidget` (thanks @valyagolev) + * Added `Brick.Main.renderWidget` to help in golden testing contexts + (thanks @valyagolev) + +Other changes: + * Various `table` documentation improvements. + 0.70.1 ------ diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -20,6 +20,7 @@ Here's an example interface (see `programs/ReadmeDemo.hs`): ``` +joinBorders $ withBorderStyle unicode $ borderWithLabel (str "Hello!") $ (center (str "Left") <+> vBorder <+> center (str "Right")) @@ -34,7 +35,7 @@ │ Left │ Right │ │ │ │ │ │ │ -└────────────────────────┘ +└───────────┴────────────┘ ``` Featured Projects diff --git a/brick.cabal b/brick.cabal --- a/brick.cabal +++ b/brick.cabal @@ -1,5 +1,5 @@ name: brick -version: 0.70.1 +version: 0.71 synopsis: A declarative terminal user interface library description: Write terminal user interfaces (TUIs) painlessly with 'brick'! You @@ -32,7 +32,7 @@ license-file: LICENSE author: Jonathan Daugherty maintainer: Jonathan Daugherty -copyright: (c) Jonathan Daugherty 2015-2021 +copyright: (c) Jonathan Daugherty 2015-2022 category: Graphics build-type: Simple cabal-version: 1.18 @@ -112,7 +112,7 @@ Brick.Widgets.Internal build-depends: base >= 4.9.0.0 && < 4.17.0.0, - vty >= 5.33, + vty >= 5.36, transformers, data-clist >= 0.1, directory >= 1.2.5.0, @@ -511,10 +511,11 @@ ghc-options: -Wall -Wcompat -Wno-orphans -O2 default-language: Haskell2010 main-is: Main.hs - other-modules: List + other-modules: List Render build-depends: base <=5, brick, containers, microlens, vector, + vty, QuickCheck diff --git a/programs/ReadmeDemo.hs b/programs/ReadmeDemo.hs --- a/programs/ReadmeDemo.hs +++ b/programs/ReadmeDemo.hs @@ -1,12 +1,13 @@ module Main where -import Brick (Widget, simpleMain, (<+>), str, withBorderStyle) +import Brick (Widget, simpleMain, (<+>), str, withBorderStyle, joinBorders) import Brick.Widgets.Center (center) import Brick.Widgets.Border (borderWithLabel, vBorder) import Brick.Widgets.Border.Style (unicode) ui :: Widget () ui = + joinBorders $ withBorderStyle unicode $ borderWithLabel (str "Hello!") $ (center (str "Left") <+> vBorder <+> center (str "Right")) diff --git a/src/Brick/Forms.hs b/src/Brick/Forms.hs --- a/src/Brick/Forms.hs +++ b/src/Brick/Forms.hs @@ -30,8 +30,9 @@ -- button sequence). -- -- To use a 'Form', you must include it within your application state --- type. You can use 'formState' to access the underlying s whenever you --- need it. See @programs/FormDemo.hs@ for a complete working example. +-- type. You can use 'formState' to access the underlying state whenever +-- you need it. See @programs/FormDemo.hs@ for a complete working +-- example. -- -- Also note that, by default, forms and their field inputs are -- concatenated together in a 'vBox'. This can be customized on a diff --git a/src/Brick/Main.hs b/src/Brick/Main.hs --- a/src/Brick/Main.hs +++ b/src/Brick/Main.hs @@ -47,6 +47,7 @@ , renderFinal , getRenderState , resetRenderState + , renderWidget ) where diff --git a/src/Brick/Widgets/Internal.hs b/src/Brick/Widgets/Internal.hs --- a/src/Brick/Widgets/Internal.hs +++ b/src/Brick/Widgets/Internal.hs @@ -4,6 +4,7 @@ , cropToContext , cropResultToContext , renderDynBorder + , renderWidget ) where @@ -12,7 +13,9 @@ import Control.Monad (forM_) import Control.Monad.Trans.State.Lazy import Control.Monad.Trans.Reader +import Data.Maybe (fromMaybe) import qualified Data.Map as M +import qualified Data.Set as S import Data.Maybe (catMaybes) import qualified Graphics.Vty as V @@ -154,3 +157,36 @@ Edges True True False True -> bsIntersectL Edges True True True False -> bsIntersectR Edges True True True True -> bsIntersectFull + +-- | This function provides a simplified interface to rendering a list +-- of 'Widget's as a 'V.Picture' outside of the context of an 'App'. +-- This can be useful in a testing setting but isn't intended to be used +-- for normal application rendering. The API is deliberately narrower +-- than the main interactive API and is not yet stable. Use at your own +-- risk. +-- +-- Consult the [Vty library documentation](https://hackage.haskell.org/package/vty) +-- for details on how to output the resulting 'V.Picture'. +renderWidget :: (Ord n) + => Maybe AttrMap + -- ^ Optional attribute map used to render. If omitted, + -- an empty attribute map with the terminal's default + -- attribute will be used. + -> [Widget n] + -- ^ The widget layers to render, topmost first. + -> V.DisplayRegion + -- ^ The size of the display region in which to render the + -- layers. + -> V.Picture +renderWidget mAttrMap layerRenders region = pic + where + initialRS = RS { viewportMap = M.empty + , rsScrollRequests = [] + , observedNames = S.empty + , renderCache = mempty + , clickableNames = [] + , requestedVisibleNames_ = S.empty + , reportedExtents = mempty + } + am = fromMaybe (attrMap V.defAttr []) mAttrMap + (_, pic, _, _) = renderFinal am layerRenders region (const Nothing) initialRS diff --git a/src/Brick/Widgets/Table.hs b/src/Brick/Widgets/Table.hs --- a/src/Brick/Widgets/Table.hs +++ b/src/Brick/Widgets/Table.hs @@ -1,4 +1,8 @@ --- | Support for basic table drawing. +{-# LANGUAGE MultiWayIf #-} +-- | This module provides a table widget that can draw other widgets +-- in a table layout, draw borders between rows and columns, and allow +-- configuration of row and column alignment. To get started, see +-- 'table'. module Brick.Widgets.Table ( -- * Types @@ -45,7 +49,8 @@ import Brick.Widgets.Center import Brick.Widgets.Border --- | Column alignment modes. +-- | Column alignment modes. Use these modes with the alignment +-- functions in this module to configure column alignment behavior. data ColumnAlignment = AlignLeft -- ^ Align all cells to the left. @@ -55,7 +60,8 @@ -- ^ Align all cells to the right. deriving (Eq, Show, Read) --- | Row alignment modes. +-- | Row alignment modes. Use these modes with the alignment functions +-- in this module to configure row alignment behavior. data RowAlignment = AlignTop -- ^ Align all cells to the top. @@ -76,7 +82,8 @@ instance E.Exception TableException where --- | A table data structure. +-- | A table data structure for widgets of type 'Widget' @n@. Create a +-- table with 'table'. data Table n = Table { columnAlignments :: M.Map Int ColumnAlignment , rowAlignments :: M.Map Int RowAlignment @@ -90,34 +97,49 @@ -- | Construct a new table. -- --- The argument is the list of rows, with each element of the argument --- list being the columns of the respective row. +-- The argument is the list of rows with the topmost row first, with +-- each element of the argument list being the contents of the cells in +-- in each column of the respective row, with the leftmost cell first. -- --- By default, all columns are left-aligned. Use the alignment functions --- in this module to change that behavior. +-- Each row's height is determined by the height of the tallest cell +-- in that row, and each column's width is determined by the width of +-- the widest cell in that column. This means that control over row +-- and column dimensions is a matter of controlling the size of the +-- individual cells, such as by wrapping cell contents in padding, +-- 'fill' and 'hLimit' or 'vLimit', etc. This also means that it is not +-- necessary to explicitly set the width of most table cells because +-- the table will determine the per-row and per-column dimensions by +-- looking at the largest cell contents. In particular, this means +-- that the table's alignment logic only has an effect when a given +-- cell's contents are smaller than the maximum for its row and column, +-- thus giving the table some way to pad the contents to result in the +-- desired alignment. -- --- By default, all rows are top-aligned. Use the alignment functions in --- this module to change that behavior. +-- By default: -- --- By default, the table will draw borders between columns, between --- rows, and around the outside of the table. Border-drawing behavior --- can be configured with the API in this module. Note that tables --- always draw with 'joinBorders' enabled. +-- * All columns are left-aligned. Use the alignment functions in this +-- module to change that behavior. +-- * All rows are top-aligned. Use the alignment functions in this +-- module to change that behavior. +-- * The table will draw borders between columns, between rows, and +-- around the outside of the table. Border-drawing behavior can be +-- configured with the API in this module. Note that tables always draw +-- with 'joinBorders' enabled. If a cell's contents has smart borders +-- but you don't want those borders to connect to the surrounding table +-- borders, wrap the cell's contents with 'freezeBorders'. -- -- All cells of all rows MUST use the 'Fixed' growth policy for both --- horizontal and vertical growth. If the argument list contains --- any cells that use the 'Greedy' policy, this will raise a +-- horizontal and vertical growth. If the argument list contains any +-- cells that use the 'Greedy' policy, this function will raise a -- 'TableException'. -- --- All rows must have the same number of cells. If not, this will raise --- a 'TableException'. +-- All rows MUST have the same number of cells. If not, this function +-- will raise a 'TableException'. table :: [[Widget n]] -> Table n table rows = - if not allFixed - then E.throw TEInvalidCellSizePolicy - else if not allSameLength - then E.throw TEUnequalRowSizes - else t + if | not allFixed -> E.throw TEInvalidCellSizePolicy + | not allSameLength -> E.throw TEUnequalRowSizes + | otherwise -> t where allSameLength = length (nub (length <$> rows)) <= 1 allFixed = all fixedRow rows @@ -149,43 +171,49 @@ t { drawColumnBorders = b } -- | Align the specified column to the right. The argument is the column --- index, starting with zero. +-- index, starting with zero. Silently does nothing if the index is out +-- of range. alignRight :: Int -> Table n -> Table n alignRight = setColAlignment AlignRight -- | Align the specified column to the left. The argument is the column --- index, starting with zero. +-- index, starting with zero. Silently does nothing if the index is out +-- of range. alignLeft :: Int -> Table n -> Table n alignLeft = setColAlignment AlignLeft -- | Align the specified column to center. The argument is the column --- index, starting with zero. +-- index, starting with zero. Silently does nothing if the index is out +-- of range. alignCenter :: Int -> Table n -> Table n alignCenter = setColAlignment AlignCenter -- | Align the specified row to the top. The argument is the row index, --- starting with zero. +-- starting with zero. Silently does nothing if the index is out of +-- range. alignTop :: Int -> Table n -> Table n alignTop = setRowAlignment AlignTop -- | Align the specified row to the middle. The argument is the row --- index, starting with zero. +-- index, starting with zero. Silently does nothing if the index is out +-- of range. alignMiddle :: Int -> Table n -> Table n alignMiddle = setRowAlignment AlignMiddle -- | Align the specified row to bottom. The argument is the row index, --- starting with zero. +-- starting with zero. Silently does nothing if the index is out of +-- range. alignBottom :: Int -> Table n -> Table n alignBottom = setRowAlignment AlignBottom -- | Set the alignment for the specified column index (starting at --- zero). +-- zero). Silently does nothing if the index is out of range. setColAlignment :: ColumnAlignment -> Int -> Table n -> Table n setColAlignment a col t = t { columnAlignments = M.insert col a (columnAlignments t) } -- | Set the alignment for the specified row index (starting at --- zero). +-- zero). Silently does nothing if the index is out of range. setRowAlignment :: RowAlignment -> Int -> Table n -> Table n setRowAlignment a row t = t { rowAlignments = M.insert row a (rowAlignments t) } @@ -208,9 +236,10 @@ joinBorders $ Widget Fixed Fixed $ do ctx <- getContext - let rows = tableRows t - cellResults <- forM rows $ mapM render - let rowHeights = rowHeight <$> cellResults + cellResults <- forM (tableRows t) $ mapM render + + let maybeIntersperse f v = if f t then intersperse v else id + rowHeights = rowHeight <$> cellResults colWidths = colWidth <$> byColumn allRowAligns = (\i -> M.findWithDefault (defaultRowAlignment t) i (rowAlignments t)) <$> [0..length rowHeights - 1] @@ -220,65 +249,83 @@ colWidth = maximum . fmap (imageWidth . image) byColumn = transpose cellResults toW = Widget Fixed Fixed . return - applyColAlignment align width w = - Widget Fixed Fixed $ do - result <- render w - case align of - AlignLeft -> render $ hLimit width $ padRight Max $ toW result - AlignCenter -> render $ hLimit width $ hCenter $ toW result - AlignRight -> render $ - padLeft (Pad (width - imageWidth (image result))) $ - toW result - applyRowAlignment rHeight align result = - case align of - AlignTop -> vLimit rHeight $ padBottom Max $ toW result - AlignMiddle -> vLimit rHeight $ vCenter $ toW result - AlignBottom -> vLimit rHeight $ padTop Max $ toW result - fixEmtpyCell w h result = + fillEmptyCell w h result = if imageWidth (image result) == 0 && imageHeight (image result) == 0 then result { image = charFill (ctx^.attrL) ' ' w h } else result - mkColumn (hAlign, width, colCells) = do + mkColumn (hAlign, width, colCells) = let paddedCells = flip map (zip3 allRowAligns rowHeights colCells) $ \(vAlign, rHeight, cell) -> - applyColAlignment hAlign width $ + applyColAlignment width hAlign $ applyRowAlignment rHeight vAlign $ - fixEmtpyCell width rHeight cell - maybeRowBorders = if drawRowBorders t - then intersperse (hLimit width hBorder) - else id - render $ vBox $ maybeRowBorders paddedCells - columns <- mapM mkColumn $ zip3 allColAligns colWidths byColumn + toW $ + fillEmptyCell width rHeight cell + maybeRowBorders = maybeIntersperse drawRowBorders (hLimit width hBorder) + in vBox $ maybeRowBorders paddedCells - let tl = joinableBorder (Edges False True False True) - tr = joinableBorder (Edges False True True False) - bl = joinableBorder (Edges True False False True) - br = joinableBorder (Edges True False True False) - cross = joinableBorder (Edges True True True True) - leftT = joinableBorder (Edges True True False True) - rightT = joinableBorder (Edges True True True False) - topT = joinableBorder (Edges False True True True) - bottomT = joinableBorder (Edges True False True True) vBorders = mkVBorder <$> rowHeights hBorders = mkHBorder <$> colWidths mkHBorder w = hLimit w hBorder mkVBorder h = vLimit h vBorder - topBorder = hBox $ (if drawColumnBorders t then intersperse topT else id) hBorders - bottomBorder = hBox $ (if drawColumnBorders t then intersperse bottomT else id) hBorders - leftBorder = vBox $ tl : (if drawRowBorders t then intersperse leftT else id) vBorders <> [bl] - rightBorder = vBox $ tr : (if drawRowBorders t then intersperse rightT else id) vBorders <> [br] - maybeAddSurroundingBorder body = - if not $ drawSurroundingBorder t - then body - else leftBorder <+> (topBorder <=> body <=> bottomBorder) <+> rightBorder - maybeAddColumnBorders = - if not $ drawColumnBorders t - then id - else let maybeAddCrosses = if drawRowBorders t - then intersperse cross - else id - columnBorder = vBox $ maybeAddCrosses vBorders - in intersperse columnBorder + topBorder = + hBox $ maybeIntersperse drawColumnBorders topT hBorders + bottomBorder = + hBox $ maybeIntersperse drawColumnBorders bottomT hBorders + leftBorder = + vBox $ topLeftCorner : maybeIntersperse drawRowBorders leftT vBorders <> [bottomLeftCorner] + rightBorder = + vBox $ topRightCorner : maybeIntersperse drawRowBorders rightT vBorders <> [bottomRightCorner] - render $ maybeAddSurroundingBorder $ - hBox $ - maybeAddColumnBorders $ toW <$> columns + maybeWrap check f = + if check t then f else id + addSurroundingBorder body = + leftBorder <+> (topBorder <=> body <=> bottomBorder) <+> rightBorder + addColumnBorders = + let maybeAddCrosses = maybeIntersperse drawRowBorders cross + columnBorder = vBox $ maybeAddCrosses vBorders + in intersperse columnBorder + + let columns = mkColumn <$> zip3 allColAligns colWidths byColumn + body = hBox $ + maybeWrap drawColumnBorders addColumnBorders columns + render $ maybeWrap drawSurroundingBorder addSurroundingBorder body + +topLeftCorner :: Widget n +topLeftCorner = joinableBorder $ Edges False True False True + +topRightCorner :: Widget n +topRightCorner = joinableBorder $ Edges False True True False + +bottomLeftCorner :: Widget n +bottomLeftCorner = joinableBorder $ Edges True False False True + +bottomRightCorner :: Widget n +bottomRightCorner = joinableBorder $ Edges True False True False + +cross :: Widget n +cross = joinableBorder $ Edges True True True True + +leftT :: Widget n +leftT = joinableBorder $ Edges True True False True + +rightT :: Widget n +rightT = joinableBorder $ Edges True True True False + +topT :: Widget n +topT = joinableBorder $ Edges False True True True + +bottomT :: Widget n +bottomT = joinableBorder $ Edges True False True True + +applyColAlignment :: Int -> ColumnAlignment -> Widget n -> Widget n +applyColAlignment width align w = + hLimit width $ case align of + AlignLeft -> padRight Max w + AlignCenter -> hCenter w + AlignRight -> padLeft Max w + +applyRowAlignment :: Int -> RowAlignment -> Widget n -> Widget n +applyRowAlignment rHeight align w = + vLimit rHeight $ case align of + AlignTop -> padBottom Max w + AlignMiddle -> vCenter w + AlignBottom -> padTop Max w diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -13,6 +13,7 @@ import qualified Data.IntMap as IntMap import qualified List +import qualified Render instance Arbitrary v => Arbitrary (Run v) where arbitrary = liftA2 (\(Positive n) -> Run n) arbitrary arbitrary @@ -111,5 +112,5 @@ main :: IO () main = - (all id <$> sequenceA [$quickCheckAll, List.main]) + (all id <$> sequenceA [$quickCheckAll, List.main, Render.main]) >>= bool exitFailure exitSuccess diff --git a/tests/Render.hs b/tests/Render.hs new file mode 100644 --- /dev/null +++ b/tests/Render.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeApplications #-} +module Render + ( main + ) +where + +import Brick +import Control.Monad (when) +#if !(MIN_VERSION_base(4,11,0)) +import Data.Monoid +#endif +import qualified Graphics.Vty as V +import Brick.Widgets.Border (hBorder) +import Control.Exception (try) + +region :: V.DisplayRegion +region = (30, 10) + +renderDisplay :: Ord n => [Widget n] -> IO () +renderDisplay ws = do + outp <- V.outputForConfig V.defaultConfig + ctx <- V.displayContext outp region + V.outputPicture ctx (renderWidget Nothing ws region) + V.releaseDisplay outp + +myWidget :: Widget () +myWidget = str "Why" <=> hBorder <=> str "not?" + +-- Since you can't Read a Picture, we have to compare the result with +-- the Shown one +expectedResult :: String +expectedResult = "Picture {picCursor = NoCursor, picLayers = [VertJoin {partTop = VertJoin {partTop = HorizText {attr = Attr {attrStyle = Default, attrForeColor = Default, attrBackColor = Default, attrURL = Default}, displayText = \"Why \", outputWidth = 30, charWidth = 30}, partBottom = VertJoin {partTop = HorizText {attr = Attr {attrStyle = Default, attrForeColor = Default, attrBackColor = Default, attrURL = Default}, displayText = \"\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\\9472\", outputWidth = 30, charWidth = 30}, partBottom = HorizText {attr = Attr {attrStyle = Default, attrForeColor = Default, attrBackColor = Default, attrURL = Default}, displayText = \"not? \", outputWidth = 30, charWidth = 30}, outputWidth = 30, outputHeight = 2}, outputWidth = 30, outputHeight = 3}, partBottom = BGFill {outputWidth = 30, outputHeight = 7}, outputWidth = 30, outputHeight = 10}], picBackground = Background {backgroundChar = ' ', backgroundAttr = Attr {attrStyle = Default, attrForeColor = Default, attrBackColor = Default, attrURL = Default}}}" + +main :: IO Bool +main = do + result <- try (renderDisplay [myWidget]) :: IO (Either V.VtyConfigurationError ()) + case result of + Left _ -> do + putStrLn "Terminal is not available, skipping test" + -- Even though we could not actually run the test, we return + -- True here to prevent the absence of a terminal from + -- causing a test suite failure in an automated context. + -- This means that this test effectively doesn't get + -- considered at all in the automated context. + return True + Right () -> do + let matched = actualResult == expectedResult + actualResult = show (renderWidget Nothing [myWidget] region) + msg = if matched then "rendering match" else "rendering mismatch" + + putStrLn "" + putStrLn $ "renderWidget test outcome: " <> msg + + when (not matched) $ do + putStrLn "Expected result:" + putStrLn expectedResult + + putStrLn "Actual result:" + putStrLn actualResult + + return matched