From 5dd5bc4100b1c6bbcba6c2c68198b1f2a0aa4013 Mon Sep 17 00:00:00 2001 From: Daniel Wagner Date: Sun, 18 Mar 2018 11:24:52 -0400 Subject: [PATCH] add a way to join neighboring borders --- brick.cabal | 26 ++++ programs/DynamicBorderDemo.hs | 71 ++++++++++ src/Brick/Types.hs | 12 +- src/Brick/Types/Internal.hs | 86 ++++++++---- src/Brick/Widgets/Border.hs | 86 ++++++++++-- src/Brick/Widgets/Core.hs | 190 +++++++++++++++++++++++++- src/Brick/Widgets/Internal.hs | 30 ++++- src/Data/BorderMap.hs | 245 ++++++++++++++++++++++++++++++++++ src/Data/IMap.hs | 175 ++++++++++++++++++++++++ tests/Main.hs | 109 +++++++++++++++ 10 files changed, 983 insertions(+), 47 deletions(-) create mode 100644 programs/DynamicBorderDemo.hs create mode 100644 src/Data/BorderMap.hs create mode 100644 src/Data/IMap.hs create mode 100644 tests/Main.hs diff --git a/brick.cabal b/brick.cabal index 158a48a..73961ac 100644 --- a/brick.cabal +++ b/brick.cabal @@ -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 diff --git a/programs/DynamicBorderDemo.hs b/programs/DynamicBorderDemo.hs new file mode 100644 index 0000000..21d5160 --- /dev/null +++ b/programs/DynamicBorderDemo.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import qualified Brick.Main as M +import Brick.Types + ( Widget + ) +import qualified Brick.Widgets.Center as C +import qualified Brick.Widgets.Core as C +import qualified Brick.Widgets.Border as B +import qualified Brick.Widgets.Border.Style as BS + +doubleHorizontal :: BS.BorderStyle +doubleHorizontal = BS.BorderStyle + { BS.bsCornerTL = '╒' + , BS.bsCornerTR = '╕' + , BS.bsCornerBR = '╛' + , BS.bsCornerBL = '╘' + , BS.bsIntersectL = '╞' + , BS.bsIntersectR = '╡' + , BS.bsIntersectT = '╤' + , BS.bsIntersectB = '╧' + , BS.bsIntersectFull = '╪' + , BS.bsHorizontal = '═' + , BS.bsVertical = '│' + } + +box1 :: Widget () +box1 + = C.withBorderStyle doubleHorizontal . B.border + . C.withBorderStyle BS.unicodeRounded . B.border + $ C.str "25 kg" + +weights :: Widget () +weights = C.withBorderStyle doubleHorizontal $ C.hBox + [ box1 + , C.str "\n\n" C.<=> B.hBorder + , box1 + ] + +box2 :: Widget () +box2 = C.freezeBorders $ C.vBox + [ C.hBox + [ C.vLimit 3 B.vBorder + , C.str "Resize horizontally to\nmove across the label\nbelow" + , C.vLimit 3 B.vBorder + ] + , B.borderWithLabel (B.vBorder C.<+> C.str " Label " C.<+> B.vBorder) $ C.hBox + [ C.str " " + , C.vBox [B.vBorder, C.str "L\na\nb\ne\nl", C.vLimit 3 B.vBorder] + , C.str "\n\n\n Resize vertically to\n move across the label\n to the left\n\n\n\n\n" C.<=> B.hBorder + ] + ] + +-- BYOB: build your own border +byob :: Widget () +byob = C.vBox + [ C.hBox [ corner , top , corner ] + , C.vLimit 6 $ C.hBox [ B.vBorder, mid , B.vBorder] + , C.hBox [ corner , B.hBorder, corner ] + ] + where + top = B.hBorderWithLabel (C.str "BYOB") + mid = C.center (C.str "If `border` is too easy,\nyou can build it yourself") + corner = B.joinableBorder (pure False) + +ui :: Widget () +ui = C.vBox [weights, box2, byob] + +main :: IO () +main = M.simpleMain (C.joinBorders ui) diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs index 664ce1c..6b0ca17 100644 --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -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(..) diff --git a/src/Brick/Types/Internal.hs b/src/Brick/Types/Internal.hs index bb20c74..e8da32e 100644 --- a/src/Brick/Types/Internal.hs +++ b/src/Brick/Types/Internal.hs @@ -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 diff --git a/src/Brick/Widgets/Border.hs b/src/Brick/Widgets/Border.hs index d186e47..07ee518 100644 --- a/src/Brick/Widgets/Border.hs +++ b/src/Brick/Widgets/Border.hs @@ -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))) diff --git a/src/Brick/Widgets/Core.hs b/src/Brick/Widgets/Core.hs index bf8e234..42ff16d 100644 --- a/src/Brick/Widgets/Core.hs +++ b/src/Brick/Widgets/Core.hs @@ -3,6 +3,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} -- | This module provides the core widget combinators and rendering -- routines. Everything this library does is in terms of these basic -- primitives. @@ -50,6 +51,9 @@ 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 diff --git a/src/Brick/Widgets/Internal.hs b/src/Brick/Widgets/Internal.hs index 3e154f4..e0f0b25 100644 --- a/src/Brick/Widgets/Internal.hs +++ b/src/Brick/Widgets/Internal.hs @@ -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 diff --git a/src/Data/BorderMap.hs b/src/Data/BorderMap.hs new file mode 100644 index 0000000..11c2c25 --- /dev/null +++ b/src/Data/BorderMap.hs @@ -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') } diff --git a/src/Data/IMap.hs b/src/Data/IMap.hs new file mode 100644 index 0000000..c98cf83 --- /dev/null +++ b/src/Data/IMap.hs @@ -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 } diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 index 0000000..cba0010 --- /dev/null +++ b/tests/Main.hs @@ -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