jtdaugherty/brick
1
1
Fork 0
mirror of https://github.com/jtdaugherty/brick.git synced 2024-12-28 00:12:02 +03:00
Code Issues Projects Releases Wiki Activity

add a way to join neighboring borders

Browse Source
This commit is contained in:
Daniel Wagner 2018-03-18 11:24:52 -04:00
parent aa5282b2b6
commit 5dd5bc4100
10 changed files with 983 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
brick.cabal
View File

@ -77,6 +77,8 @@ library
Brick.Widgets.Edit
Brick.Widgets.List
Brick.Widgets.ProgressBar
Data.BorderMap
Data.IMap
Data.Text.Markup
other-modules:
Brick.Types.TH
@ -392,6 +394,20 @@ executable brick-border-demo
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 +421,13 @@ executable brick-progressbar-demo
vty >= 5.18.1,
text,
microlens
test-suite brick-tests
type: exitcode-stdio-1.0
hs-source-dirs: tests
ghc-options: -Wall -Wno-orphans -O2
main-is: Main.hs
build-depends: base <=5,
brick,
containers,
QuickCheck

71
programs/DynamicBorderDemo.hs Normal file
View File

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

12
src/Brick/Types.hs
View File

@ -33,13 +33,14 @@ module Brick.Types
, 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(..)
@ -61,6 +62,15 @@ module Brick.Types
-- * Making lenses
, suffixLenses
-- * Dynamic borders
, bordersL
, DynBorder(..)
, dbStyleL, dbAttrL, dbSegmentsL
, BorderSegment(..)
, bsAcceptL, bsOfferL, bsDrawL
, Edges(..)
, eTopL, eBottomL, eRightL, eLeftL
-- * Miscellaneous
, Size(..)
, Padding(..)

86
src/Brick/Types/Internal.hs
View File

@ -23,6 +23,12 @@ module Brick.Types.Internal
, Next(..)
, Result(..)
, Extent(..)
, Edges(..)
, eTopL, eBottomL, eRightL, eLeftL
, BorderSegment(..)
, bsAcceptL, bsOfferL, bsDrawL
, DynBorder(..)
, dbStyleL, dbAttrL, dbSegmentsL
, CacheInvalidateRequest(..)
, BrickEvent(..)
@ -37,6 +43,7 @@ module Brick.Types.Internal
, imageL
, cursorsL
, extentsL
, bordersL
, visibilityRequestsL
, emptyResult
)
@ -46,13 +53,13 @@ where
import Data.Monoid
#endif
import Data.BorderMap (BorderMap, Edges(..), Location(..), locL, origin, eTopL, eBottomL, eLeftL, eRightL)
import qualified Data.BorderMap as BM
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.Types.TH
import Brick.AttrMap (AttrName, AttrMap)
@ -130,20 +137,6 @@ data Direction = Up
-- ^ 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 +153,6 @@ instance TerminalLocation Location where
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 +162,36 @@ data CursorLocation n =
}
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 +205,28 @@ data Result n =
-- ^ 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 +261,7 @@ data Context =
, availHeight :: Int
, ctxBorderStyle :: BorderStyle
, ctxAttrMap :: AttrMap
, ctxDynBorders :: Bool
}
deriving Show

86
src/Brick/Widgets/Border.hs
View File

@ -20,6 +20,9 @@ module Brick.Widgets.Border
-- * Attribute names
, borderAttr
-- * Utility
, joinableBorder
)
where
@ -27,7 +30,7 @@ where
import Control.Applicative ((<$>))
#endif
import Lens.Micro ((^.), to)
import Lens.Micro ((^.), (&), (.~), to)
import Graphics.Vty (imageHeight, imageWidth)
import Brick.AttrMap
@ -35,6 +38,9 @@ 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 Data.BorderMap as BM
-- | The top-level border attribute name.
borderAttr :: AttrName
@ -42,6 +48,10 @@ borderAttr = "border"
-- | 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 +87,12 @@ border_ label wrapped =
$ 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 +102,69 @@ border_ label wrapped =
-- | 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 BM.origin (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 BM.origin (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 BM.origin db)
(render (raw (renderDynBorder db)))

190
src/Brick/Widgets/Core.hs
View File

@ -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 @@ module Brick.Widgets.Core
-- * Border style management
, withBorderStyle
, joinBorders
, separateBorders
, freezeBorders
-- * Cursor placement
, showCursor
@ -103,6 +107,8 @@ import qualified Data.Text as T
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.BorderMap as BM
import qualified Data.Function as DF
import Data.List (sortBy, partition)
import qualified Graphics.Vty as V
@ -140,6 +146,29 @@ class Named a n where
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 @@ emptyWidget = raw V.emptyImage
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 @@ addVisibilityOffset off r = r & visibilityRequestsL.each.vrPositionL %~ (off <>)
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 @@ data BoxRenderer n =
, 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 @@ vBoxRenderer =
, 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 @@ hBoxRenderer =
, 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 @@ renderBox br ws =
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

30
src/Brick/Widgets/Internal.hs
View File

@ -3,6 +3,7 @@ module Brick.Widgets.Internal
( renderFinal
, cropToContext
, cropResultToContext
, renderDynBorder
)
where
@ -20,6 +21,8 @@ import Brick.Types
import Brick.Types.Internal
import Brick.AttrMap
import Brick.Widgets.Border.Style
import Data.BorderMap (BorderMap, Edges(..))
import qualified Data.BorderMap as BM
renderFinal :: AttrMap
-> [Widget n]
@ -32,7 +35,7 @@ renderFinal aMap layerRenders sz chooseCursor rs = (newRS, picWithBg, theCursor,
(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 @@ cropResultToContext result = do
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 @@ cropExtents ctx es = catMaybes $ cropExtent <$> es
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

245
src/Data/BorderMap.hs Normal file
View File

@ -0,0 +1,245 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.BorderMap
( BorderMap
, Location(..), origin, locL
, 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.TH (suffixLenses)
import Control.Applicative (liftA2)
import qualified Data.Semigroup as Sem
import Data.IMap (IMap, Run(Run))
import Lens.Micro (_1, _2)
import Lens.Micro.Internal (Field1, Field2)
import Prelude hiding (lookup)
import qualified Data.IMap as IM
-- | 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))
-- | 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 :: Location -> a -> BorderMap a -> BorderMap a
insert l = insertV l . Run 1
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))]]
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))]]
lookupH :: Location -> Run ignored -> BorderMap a -> IMap a
lookupH (Location (col, row)) r = IM.restrict col r . lookupRow row
lookupV :: Location -> Run ignored -> BorderMap a -> IMap a
lookupV (Location (col, row)) r = IM.restrict row r . lookupCol col
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') }

175
src/Data/IMap.hs Normal file
View File

@ -0,0 +1,175 @@
{-# 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
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)
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: 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 }

109
tests/Main.hs Normal file
View File

@ -0,0 +1,109 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# 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 -> Int -> I -> Bool
prop_restrict k len m = lower (IMap.restrict k (Run len ()) m) == restrict (lower m) where
restrict = fst . IntMap.split (k+len) . snd . IntMap.split (k-1)
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