brick 0.35.1 → 0.36

raw patch · 15 files changed

+1243/−58 lines, 15 filesdep +QuickCheckdep ~basedep ~microlensnew-component:exe:brick-dynamic-border-demoPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck

Dependency ranges changed: base, microlens

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• README.md +2/−3
• brick.cabal +32/−2
• docs/guide.rst +208/−1
• programs/DynamicBorderDemo.hs +71/−0
• src/Brick/BorderMap.hs +211/−0
• src/Brick/Types.hs +11/−1
• src/Brick/Types/Common.hs +58/−0
• src/Brick/Types/Internal.hs +58/−29
• src/Brick/Widgets/Border.hs +73/−15
• src/Brick/Widgets/Core.hs +188/−2
• src/Brick/Widgets/Internal.hs +29/−1
• src/Brick/Widgets/List.hs +4/−4
• src/Data/IMap.hs +181/−0
• tests/Main.hs +107/−0

@@ -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 ------ 

@@ -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 ----------------------

@@ -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

@@ -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`_.

@@ -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)

@@ -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') }

@@ -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(..)

@@ -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))

@@ -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 

@@ -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)))

@@ -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

@@ -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

@@ -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)

@@ -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 }

@@ -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