diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,16 @@ Brick changelog --------------- +0.36 +---- + +New features: + * Dynamic border support: adjacent widgets that use borders can make + those borders seamlessly connect to each other! Thanks + so much to Daniel Wagner for this feature! Please see + `programs/DynamicBorderDemo.hs` for a demonstraton. Also see the + "Joinable Borders" section of the User Guide. + 0.35.1 ------ diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -62,7 +62,7 @@ * `matterhorn`, a client for [Mattermost](https://about.mattermost.com/): https://github.com/matterhorn-chat/matterhorn * `viewprof`, a GHC profile viewer: https://github.com/maoe/viewprof * `tart`, a mouse-driven ASCII art drawing program: https://github.com/jtdaugherty/tart - * `silly-joy`, an interpreter for Joy in Haskell: https://github.com/rootmos/silly-joy + * `silly-joy`, an interpreter for Joy: https://github.com/rootmos/silly-joy * `herms`, a command-line tool for managing kitchen recipes: https://github.com/jackkiefer/herms * `purebred`, a mail user agent: https://github.com/purebred-mua/purebred * `2048Haskell`, an implementation of the 2048 game: https://github.com/8Gitbrix/2048Haskell @@ -98,8 +98,6 @@ `brick` comes with a bunch of batteries included: -Low-level stuff: - * Vertical and horizontal box layout widgets * Basic single- and multi-line text editor widgets * List widget @@ -113,6 +111,7 @@ * Extensible widget-building API * User-customizable attribute themes * Type-safe, validated input form API (see the `Brick.Forms` module) + * Borders can be configured to automatically connect! Brick-Users Discussion ---------------------- diff --git a/brick.cabal b/brick.cabal --- a/brick.cabal +++ b/brick.cabal @@ -1,5 +1,5 @@ name: brick -version: 0.35.1 +version: 0.36 synopsis: A declarative terminal user interface library description: Write terminal applications painlessly with 'brick'! You write an @@ -34,7 +34,7 @@ copyright: (c) Jonathan Daugherty 2015-2018 category: Graphics build-type: Simple -cabal-version: >=1.18 +cabal-version: 1.18 Homepage: https://github.com/jtdaugherty/brick/ Bug-reports: https://github.com/jtdaugherty/brick/issues tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.1 @@ -62,6 +62,7 @@ Brick Brick.AttrMap Brick.BChan + Brick.BorderMap Brick.Focus Brick.Forms Brick.Main @@ -77,8 +78,10 @@ Brick.Widgets.Edit Brick.Widgets.List Brick.Widgets.ProgressBar + Data.IMap Data.Text.Markup other-modules: + Brick.Types.Common Brick.Types.TH Brick.Types.Internal Brick.Widgets.Internal @@ -392,6 +395,20 @@ text, microlens +executable brick-dynamic-border-demo + if !flag(demos) + Buildable: False + hs-source-dirs: programs + ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O3 + default-extensions: CPP + default-language: Haskell2010 + main-is: DynamicBorderDemo.hs + build-depends: base <= 5, + brick, + vty >= 5.18.1, + text, + microlens + executable brick-progressbar-demo if !flag(demos) Buildable: False @@ -405,3 +422,16 @@ vty >= 5.18.1, text, microlens + +test-suite brick-tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + ghc-options: -Wall -O2 + if impl(ghc >= 8) + ghc-options: -Wno-orphans + default-language: Haskell2010 + main-is: Main.hs + build-depends: base <=5, + brick, + containers, + QuickCheck diff --git a/docs/guide.rst b/docs/guide.rst --- a/docs/guide.rst +++ b/docs/guide.rst @@ -714,6 +714,25 @@ let w = withBorderStyle Brick.Widgets.Border.Style.ascii $ Brick.Widgets.Border.border $ str "Hello, world!" +By default, borders in adjacent widgets do not connect to each other. +This can lead to visual oddities, for example, when horizontal borders +are drawn next to vertical borders by leaving a small gap like this: + +.. code:: text + + │─ + +You can request that adjacent borders connect to each other with +``Brick.Widgets.Core.joinBorders``. Two borders drawn with the +same attribute and border style, and both under the influence of +``joinBorders``, will produce a border like this instead: + +.. code:: text + + ├─ + +See `Joining Borders`_ for further details. + How Attributes Work =================== @@ -771,7 +790,7 @@ Customizations are written in an INI-style file. Here's an example: -.. code:: +.. code:: ini [default] default.fg = blue @@ -1454,6 +1473,192 @@ the ``FormFieldState`` and ``FormField`` data types along with the implementations of the built-in form field types. +Joining Borders +=============== + +Brick supports a feature called "joinable borders" which means that +borders drawn in adjacent widgets can be configured to automatically +"join" with each other using the appropriate intersection characters. +This feature is helpful for creating seamless connected borders without +the need for manual calculations to determine where to draw intersection +characters. + +Under normal circumstances, widgets are self-contained in that their +renderings do not interact with the appearance of adjacent widgets. This +is unfortunate for borders: one often wants to draw a T-shaped character +at the intersection of a vertical and horizontal border, for example. +To facilitate automatically adding such characters, ``brick`` offers +some border-specific capabilities for widgets to re-render themselves +as information about neighboring widgets becomes available during the +rendering process. + +Border-joining works by iteratively *redrawing* the edges of widgets as +those edges come into contact with other widgets during rendering. If +the adjacent edge locations of two widgets both use joinable borders, +the Brick will re-draw one of the characters to so that it connects +seamlessly with the adjacent border. + +How Joining Works +----------------- + +When a widget is rendered, it can report supplementary information +about each position on its edges. Each position has four notional line +segments extending from its center, arranged like this: + +.. code:: text + + top + | + | + left ----+---- right + | + | + bottom + +These segments can independently be *drawn*, *accepting*, and +*offering*, as captured in the ``Brick.Types.BorderSegment`` type: + +.. code:: haskell + + data BorderSegment = BorderSegment + { bsAccept :: Bool + , bsOffer :: Bool + , bsDraw :: Bool + } + +If no information is reported for a position, it assumed that it is +not drawn, not accepting, and not offering -- and so it will never +be rewritten. This situation is the ordinary situation where an edge +location is not a border at all, or is a border that we don't want to +join to other borders. + +Line segments that are *drawn* are used for deciding which part of the +``BorderStyle`` to use if this position needs to be updated. (See also +`The Active Border Style`_.) For example, suppose a position needs to +be redrawn, and already has the left and bottom segments drawn; then it +will replace the current character with the upper-right corner drawing +character ``bsCornerTR`` from its border style. + +The *accepting* and *offering* properties are used to perform a small +handshake between neighboring widgets; when the handshake is successful, +one segment will transition to being drawn. For example, suppose a +horizontal and vertical border widget are drawn next to each other: + +.. code:: text + + top + (offering) top + | + | + left + right left ----+---- right + | (offering) (offering) + | + bottom bottom + (offering) + +These borders are accepting in all directions, drawn in the directions +signified by visible lines, and offering in the directions written. +Since the horizontal border on the right is offering towards the +vertical border, and the vertical border is accepting from the direction +towards the horizontal border, the right segment of the vertical +border will transition to being drawn. This will trigger an update of +the ``Image`` associated with the left widget, overwriting whatever +character is there currently with a ``bsIntersectL`` character instead. +The state of the segments afterwards will be the same, but the fact that +there is one more segment drawn will be recorded: + +.. code:: text + + top + (offering) top + | + | + left +---- right left ----+---- right + | (offering) (offering) + | + bottom bottom + (offering) + +It is important that this be recorded: we may later place this combined +widget to the right of another horizontal border, in which case we +would want to transition again from a ``bsIntersectL`` character to a +``bsIntersectFull`` character that represents all four segments being +drawn. + +Because this involves an interaction between multiple widgets, we +may find that the two widgets involved were rendered under different +rendering contexts. To avoid mixing and matching border styles and +drawing attributes, each location records not just the state of its +four segments but also the border style and attribute that were active +at the time the border was drawn. This information is stored in +``Brick.Types.DynBorder``. + +.. code:: haskell + + data DynBorder = DynBorder + { dbStyle :: BorderStyle + , dbAttr :: Attr + , dbSegments :: Edges BorderSegment + } + +The ``Brick.Types.Edges`` type has one field for each direction: + +.. code:: haskell + + data Edges a = Edges { eTop, eBottom, eLeft, eRight :: a } + +In addition to the offer/accept handshake described above, segments also +check that their neighbor's ``BorderStyle`` and ``Attr`` match their own +before transitioning from undrawn to drawn to avoid visual glitches from +trying to connect e.g. ``unicode`` borders to ``ascii`` ones or green +borders to red ones. + +The above description applies to a single location; any given widget's +result may report information about any location on its border using the +``Brick.BorderMap.BorderMap`` type. A ``BorderMap a`` is close kin to a +``Data.Map.Map Location a`` except that each ``BorderMap`` has a fixed +rectangle on which keys are retained. Values inserted at other keys are +silently discarded. + +For backwards compatibility, all the widgets that ship with ``brick`` +avoid reporting any border information by default, but ``brick`` offers +three ways of modifying the border-joining behavior of a widget. + +* ``Brick.Widgets.Core.joinBorders`` instructs any borders drawn in its + child widget to report their edge information. It does this + by setting a flag in the rendering context that tells the + ``Brick.Widgets.Border`` widgets to report the information described + above. Consequently, widgets drawn in this context will join their + borders with neighbors. +* ``Brick.Widgets.Core.separateBorders`` does the opposite of + ``joinBorders`` by unsetting the same context flag, preventing border + widgets from attempting to connect. +* ``Brick.Widgets.Core.freezeBorders`` lets its child widget connect its + borders internally but prevents it from connecting with anything + outside the ``freezeBorders`` call. It does this by deleting the edge + metadata about its child widget. This means that any connections + already made within the child widget will stay as they are but no new + connections will be made to adjacent widgets. For example, one might + use this to create a box with internal but no external connections: + + .. code:: haskell + + joinBorders . freezeBorders . border . hBox $ + [str "left", vBorder, str "right"] + + Or to create a box that allows external connections but not internal + ones: + + .. code:: haskell + + joinBorders . border . freezeBorders . hBox $ + [str "left", vBorder, str "right"] + +When creating new widgets, if you would like ``joinBorders`` and +``separateBorders`` to affect the behavior of your widget, you may do +so by consulting the ``ctxDynBorders`` field of the rendering context +before writing to your ``Result``'s ``borders`` field. + The Rendering Cache =================== @@ -1539,6 +1744,7 @@ , cursors :: [Brick.Types.CursorLocation n] , visibilityRequests :: [Brick.Types.VisibilityRequest] , extents :: [Extent n] + , borders :: BorderMap DynBorder } The rendering function runs in the ``RenderM`` monad, which gives us @@ -1555,6 +1761,7 @@ , availHeight :: Int , ctxBorderStyle :: BorderStyle , ctxAttrMap :: AttrMap + , ctxDynBorders :: Bool } and has lens fields exported as described in `Conventions`_. diff --git a/programs/DynamicBorderDemo.hs b/programs/DynamicBorderDemo.hs new file mode 100644 --- /dev/null +++ b/programs/DynamicBorderDemo.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import qualified Brick.Main as M +import Brick.Types + ( Widget + ) +import qualified Brick.Widgets.Center as C +import qualified Brick.Widgets.Core as C +import qualified Brick.Widgets.Border as B +import qualified Brick.Widgets.Border.Style as BS + +doubleHorizontal :: BS.BorderStyle +doubleHorizontal = BS.BorderStyle + { BS.bsCornerTL = '╒' + , BS.bsCornerTR = '╕' + , BS.bsCornerBR = '╛' + , BS.bsCornerBL = '╘' + , BS.bsIntersectL = '╞' + , BS.bsIntersectR = '╡' + , BS.bsIntersectT = '╤' + , BS.bsIntersectB = '╧' + , BS.bsIntersectFull = '╪' + , BS.bsHorizontal = '═' + , BS.bsVertical = '│' + } + +box1 :: Widget () +box1 + = C.withBorderStyle doubleHorizontal . B.border + . C.withBorderStyle BS.unicodeRounded . B.border + $ C.str "25 kg" + +weights :: Widget () +weights = C.withBorderStyle doubleHorizontal $ C.hBox + [ box1 + , C.str "\n\n" C.<=> B.hBorder + , box1 + ] + +box2 :: Widget () +box2 = C.freezeBorders $ C.vBox + [ C.hBox + [ C.vLimit 3 B.vBorder + , C.str "Resize horizontally to\nmove across the label\nbelow" + , C.vLimit 3 B.vBorder + ] + , B.borderWithLabel (B.vBorder C.<+> C.str " Label " C.<+> B.vBorder) $ C.hBox + [ C.str " " + , C.vBox [B.vBorder, C.str "L\na\nb\ne\nl", C.vLimit 3 B.vBorder] + , C.str "\n\n\n Resize vertically to\n move across the label\n to the left\n\n\n\n\n" C.<=> B.hBorder + ] + ] + +-- BYOB: build your own border +byob :: Widget () +byob = C.vBox + [ C.hBox [ corner , top , corner ] + , C.vLimit 6 $ C.hBox [ B.vBorder, mid , B.vBorder] + , C.hBox [ corner , B.hBorder, corner ] + ] + where + top = B.hBorderWithLabel (C.str "BYOB") + mid = C.center (C.str "If `border` is too easy,\nyou can build it yourself") + corner = B.joinableBorder (pure False) + +ui :: Widget () +ui = C.vBox [weights, box2, byob] + +main :: IO () +main = M.simpleMain (C.joinBorders ui) diff --git a/src/Brick/BorderMap.hs b/src/Brick/BorderMap.hs new file mode 100644 --- /dev/null +++ b/src/Brick/BorderMap.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +module Brick.BorderMap + ( BorderMap + , Edges(..) + , eTopL, eBottomL, eRightL, eLeftL + , empty, emptyCoordinates, singleton + , insertH, insertV, insert + , unsafeUnion + , coordinates, bounds + , values + , lookupRow, lookupCol, lookupH, lookupV, lookup + , setCoordinates, crop, expand + , translate + ) where + +import Brick.Types.Common (Edges(..), Location(..), eTopL, eBottomL, eRightL, eLeftL, origin) +import Control.Applicative (liftA2) +import Data.IMap (IMap, Run(Run)) +import Prelude hiding (lookup) +import qualified Data.IMap as IM + +-- | Internal use only. +neighbors :: Edges a -> Edges (a, a) +neighbors (Edges vt vb vl vr) = Edges horiz horiz vert vert where + horiz = (vl, vr) + vert = (vt, vb) + +-- Invariant: corner values are present on all the edges incident on that +-- corner. Widthless or heightless rectangles replicate the IMaps exactly on +-- the two coincident edges. +-- +-- Practically speaking, this means for lookup you can look on any edge that +-- could contain the key you care about, while for insertion you must insert on +-- every edge that could contain the keys being inserted. + +-- | A @BorderMap a@ is like a @Map Location a@, except that there is a +-- rectangle, and only 'Location's on the border of this rectangle are +-- retained. The 'BorderMap' can be queried for the position and size of the +-- rectangle. There are also efficient bulk query and bulk update operations +-- for adjacent positions on the border. +data BorderMap a = BorderMap + { _coordinates :: Edges Int + , _values :: Edges (IMap a) + } deriving (Eq, Ord, Show, Functor) + +-- | Given a rectangle (specified as the coordinates of the top, left, bottom, +-- and right sides), initialize an empty 'BorderMap'. +emptyCoordinates :: Edges Int -> BorderMap a +emptyCoordinates cs = BorderMap { _coordinates = cs, _values = pure IM.empty } + +-- | An empty 'BorderMap' that only tracks the point (0,0). +empty :: BorderMap a +empty = emptyCoordinates (pure 0) + +-- | A 'BorderMap' that tracks only the given the point (and initially maps it +-- to the given value). +singleton :: Location -> a -> BorderMap a +singleton l v = translate l . insert origin v $ empty + +{-# INLINE coordinates #-} +-- | The positions of the edges of the rectangle whose border is retained in a +-- 'BorderMap'. For example, if @coordinates m = e@, then the top border +-- contains the 'Location's on row @eTop e@ and between columns @eLeft e@ to +-- @eRight e@ inclusive. +coordinates :: BorderMap a -> Edges Int +coordinates = _coordinates + +-- | A complementary way to query the edges of the rectangle whose border is +-- retained in a 'BorderMap'. For example, if @bounds m = b@, then a +-- 'Location'\'s column must be between @fst (eTop b)@ and @snd (eTop b)@ to be +-- retained. See also 'coordinates', which is in most cases a more natural +-- border query. +bounds :: BorderMap a -> Edges (Int, Int) +bounds = neighbors . coordinates + +{-# INLINE values #-} +-- | Maps giving the values along each edge. Corner values are replicated in +-- all relevant edges. +values :: BorderMap a -> Edges (IMap a) +values = _values + +-- | Bulk insertion of horizontally-adjacent values. The 'Location' gives the +-- start point, and the 'Run' extends in the "larger columns" direction. +insertH :: Location -> Run a -> BorderMap a -> BorderMap a +insertH = insertDirAgnostic (Edges insertPar insertPar insertPerp insertPerp) . swapLoc + where + swapLoc (Location (col, row)) = Location (row, col) + +-- | Bulk insertion of vertically-adjacent values. The 'Location' gives the +-- start point, and the 'Run' extends in the "larger rows" direction. +insertV :: Location -> Run a -> BorderMap a -> BorderMap a +insertV = insertDirAgnostic (Edges insertPerp insertPerp insertPar insertPar) + +insertDirAgnostic + :: Edges (Location -> Run a -> Int -> (Int, Int) -> IMap a -> IMap a) + -> Location -> Run a -> BorderMap a -> BorderMap a +insertDirAgnostic insertions l r m = + m { _values = insertions <*> pure l <*> pure r <*> coordinates m <*> bounds m <*> _values m } + +insertPar, insertPerp :: Location -> Run a -> Int -> (Int, Int) -> IMap a -> IMap a +insertPar (Location (kPar, kPerp)) r herePar (loPerp, hiPerp) + | kPar == herePar && loPerp <= kPerp + IM.len r - 1 && kPerp <= hiPerp + = IM.insert beg r { IM.len = end - beg + 1 } + | otherwise = id + where + beg = max kPerp loPerp + end = min (kPerp + IM.len r - 1) hiPerp +insertPerp (Location (kPar, kPerp)) r herePerp (loPar, hiPar) + | loPar <= kPar && kPar <= hiPar && kPerp <= herePerp && herePerp <= kPerp + IM.len r - 1 + = IM.insert kPar r { IM.len = 1 } + | otherwise = id + +-- | Insert a single value at the given location. +insert :: Location -> a -> BorderMap a -> BorderMap a +insert l = insertV l . Run 1 + +-- | Look up all values on a given row. The 'IMap' returned maps columns to +-- values. +lookupRow :: Int -> BorderMap a -> IMap a +lookupRow row m + | row == eTop (coordinates m) = eTop (_values m) + | row == eBottom (coordinates m) = eBottom (_values m) + | otherwise = IM.fromList + $ [(eLeft (coordinates m), Run 1 a) | Just a <- [IM.lookup row (eLeft (_values m))]] + ++ [(eRight (coordinates m), Run 1 a) | Just a <- [IM.lookup row (eRight (_values m))]] + +-- | Look up all values on a given column. The 'IMap' returned maps rows to +-- values. +lookupCol :: Int -> BorderMap a -> IMap a +lookupCol col m + | col == eLeft (coordinates m) = eLeft (_values m) + | col == eRight (coordinates m) = eRight (_values m) + | otherwise = IM.fromList + $ [(eTop (coordinates m), Run 1 a) | Just a <- [IM.lookup col (eTop (_values m))]] + ++ [(eBottom (coordinates m), Run 1 a) | Just a <- [IM.lookup col (eBottom (_values m))]] + +-- | Bulk lookup of horizontally-adjacent values. The 'Location' gives the +-- starting point, and the 'Run' extends in the "larger columns" direction. The +-- 'IMap' returned maps columns to values. +lookupH :: Location -> Run ignored -> BorderMap a -> IMap a +lookupH (Location (col, row)) r = IM.restrict col r . lookupRow row + +-- | Bulk lookup of vertically-adjacent values. The 'Location' gives the +-- starting point, and the 'Run' extends in the "larger rows" direction. The +-- 'IMap' returned maps rows to values. +lookupV :: Location -> Run ignored -> BorderMap a -> IMap a +lookupV (Location (col, row)) r = IM.restrict row r . lookupCol col + +-- | Look up a single position. +lookup :: Location -> BorderMap a -> Maybe a +lookup (Location (col, row)) = IM.lookup row . lookupCol col + +-- | Set the rectangle being tracked by this 'BorderMap', throwing away any +-- values that do not lie on this new rectangle. +setCoordinates :: Edges Int -> BorderMap a -> BorderMap a +setCoordinates coordinates' m = BorderMap + { _values = values' + , _coordinates = coordinates' + } + where + bounds' = neighbors coordinates' + values' = pure gc + <*> _coordinates m + <*> coordinates' + <*> bounds' + <*> _values m + <*> Edges { eTop = lookupRow, eBottom = lookupRow, eLeft = lookupCol, eRight = lookupCol } + gc oldPar newPar (loPerp, hiPerp) imPar lookupPerp + | oldPar == newPar = IM.restrict loPerp (Run (hiPerp-loPerp+1) ()) imPar + | otherwise = lookupPerp newPar m + +-- | Ensure that the rectangle being tracked by this 'BorderMap' extends no +-- farther than the given one. +crop :: Edges Int -> BorderMap a -> BorderMap a +crop cs m = setCoordinates (shrink <*> cs <*> coordinates m) m where + shrink = Edges + { eTop = max + , eBottom = min + , eLeft = max + , eRight = min + } + +-- | Ensure that the rectangle being tracked by this 'BorderMap' extends at +-- least as far as the given one. +expand :: Edges Int -> BorderMap a -> BorderMap a +expand cs m = setCoordinates (grow <*> cs <*> coordinates m) m where + grow = Edges + { eTop = min + , eBottom = max + , eLeft = min + , eRight = max + } + +-- | Move a 'BorderMap' by adding the given 'Location' to all keys in the map. +translate :: Location -> BorderMap a -> BorderMap a +-- fast path: do nothing for (0,0) +translate (Location (0, 0)) m = m +translate (Location (c, r)) m = BorderMap + { _coordinates = liftA2 (+) cOffsets (_coordinates m) + , _values = liftA2 IM.addToKeys vOffsets (_values m) + } + where + cOffsets = Edges { eTop = r, eBottom = r, eLeft = c, eRight = c } + vOffsets = Edges { eTop = c, eBottom = c, eLeft = r, eRight = r } + +-- | Assumes the two 'BorderMap's are tracking the same rectangles, but have +-- disjoint keys. This property is not checked. +unsafeUnion :: BorderMap a -> BorderMap a -> BorderMap a +unsafeUnion m m' = m { _values = liftA2 IM.unsafeUnion (_values m) (_values m') } diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -33,13 +33,14 @@ , getContext -- ** The rendering context - , Context(ctxAttrName, availWidth, availHeight, ctxBorderStyle, ctxAttrMap) + , Context(ctxAttrName, availWidth, availHeight, ctxBorderStyle, ctxAttrMap, ctxDynBorders) , attrL , availWidthL , availHeightL , ctxAttrMapL , ctxAttrNameL , ctxBorderStyleL + , ctxDynBordersL -- ** Rendering results , Result(..) @@ -60,6 +61,15 @@ -- * Making lenses , suffixLenses + + -- * Dynamic borders + , bordersL + , DynBorder(..) + , dbStyleL, dbAttrL, dbSegmentsL + , BorderSegment(..) + , bsAcceptL, bsOfferL, bsDrawL + , Edges(..) + , eTopL, eBottomL, eRightL, eLeftL -- * Miscellaneous , Size(..) diff --git a/src/Brick/Types/Common.hs b/src/Brick/Types/Common.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Types/Common.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module Brick.Types.Common + ( Location(..) + , locL + , origin + , Edges(..) + , eTopL, eBottomL, eRightL, eLeftL + ) where + +import Brick.Types.TH (suffixLenses) +import qualified Data.Semigroup as Sem +import Lens.Micro (_1, _2) +import Lens.Micro.Internal (Field1, Field2) + +-- | A terminal screen location. +data Location = Location { loc :: (Int, Int) + -- ^ (Column, Row) + } + deriving (Show, Eq, Ord) + +suffixLenses ''Location + +instance Field1 Location Location Int Int where + _1 = locL._1 + +instance Field2 Location Location Int Int where + _2 = locL._2 + +-- | The origin (upper-left corner). +origin :: Location +origin = Location (0, 0) + +instance Sem.Semigroup Location where + (Location (w1, h1)) <> (Location (w2, h2)) = Location (w1+w2, h1+h2) + +instance Monoid Location where + mempty = origin + mappend = (Sem.<>) + +data Edges a = Edges { eTop, eBottom, eLeft, eRight :: a } + deriving (Eq, Ord, Read, Show, Functor) + +suffixLenses ''Edges + +instance Applicative Edges where + pure a = Edges a a a a + Edges ft fb fl fr <*> Edges vt vb vl vr = + Edges (ft vt) (fb vb) (fl vl) (fr vr) + +instance Monad Edges where + Edges vt vb vl vr >>= f = Edges + (eTop (f vt)) + (eBottom (f vb)) + (eLeft (f vl)) + (eRight (f vr)) diff --git a/src/Brick/Types/Internal.hs b/src/Brick/Types/Internal.hs --- a/src/Brick/Types/Internal.hs +++ b/src/Brick/Types/Internal.hs @@ -23,6 +23,12 @@ , Next(..) , Result(..) , Extent(..) + , Edges(..) + , eTopL, eBottomL, eRightL, eLeftL + , BorderSegment(..) + , bsAcceptL, bsOfferL, bsDrawL + , DynBorder(..) + , dbStyleL, dbAttrL, dbSegmentsL , CacheInvalidateRequest(..) , BrickEvent(..) @@ -37,6 +43,7 @@ , imageL , cursorsL , extentsL + , bordersL , visibilityRequestsL , emptyResult ) @@ -48,12 +55,13 @@ import Lens.Micro (_1, _2, Lens') import Lens.Micro.TH (makeLenses) -import Lens.Micro.Internal (Field1, Field2) import qualified Data.Set as S import qualified Data.Map as M -import qualified Data.Semigroup as Sem -import Graphics.Vty (Vty, Event, Button, Modifier, DisplayRegion, Image, emptyImage) +import Graphics.Vty (Vty, Event, Button, Modifier, DisplayRegion, Image, Attr, emptyImage) +import Brick.BorderMap (BorderMap) +import qualified Brick.BorderMap as BM +import Brick.Types.Common import Brick.Types.TH import Brick.AttrMap (AttrName, AttrMap) import Brick.Widgets.Border.Style (BorderStyle) @@ -130,20 +138,6 @@ -- ^ Down/right deriving (Show, Eq) --- | A terminal screen location. -data Location = Location { loc :: (Int, Int) - -- ^ (Column, Row) - } - deriving (Show, Eq, Ord) - -suffixLenses ''Location - -instance Field1 Location Location Int Int where - _1 = locL._1 - -instance Field2 Location Location Int Int where - _2 = locL._2 - -- | The class of types that behave like terminal locations. class TerminalLocation a where -- | Get the column out of the value @@ -160,17 +154,6 @@ locationRowL = _2 locationRow (Location t) = snd t --- | The origin (upper-left corner). -origin :: Location -origin = Location (0, 0) - -instance Sem.Semigroup Location where - (Location (w1, h1)) <> (Location (w2, h2)) = Location (w1+w2, h1+h2) - -instance Monoid Location where - mempty = origin - mappend = (Sem.<>) - -- | A cursor location. These are returned by the rendering process. data CursorLocation n = CursorLocation { cursorLocation :: !Location @@ -180,6 +163,36 @@ } deriving Show +-- | A border character has four segments, one extending in each direction +-- (horizontally and vertically) from the center of the character. +data BorderSegment = BorderSegment + { bsAccept :: Bool + -- ^ Would this segment be willing to be drawn if a neighbor wanted to + -- connect to it? + , bsOffer :: Bool + -- ^ Does this segment want to connect to its neighbor? + , bsDraw :: Bool + -- ^ Should this segment be represented visually? + } deriving (Eq, Ord, Read, Show) + +suffixLenses ''BorderSegment + +-- | Information about how to redraw a dynamic border character when it abuts +-- another dynamic border character. +data DynBorder = DynBorder + { dbStyle :: BorderStyle + -- ^ The 'Char's to use when redrawing the border. Also used to filter + -- connections: only dynamic borders with equal 'BorderStyle's will connect + -- to each other. + , dbAttr :: Attr + -- ^ What 'Attr' to use to redraw the border character. Also used to filter + -- connections: only dynamic borders with equal 'Attr's will connect to + -- each other. + , dbSegments :: Edges BorderSegment + } deriving (Eq, Read, Show) + +suffixLenses ''DynBorder + -- | The type of result returned by a widget's rendering function. The -- result provides the image, cursor positions, and visibility requests -- that resulted from the rendering process. @@ -193,13 +206,28 @@ -- ^ The list of visibility requests made by widgets rendered -- while rendering this one (used by viewports) , extents :: [Extent n] + -- Programmer's note: we don't try to maintain the invariant that + -- the size of the borders closely matches the size of the 'image' + -- field. Most widgets don't need to care about borders, and so they + -- use the empty 'BorderMap' that has a degenerate rectangle. Only + -- border-drawing widgets and the hbox/vbox stuff try to set this + -- carefully. Even then, in the boxes, we only make sure that the + -- 'BorderMap' is no larger than the entire concatenation of boxes, + -- and it's certainly possible for it to be smaller. (Resizing + -- 'BorderMap's is lossy, so we try to do it as little as possible.) + -- If you're writing a widget, this should make it easier for you to + -- do so; but beware this lack of invariant if you are consuming + -- widgets. + , borders :: BorderMap DynBorder + -- ^ Places where we may rewrite the edge of the image when + -- placing this widget next to another one. } deriving Show suffixLenses ''Result emptyResult :: Result n -emptyResult = Result emptyImage [] [] [] +emptyResult = Result emptyImage [] [] [] BM.empty -- | The type of events. data BrickEvent n e = VtyEvent Event @@ -234,6 +262,7 @@ , availHeight :: Int , ctxBorderStyle :: BorderStyle , ctxAttrMap :: AttrMap + , ctxDynBorders :: Bool } deriving Show diff --git a/src/Brick/Widgets/Border.hs b/src/Brick/Widgets/Border.hs --- a/src/Brick/Widgets/Border.hs +++ b/src/Brick/Widgets/Border.hs @@ -20,6 +20,9 @@ -- * Attribute names , borderAttr + + -- * Utility + , joinableBorder ) where @@ -27,14 +30,16 @@ import Control.Applicative ((<$>)) #endif -import Lens.Micro ((^.), to) +import Lens.Micro ((^.), (&), (.~), to) import Graphics.Vty (imageHeight, imageWidth) import Brick.AttrMap import Brick.Types import Brick.Widgets.Core -import Brick.Widgets.Center (hCenterWith) import Brick.Widgets.Border.Style (BorderStyle(..)) +import Brick.Widgets.Internal (renderDynBorder) +import Data.IMap (Run(..)) +import qualified Brick.BorderMap as BM -- | The top-level border attribute name. borderAttr :: AttrName @@ -42,6 +47,10 @@ -- | Draw the specified border element using the active border style -- using 'borderAttr'. +-- +-- Does not participate in dynamic borders (due to the difficulty of +-- introspecting on the first argument); consider using 'joinableBorder' +-- instead. borderElem :: (BorderStyle -> Char) -> Widget n borderElem f = Widget Fixed Fixed $ do @@ -77,8 +86,12 @@ $ vLimit (c^.availHeightL - 2) $ wrapped - let top = (borderElem bsCornerTL) <+> hBorder_ label <+> (borderElem bsCornerTR) - bottom = (borderElem bsCornerBL) <+> hBorder <+> (borderElem bsCornerBR) + 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) + top = tl <+> maybe hBorder hBorderWithLabel label <+> tr + bottom = bl <+> hBorder <+> br middle = vBorder <+> (Widget Fixed Fixed $ return middleResult) <+> vBorder total = top <=> middle <=> bottom @@ -88,25 +101,70 @@ -- | A horizontal border. Fills all horizontal space. hBorder :: Widget n -hBorder = hBorder_ Nothing +hBorder = + withAttr borderAttr $ Widget Greedy Fixed $ do + ctx <- getContext + let bs = ctxBorderStyle ctx + w = availWidth ctx + db <- dynBorderFromDirections (Edges False False True True) + let dynBorders = BM.insertH mempty (Run w db) + $ BM.emptyCoordinates (Edges 0 0 0 (w-1)) + setDynBorders dynBorders $ render $ vLimit 1 $ fill (bsHorizontal bs) -- | A horizontal border with a label placed in the center of the -- border. Fills all horizontal space. hBorderWithLabel :: Widget n -- ^ The label widget -> Widget n -hBorderWithLabel label = hBorder_ (Just label) - -hBorder_ :: Maybe (Widget n) -> Widget n -hBorder_ label = +hBorderWithLabel label = Widget Greedy Fixed $ do - bs <- ctxBorderStyle <$> getContext - let msg = maybe (str [bsHorizontal bs]) id label - render $ vLimit 1 $ withAttr borderAttr $ hCenterWith (Just $ bsHorizontal bs) msg + res <- render $ vLimit 1 label + render $ hBox [hBorder, Widget Fixed Fixed (return res), hBorder] -- | A vertical border. Fills all vertical space. vBorder :: Widget n vBorder = - Widget Fixed Greedy $ do - bs <- ctxBorderStyle <$> getContext - render $ hLimit 1 $ withAttr borderAttr $ fill (bsVertical bs) + withAttr borderAttr $ Widget Fixed Greedy $ do + ctx <- getContext + let bs = ctxBorderStyle ctx + h = availHeight ctx + db <- dynBorderFromDirections (Edges True True False False) + let dynBorders = BM.insertV mempty (Run h db) + $ BM.emptyCoordinates (Edges 0 (h-1) 0 0) + setDynBorders dynBorders $ render $ hLimit 1 $ fill (bsVertical bs) + +-- | Initialize a 'DynBorder'. It will be 'bsDraw'n and 'bsOffer'ing +-- in the given directions to begin with, and accept join offers from +-- all directions. We consult the context to choose the 'dbStyle' and +-- 'dbAttr'. +-- +-- This is likely to be useful only for custom widgets that need more +-- complicated dynamic border behavior than 'border', 'vBorder', or +-- 'hBorder' offer. +dynBorderFromDirections :: Edges Bool -> RenderM n DynBorder +dynBorderFromDirections dirs = do + ctx <- getContext + return DynBorder + { dbStyle = ctxBorderStyle ctx + , dbAttr = attrMapLookup (ctxAttrName ctx) (ctxAttrMap ctx) + , dbSegments = (\draw -> BorderSegment True draw draw) <$> dirs + } + +-- | Replace the 'Result'\'s dynamic borders with the given one, +-- provided the context says to use dynamic borders at all. +setDynBorders :: BM.BorderMap DynBorder -> RenderM n (Result n) -> RenderM n (Result n) +setDynBorders newBorders act = do + dyn <- ctxDynBorders <$> getContext + res <- act + return $ if dyn + then res & bordersL .~ newBorders + else res + +-- | A single-character dynamic border that will react to neighboring +-- borders, initially connecting in the given directions. +joinableBorder :: Edges Bool -> Widget n +joinableBorder dirs = withAttr borderAttr . Widget Fixed Fixed $ do + db <- dynBorderFromDirections dirs + setDynBorders + (BM.singleton mempty db) + (render (raw (renderDynBorder db))) diff --git a/src/Brick/Widgets/Core.hs b/src/Brick/Widgets/Core.hs --- a/src/Brick/Widgets/Core.hs +++ b/src/Brick/Widgets/Core.hs @@ -3,6 +3,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} -- | This module provides the core widget combinators and rendering -- routines. Everything this library does is in terms of these basic -- primitives. @@ -50,6 +51,9 @@ -- * Border style management , withBorderStyle + , joinBorders + , separateBorders + , freezeBorders -- * Cursor placement , showCursor @@ -103,6 +107,7 @@ import qualified Data.DList as DL import qualified Data.Map as M import qualified Data.Set as S +import qualified Data.IMap as I import qualified Data.Function as DF import Data.List (sortBy, partition) import qualified Graphics.Vty as V @@ -116,6 +121,7 @@ import Brick.Util (clOffset, clamp) import Brick.AttrMap import Brick.Widgets.Internal +import qualified Brick.BorderMap as BM -- | The class of text types that have widths measured in terminal -- columns. NEVER use 'length' etc. to measure the length of a string if @@ -140,6 +146,29 @@ withBorderStyle :: BorderStyle -> Widget n -> Widget n withBorderStyle bs p = Widget (hSize p) (vSize p) $ withReaderT (& ctxBorderStyleL .~ bs) (render p) +-- | When rendering the specified widget, create borders that respond +-- dynamically to their neighbors to form seamless connections. +joinBorders :: Widget n -> Widget n +joinBorders p = Widget (hSize p) (vSize p) $ withReaderT (& ctxDynBordersL .~ True) (render p) + +-- | When rendering the specified widget, use static borders. This +-- may be marginally faster, but will introduce a small gap between +-- neighboring orthogonal borders. +-- +-- This is the default for backwards compatibility. +separateBorders :: Widget n -> Widget n +separateBorders p = Widget (hSize p) (vSize p) $ withReaderT (&ctxDynBordersL .~ False) (render p) + +-- | After the specified widget has been rendered, freeze its borders. A +-- frozen border will not be affected by neighbors, nor will it affect +-- neighbors. Compared to 'separateBorders', 'freezeBorders' will not +-- affect whether borders connect internally to a widget (whereas +-- 'separateBorders' prevents them from connecting). +-- +-- Frozen borders cannot be thawed. +freezeBorders :: Widget n -> Widget n +freezeBorders p = Widget (hSize p) (vSize p) $ (bordersL .~ BM.empty) <$> render p + -- | The empty widget. emptyWidget :: Widget n emptyWidget = raw V.emptyImage @@ -156,7 +185,8 @@ addResultOffset :: Location -> Result n -> Result n addResultOffset off = addCursorOffset off . addVisibilityOffset off . - addExtentOffset off + addExtentOffset off . + addDynBorderOffset off addVisibilityOffset :: Location -> Result n -> Result n addVisibilityOffset off r = r & visibilityRequestsL.each.vrPositionL %~ (off <>) @@ -164,6 +194,9 @@ addExtentOffset :: Location -> Result n -> Result n addExtentOffset off r = r & extentsL.each %~ (\(Extent n l sz o) -> Extent n (off <> l) sz o) +addDynBorderOffset :: Location -> Result n -> Result n +addDynBorderOffset off r = r & bordersL %~ BM.translate off + -- | Render the specified widget and record its rendering extent using -- the specified name (see also 'lookupExtent'). reportExtent :: n -> Widget n -> Widget n @@ -412,8 +445,20 @@ , limitSecondary :: Int -> Widget n -> Widget n , primaryWidgetSize :: Widget n -> Size , concatenatePrimary :: [V.Image] -> V.Image + , concatenateSecondary :: [V.Image] -> V.Image , locationFromOffset :: Int -> Location , padImageSecondary :: Int -> V.Image -> V.Attr -> V.Image + , loPrimary :: forall a. Lens' (Edges a) a -- lo: towards smaller coordinates in that dimension + , hiPrimary :: forall a. Lens' (Edges a) a -- hi: towards larger coordinates in that dimension + , loSecondary :: forall a. Lens' (Edges a) a + , hiSecondary :: forall a. Lens' (Edges a) a + , locationFromPrimarySecondary :: Int -> Int -> Location + , splitLoPrimary :: Int -> V.Image -> V.Image + , splitHiPrimary :: Int -> V.Image -> V.Image + , splitLoSecondary :: Int -> V.Image -> V.Image + , splitHiSecondary :: Int -> V.Image -> V.Image + , lookupPrimary :: Int -> BM.BorderMap DynBorder -> I.IMap DynBorder + , insertSecondary :: Location -> I.Run DynBorder -> BM.BorderMap DynBorder -> BM.BorderMap DynBorder } vBoxRenderer :: BoxRenderer n @@ -426,10 +471,22 @@ , limitSecondary = hLimit , primaryWidgetSize = vSize , concatenatePrimary = V.vertCat + , concatenateSecondary = V.horizCat , locationFromOffset = Location . (0 ,) , padImageSecondary = \amt img a -> let p = V.charFill a ' ' amt (V.imageHeight img) in V.horizCat [img, p] + , loPrimary = eTopL + , hiPrimary = eBottomL + , loSecondary = eLeftL + , hiSecondary = eRightL + , locationFromPrimarySecondary = \r c -> Location (c, r) + , splitLoPrimary = V.cropBottom + , splitHiPrimary = \n img -> V.cropTop (V.imageHeight img-n) img + , splitLoSecondary = V.cropRight + , splitHiSecondary = \n img -> V.cropLeft (V.imageWidth img-n) img + , lookupPrimary = BM.lookupRow + , insertSecondary = BM.insertH } hBoxRenderer :: BoxRenderer n @@ -442,10 +499,22 @@ , limitSecondary = vLimit , primaryWidgetSize = hSize , concatenatePrimary = V.horizCat + , concatenateSecondary = V.vertCat , locationFromOffset = Location . (, 0) , padImageSecondary = \amt img a -> let p = V.charFill a ' ' (V.imageWidth img) amt in V.vertCat [img, p] + , loPrimary = eLeftL + , hiPrimary = eRightL + , loSecondary = eTopL + , hiSecondary = eBottomL + , locationFromPrimarySecondary = \c r -> Location (c, r) + , splitLoPrimary = V.cropRight + , splitHiPrimary = \n img -> V.cropLeft (V.imageWidth img-n) img + , splitLoSecondary = V.cropBottom + , splitHiSecondary = \n img -> V.cropTop (V.imageHeight img-n) img + , lookupPrimary = BM.lookupCol + , insertSecondary = BM.insertV } -- | Render a series of widgets in a box layout in the order given. @@ -551,12 +620,129 @@ maxSecondary = maximum $ imageSecondary br <$> allImages padImage img = padImageSecondary br (maxSecondary - imageSecondary br img) img (c^.attrL) - paddedImages = padImage <$> allImages + (imageRewrites, newBorders) = catAllBorders br (borders <$> allTranslatedResults) + rewrittenImages = zipWith (rewriteImage br) imageRewrites allImages + paddedImages = padImage <$> rewrittenImages cropResultToContext $ Result (concatenatePrimary br paddedImages) (concat $ cursors <$> allTranslatedResults) (concat $ visibilityRequests <$> allTranslatedResults) (concat $ extents <$> allTranslatedResults) + newBorders + +catDynBorder + :: Lens' (Edges BorderSegment) BorderSegment + -> Lens' (Edges BorderSegment) BorderSegment + -> DynBorder + -> DynBorder + -> Maybe DynBorder +catDynBorder towardsA towardsB a b + -- Currently, we check if the 'BorderStyle's are exactly the same. In the + -- future, it might be nice to relax this restriction. For example, if a + -- horizontal border is being rewritten to accomodate a neighboring + -- vertical border, all we care about is that the two 'bsVertical's line up + -- sanely. After all, if the horizontal border's 'bsVertical' is the same + -- as the vertical one's, and the horizontal border's 'BorderStyle' is + -- self-consistent, then it will look "right" to rewrite according to the + -- horizontal border's 'BorderStyle'. + | dbStyle a == dbStyle b + && dbAttr a == dbAttr b + && a ^. dbSegmentsL.towardsB.bsAcceptL + && b ^. dbSegmentsL.towardsA.bsOfferL + && not (a ^. dbSegmentsL.towardsB.bsDrawL) -- don't bother doing an update if we don't need to + = Just (a & dbSegmentsL.towardsB.bsDrawL .~ True) + | otherwise = Nothing + +catDynBorders + :: Lens' (Edges BorderSegment) BorderSegment + -> Lens' (Edges BorderSegment) BorderSegment + -> I.IMap DynBorder + -> I.IMap DynBorder + -> I.IMap DynBorder +catDynBorders towardsA towardsB am bm = I.mapMaybe id + $ I.intersectionWith (catDynBorder towardsA towardsB) am bm + +-- | Given borders that should be placed next to each other (the first argument +-- on the right or bottom, and the second argument on the left or top), compute +-- new borders and the rewrites that should be done along the edges of the two +-- images to keep the image in synch with the border information. +-- +-- The input borders are assumed to be disjoint. This property is not checked. +catBorders + :: (border ~ BM.BorderMap DynBorder, rewrite ~ I.IMap V.Image) + => BoxRenderer n -> border -> border -> ((rewrite, rewrite), border) +catBorders br r l = if lCoord + 1 == rCoord + then ((lRe, rRe), lr') + else ((I.empty, I.empty), lr) + where + lr = BM.expand (BM.coordinates r) l `BM.unsafeUnion` + BM.expand (BM.coordinates l) r + lr' = id + . mergeIMap lCoord lIMap' + . mergeIMap rCoord rIMap' + $ lr + lCoord = BM.coordinates l ^. hiPrimary br + rCoord = BM.coordinates r ^. loPrimary br + lIMap = lookupPrimary br lCoord l + rIMap = lookupPrimary br rCoord r + lIMap' = catDynBorders (loPrimary br) (hiPrimary br) lIMap rIMap + rIMap' = catDynBorders (hiPrimary br) (loPrimary br) rIMap lIMap + lRe = renderDynBorder <$> lIMap' + rRe = renderDynBorder <$> rIMap' + mergeIMap p imap bm = F.foldl' + (\bm' (s,v) -> insertSecondary br (locationFromPrimarySecondary br p s) v bm') + bm + (I.unsafeToAscList imap) + +-- | Given a direction to concatenate borders in, and the border information +-- itself (which list is assumed to be already shifted so that borders do not +-- overlap and are strictly increasing in the primary direction), produce: a +-- list of rewrites for the lo and hi directions of each border, respectively, +-- and the borders describing the fully concatenated object. +catAllBorders :: + BoxRenderer n -> + [BM.BorderMap DynBorder] -> + ([(I.IMap V.Image, I.IMap V.Image)], BM.BorderMap DynBorder) +catAllBorders _ [] = ([], BM.empty) +catAllBorders br (bm:bms) = (zip ([I.empty]++los) (his++[I.empty]), bm') where + (rewrites, bm') = runState (traverse (state . catBorders br) bms) bm + (his, los) = unzip rewrites + +rewriteEdge :: + (Int -> V.Image -> V.Image) -> + (Int -> V.Image -> V.Image) -> + ([V.Image] -> V.Image) -> + I.IMap V.Image -> V.Image -> V.Image +rewriteEdge splitLo splitHi combine = (combine .) . go . offsets 0 . I.unsafeToAscList where + + -- convert absolute positions into relative ones + offsets _ [] = [] + offsets n ((n', r):nrs) = (n'-n, r) : offsets (n'+I.len r) nrs + + go [] old = [old] + -- TODO: might be nice to construct this image with fill rather than + -- replicate+char + go ((lo, I.Run len new):nrs) old + = [splitLo lo old] + ++ replicate len new + ++ go nrs (splitHi (lo+len) old) + +rewriteImage :: BoxRenderer n -> (I.IMap V.Image, I.IMap V.Image) -> V.Image -> V.Image +rewriteImage br (loRewrite, hiRewrite) old = rewriteHi . rewriteLo $ old where + size = imagePrimary br old + go = rewriteEdge (splitLoSecondary br) (splitHiSecondary br) (concatenateSecondary br) + rewriteLo img + | I.null loRewrite = img + | otherwise = concatenatePrimary br + [ go loRewrite (splitLoPrimary br 1 img) + , splitHiPrimary br 1 img + ] + rewriteHi img + | I.null hiRewrite = img + | otherwise = concatenatePrimary br + [ splitLoPrimary br (size-1) img + , go hiRewrite (splitHiPrimary br (size-1) img) + ] -- | Limit the space available to the specified widget to the specified -- number of columns. This is important for constraining the horizontal 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 @@ -3,6 +3,7 @@ ( renderFinal , cropToContext , cropResultToContext + , renderDynBorder ) where @@ -20,6 +21,8 @@ import Brick.Types.Internal import Brick.AttrMap import Brick.Widgets.Border.Style +import Brick.BorderMap (BorderMap, Edges(..)) +import qualified Brick.BorderMap as BM renderFinal :: AttrMap -> [Widget n] @@ -32,7 +35,7 @@ (layerResults, !newRS) = flip runState rs $ sequence $ (\p -> runReaderT p ctx) <$> (render <$> cropToContext <$> layerRenders) - ctx = Context mempty (fst sz) (snd sz) defaultBorderStyle aMap + ctx = Context mempty (fst sz) (snd sz) defaultBorderStyle aMap False pic = V.picForLayers $ uncurry V.resize sz <$> (^.imageL) <$> layerResults -- picWithBg is a workaround for runaway attributes. -- See https://github.com/coreyoconnor/vty/issues/95 @@ -53,6 +56,7 @@ return $ result & imageL %~ cropImage c & cursorsL %~ cropCursors c & extentsL %~ cropExtents c + & bordersL %~ cropBorders c cropImage :: Context -> V.Image -> V.Image cropImage c = V.crop (max 0 $ c^.availWidthL) (max 0 $ c^.availHeightL) @@ -105,3 +109,27 @@ in if w' < 0 || h' < 0 then Nothing else Just e + +cropBorders :: Context -> BorderMap DynBorder -> BorderMap DynBorder +cropBorders ctx = BM.crop Edges + { eTop = 0 + , eBottom = availHeight ctx - 1 + , eLeft = 0 + , eRight = availWidth ctx - 1 + } + +renderDynBorder :: DynBorder -> V.Image +renderDynBorder db = V.char (dbAttr db) . ($dbStyle db) $ case bsDraw <$> dbSegments db of + -- top bot left right + Edges False False False False -> const ' ' -- dunno lol (but should never happen, so who cares) + Edges False False _ _ -> bsHorizontal + Edges _ _ False False -> bsVertical + Edges False True False True -> bsCornerTL + Edges False True True False -> bsCornerTR + Edges True False False True -> bsCornerBL + Edges True False True False -> bsCornerBR + Edges False True True True -> bsIntersectT + Edges True False True True -> bsIntersectB + Edges True True False True -> bsIntersectL + Edges True True True False -> bsIntersectR + Edges True True True True -> bsIntersectFull diff --git a/src/Brick/Widgets/List.hs b/src/Brick/Widgets/List.hs --- a/src/Brick/Widgets/List.hs +++ b/src/Brick/Widgets/List.hs @@ -127,8 +127,8 @@ EvKey (KChar 'G') [] -> return $ listMoveTo (V.length $ listElements theList) theList EvKey (KChar 'f') [MCtrl] -> listMovePageDown theList EvKey (KChar 'b') [MCtrl] -> listMovePageUp theList - EvKey (KChar 'd') [MCtrl] -> listMoveByPages 0.5 theList - EvKey (KChar 'u') [MCtrl] -> listMoveByPages (-0.5) theList + EvKey (KChar 'd') [MCtrl] -> listMoveByPages (0.5::Double) theList + EvKey (KChar 'u') [MCtrl] -> listMoveByPages (-0.5::Double) theList _ -> fallback e theList -- | The top-level attribute used for the entire list. @@ -274,7 +274,7 @@ -- | Move the list selected index up by one page. listMovePageUp :: (Ord n) => List n e -> EventM n (List n e) -listMovePageUp theList = listMoveByPages (-1) theList +listMovePageUp theList = listMoveByPages (-1::Double) theList -- | Move the list selected index down by one. (Moves the cursor down, -- adds one to the index.) @@ -283,7 +283,7 @@ -- | Move the list selected index down by one page. listMovePageDown :: (Ord n) => List n e -> EventM n (List n e) -listMovePageDown theList = listMoveByPages 1 theList +listMovePageDown theList = listMoveByPages (1::Double) theList -- | Move the list selected index by some (fractional) number of pages. listMoveByPages :: (Ord n, RealFrac m) => m -> List n e -> EventM n (List n e) diff --git a/src/Data/IMap.hs b/src/Data/IMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/IMap.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE DeriveFunctor #-} +module Data.IMap + ( IMap + , Run(..) + , empty + , Data.IMap.null + , singleton + , insert + , delete + , restrict + , lookup + , splitLE + , intersectionWith + , mapMaybe + , addToKeys + , unsafeUnion + , fromList + , unsafeRuns + , unsafeToAscList + ) where + +import Data.List (foldl') +import Data.Monoid +import Data.IntMap.Strict (IntMap) +import Prelude hiding (lookup) +import qualified Data.IntMap.Strict as IM + +-- | Semantically, 'IMap' and 'IntMap' are identical; but 'IMap' is more +-- efficient when large sequences of contiguous keys are mapped to the same +-- value. +newtype IMap a = IMap { _runs :: IntMap (Run a) } deriving (Show, Functor) + +{-# INLINE unsafeRuns #-} +-- | This function is unsafe because 'IMap's that compare equal may split their +-- runs into different chunks; consumers must promise that they do not treat +-- run boundaries specially. +unsafeRuns :: IMap a -> IntMap (Run a) +unsafeRuns = _runs + +instance Eq a => Eq (IMap a) where + IMap m == IMap m' = go (IM.toAscList m) (IM.toAscList m') where + go ((k, Run n a):kvs) ((k', Run n' a'):kvs') + = k == k' && a == a' && case compare n n' of + LT -> go kvs ((k'+n, Run (n'-n) a'):kvs') + EQ -> go kvs kvs' + GT -> go ((k+n', Run (n-n') a):kvs) kvs' + go [] [] = True + go _ _ = False + +instance Ord a => Ord (IMap a) where + compare (IMap m) (IMap m') = go (IM.toAscList m) (IM.toAscList m') where + go [] [] = EQ + go [] _ = LT + go _ [] = GT + go ((k, Run n a):kvs) ((k', Run n' a'):kvs') + = compare k k' <> compare a a' <> case compare n n' of + LT -> go kvs ((k'+n, Run (n'-n) a'):kvs') + EQ -> go kvs kvs' + GT -> go ((k+n', Run (n-n') a):kvs) kvs' + +-- | Zippy: '(<*>)' combines values at equal keys, discarding any values whose +-- key is in only one of its two arguments. +instance Applicative IMap where + pure a = IMap . IM.fromDistinctAscList $ + [ (minBound, Run maxBound a) + , (-1, Run maxBound a) + , (maxBound-1, Run 2 a) + ] + (<*>) = intersectionWith ($) + +-- | @Run n a@ represents @n@ copies of the value @a@. +data Run a = Run + { len :: !Int + , val :: !a + } deriving (Eq, Ord, Read, Show, Functor) + +instance Foldable Run where foldMap f r = f (val r) +instance Traversable Run where sequenceA (Run n v) = Run n <$> v + +empty :: IMap a +empty = IMap IM.empty + +null :: IMap a -> Bool +null = IM.null . _runs + +singleton :: Int -> Run a -> IMap a +singleton k r + | len r >= 1 = IMap (IM.singleton k r) + | otherwise = empty + +insert :: Int -> Run a -> IMap a -> IMap a +insert k r m + | len r < 1 = m + | otherwise = m { _runs = IM.insert k r (_runs (delete k r m)) } + +{-# INLINE delete #-} +delete :: Int -> Run ignored -> IMap a -> IMap a +delete k r m + | len r < 1 = m + | otherwise = m { _runs = IM.union (_runs lt) (_runs gt) } + where + (lt, ge) = splitLE (k-1) m + (_ , gt) = splitLE (k+len r-1) ge + +-- | Given a range of keys (as specified by a starting key and a length for +-- consistency with other functions in this module), restrict the map to keys +-- in that range. @restrict k r m@ is equivalent to @intersectionWith const m +-- (insert k r empty)@ but potentially more efficient. +restrict :: Int -> Run ignored -> IMap a -> IMap a +restrict k r = id + . snd + . splitLE (k-1) + . fst + . splitLE (k+len r-1) + +lookup :: Int -> IMap a -> Maybe a +lookup k m = case IM.lookupLE k (_runs m) of + Just (k', Run n a) | k < k'+n -> Just a + _ -> Nothing + +-- | @splitLE n m@ produces a tuple @(le, gt)@ where @le@ has all the +-- associations of @m@ where the keys are @<= n@ and @gt@ has all the +-- associations of @m@ where the keys are @> n@. +splitLE :: Int -> IMap a -> (IMap a, IMap a) +splitLE k m = case IM.lookupLE k (_runs m) of + Nothing -> (empty, m) + Just (k', r@(Run n _)) -> case (k' + n - 1 <= k, k' == k) of + (True , False) -> (m { _runs = lt }, m { _runs = gt }) + (True , True ) -> (m { _runs = IM.insert k r lt }, m { _runs = gt }) + (False, _ ) -> ( m { _runs = IM.insert k' r { len = 1 + k - k' } lt' } + , m { _runs = IM.insert (k+1) r { len = n - 1 - k + k' } gt' } + ) + where + (lt', gt') = IM.split k' (_runs m) + where + (lt, gt) = IM.split k (_runs m) + +-- | Increment all keys by the given amount. This is like +-- 'IM.mapKeysMonotonic', but restricted to partially-applied addition. +addToKeys :: Int -> IMap a -> IMap a +addToKeys n m = m { _runs = IM.mapKeysMonotonic (n+) (_runs m) } + +-- TODO: This is pretty inefficient. IntMap offers some splitting functions +-- that should make it possible to be more efficient here (though the +-- implementation would be significantly messier). +intersectionWith :: (a -> b -> c) -> IMap a -> IMap b -> IMap c +intersectionWith f (IMap runsa) (IMap runsb) + = IMap . IM.fromDistinctAscList $ merge (IM.toAscList runsa) (IM.toAscList runsb) + where + merge as@((ka, ra):at) bs@((kb, rb):bt) + | ka' < kb = merge at bs + | kb' < ka = merge as bt + | otherwise = (kc, Run (kc' - kc + 1) vc) : case compare ka' kb' of + LT -> merge at bs + EQ -> merge at bt + GT -> merge as bt + where + ka' = ka + len ra - 1 + kb' = kb + len rb - 1 + kc = max ka kb + kc' = min ka' kb' + vc = f (val ra) (val rb) + merge _ _ = [] + +mapMaybe :: (a -> Maybe b) -> IMap a -> IMap b +mapMaybe f (IMap runs) = IMap (IM.mapMaybe (traverse f) runs) + +fromList :: [(Int, Run a)] -> IMap a +fromList = foldl' (\m (k, r) -> insert k r m) empty + +-- | This function is unsafe because 'IMap's that compare equal may split their +-- runs into different chunks; consumers must promise that they do not treat +-- run boundaries specially. +unsafeToAscList :: IMap a -> [(Int, Run a)] +unsafeToAscList = IM.toAscList . _runs + +-- | This function is unsafe because it assumes there is no overlap between its +-- arguments. That is, in the call @unsafeUnion a b@, the caller must guarantee +-- that if @lookup k a = Just v@ then @lookup k b = Nothing@ and vice versa. +unsafeUnion :: IMap a -> IMap a -> IMap a +unsafeUnion a b = IMap { _runs = _runs a `IM.union` _runs b } diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +import Control.Applicative +import Data.IMap (IMap, Run(Run)) +import Data.IntMap (IntMap) +import Test.QuickCheck +import qualified Data.IMap as IMap +import qualified Data.IntMap as IntMap + +instance Arbitrary v => Arbitrary (Run v) where + arbitrary = liftA2 (\(Positive n) -> Run n) arbitrary arbitrary + +instance Arbitrary v => Arbitrary (IMap v) where + arbitrary = IMap.fromList <$> arbitrary + +instance (a ~ Ordering, Show b) => Show (a -> b) where + show f = show [f x | x <- [minBound .. maxBound]] + +lower :: IMap v -> IntMap v +lower m = IntMap.fromDistinctAscList + [ (base+offset, v) + | (base, Run n v) <- IMap.unsafeToAscList m + , offset <- [0..n-1] + ] + +raise :: Eq v => IntMap v -> IMap v +raise = IMap.fromList . rle . map singletonRun . IntMap.toAscList where + singletonRun (k, v) = (k, Run 1 v) + + rle ((k, Run n v):(k', Run n' v'):kvs) + | k+n == k' && v == v' = rle ((k, Run (n+n') v):kvs) + rle (kv:kvs) = kv:rle kvs + rle [] = [] + +lowerRun :: Int -> Run v -> IntMap v +lowerRun k r = IntMap.fromAscList [(k+offset, IMap.val r) | offset <- [0..IMap.len r-1]] + +type O = Ordering +type I = IMap Ordering + +-- These next two probably have overflow bugs that QuickCheck can't reasonably +-- notice. Hopefully they don't come up in real use cases... +prop_raiseLowerFaithful :: IntMap O -> Bool +prop_raiseLowerFaithful m = m == lower (raise m) + +prop_equalityReflexive :: I -> Bool +prop_equalityReflexive m = m == raise (lower m) + +prop_equality :: I -> I -> Bool +prop_equality l r = (l == r) == (lower l == lower r) + +prop_compare :: I -> I -> Bool +prop_compare l r = compare l r == compare (lower l) (lower r) + +prop_applicativeIdentity :: I -> Bool +prop_applicativeIdentity v = (pure id <*> v) == v + +prop_applicativeComposition :: IMap (O -> O) -> IMap (O -> O) -> IMap O -> Bool +prop_applicativeComposition u v w = (pure (.) <*> u <*> v <*> w) == (u <*> (v <*> w)) + +prop_applicativeHomomorphism :: (O -> O) -> O -> Bool +prop_applicativeHomomorphism f x = (pure f <*> pure x :: I) == pure (f x) + +prop_applicativeInterchange :: IMap (O -> O) -> O -> Bool +prop_applicativeInterchange u y = (u <*> pure y) == (pure ($ y) <*> u) + +prop_empty :: Bool +prop_empty = lower (IMap.empty :: I) == IntMap.empty + +prop_singleton :: Int -> Run O -> Bool +prop_singleton k r = lower (IMap.singleton k r) == lowerRun k r + +prop_insert :: Int -> Run O -> I -> Bool +prop_insert k r m = lower (IMap.insert k r m) == IntMap.union (lowerRun k r) (lower m) + +prop_delete :: Int -> Run () -> I -> Bool +prop_delete k r m = lower (IMap.delete k r m) == lower m IntMap.\\ lowerRun k r + +prop_splitLE :: Int -> I -> Bool +prop_splitLE k m = (lower le, lower gt) == (le', gt') where + (le, gt) = IMap.splitLE k m + (lt, eq, gt') = IntMap.splitLookup k (lower m) + le' = maybe id (IntMap.insert k) eq lt + +prop_intersectionWith :: (O -> O -> O) -> I -> I -> Bool +prop_intersectionWith f l r = lower (IMap.intersectionWith f l r) == IntMap.intersectionWith f (lower l) (lower r) + +prop_addToKeys :: Int -> I -> Bool +prop_addToKeys n m = lower (IMap.addToKeys n m) == IntMap.mapKeysMonotonic (n+) (lower m) + +prop_lookup :: Int -> I -> Bool +prop_lookup k m = IMap.lookup k m == IntMap.lookup k (lower m) + +prop_restrict :: Int -> Run () -> I -> Bool +prop_restrict k r m = lower (IMap.restrict k r m) == IntMap.intersection (lower m) (lowerRun k r) + +prop_mapMaybe :: (O -> Maybe O) -> I -> Bool +prop_mapMaybe f m = lower (IMap.mapMaybe f m) == IntMap.mapMaybe f (lower m) + +prop_null :: I -> Bool +prop_null m = IMap.null m == IntMap.null (lower m) + +return [] + +main :: IO Bool +main = $quickCheckAll