brick 0.9 → 0.10

raw patch · 9 files changed

+303/−62 lines, 9 filesdep ~microlensnew-component:exe:brick-cache-demoPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: microlens

API changes (from Hackage documentation)

Files

• CHANGELOG.md +28/−0
• brick.cabal +16/−1
• programs/CacheDemo.hs +80/−0
• programs/LayerDemo.hs +1/−1
• src/Brick/Main.hs +99/−27
• src/Brick/Types.hs +1/−21
• src/Brick/Types/Internal.hs +45/−10
• src/Brick/Widgets/Core.hs +29/−1
• src/Brick/Widgets/Dialog.hs +4/−1

@@ -2,6 +2,34 @@ Brick changelog --------------- +0.10+----++New features:+ * Added a rendering cache. To use the rendering cache, use the 'cached'+   widget combinator. This causes drawings of the specified widget to+   re-use a cached rendering until the rendering cache is invalidated+   with 'invalidateCacheEntry' or 'invalidateCache'. This change also+   includes programs/CacheDemo.hs. This change introduced an Ord+   constraint on the name type variable 'n'.+ * Added setTop and setLeft for setting viewport offsets directly in+   EventM.+ * Dialog event handlers now support left and right arrow keys (thanks+   Grégoire Charvet)++Library changes:+ * On resizes brick now draws the application twice before handling the+   resize event. This change makes it possible for event handlers to+   get the latest viewport states on a resize rather than getting the+   most recent (but stale) versions as before, at the cost of a second+   redraw.++Bug fixes:+ * We now use the most recent rendering state when setting up event handler+   viewport data. This mostly won't matter to anyone except in cases+   where a viewport name was expected to be in the viewport map but+   wasn't due to using stale rendering state to set up EventM.+ 0.9 --- 

@@ -1,5 +1,5 @@ name:                brick-version:             0.9+version:             0.10 synopsis:            A declarative terminal user interface library description:   Write terminal applications painlessly with 'brick'! You write an@@ -91,6 +91,21 @@                        text-zipper >= 0.7.1,                        template-haskell,                        deepseq >= 1.3 && < 1.5++executable brick-cache-demo+  if !flag(demos)+    Buildable: False+  hs-source-dirs:      programs+  ghc-options:         -threaded -Wall -fno-warn-unused-do-bind -O3+  default-language:    Haskell2010+  default-extensions:  CPP+  main-is:             CacheDemo.hs+  build-depends:       base,+                       brick,+                       vty >= 5.5.0,+                       text,+                       microlens >= 0.3.0.0,+                       microlens-th  executable brick-visibility-demo   if !flag(demos)

@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedStrings #-}+module Main where++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++import Control.Monad (void)+import Data.Monoid ((<>))+import qualified Graphics.Vty as V++import qualified Brick.Types as T+import qualified Brick.Main as M+import qualified Brick.Widgets.Center as C+import Brick.Types+  ( Widget+  )+import Brick.Widgets.Core+  ( vBox+  , padTopBottom+  , withDefAttr+  , cached+  , padBottom+  , str+  )+import Brick (on)+import Brick.Widgets.Center+  ( hCenter+  )+import Brick.AttrMap+  ( AttrName+  , attrMap+  )++data Name = ExpensiveWidget+          deriving (Ord, Show, Eq)++drawUi :: Int -> [Widget Name]+drawUi i = [ui]+    where+        ui = C.vCenter $+             vBox $ hCenter <$>+             [ str "This demo shows how cached widgets behave. The top widget below"+             , str "is cacheable, so once it's rendered, brick re-uses the rendering"+             , str "each time it is drawn. The bottom widget is not cacheable so it is"+             , str "drawn on every request. Brick supports cache invalidation to force"+             , str "a redraw of cached widgets; we can trigger that here with 'i'. Notice"+             , str "how state changes with '+' aren't reflected in the cached widget"+             , str "until the cache is invalidated with 'i'."+             , padTopBottom 1 $+               cached ExpensiveWidget $+               withDefAttr emphAttr $ str $ "This widget is cached (state = " <> show i <> ")"+             , padBottom (T.Pad 1) $+               withDefAttr emphAttr $ str $ "This widget is not cached (state = " <> show i <> ")"+             , hCenter $ str "Press 'i' to invalidate the cache,"+             , str "'+' to change the state value, and"+             , str "'Esc' to quit."+             ]++appEvent :: Int -> V.Event -> T.EventM Name (T.Next Int)+appEvent i (V.EvKey (V.KChar '+') []) = M.continue $ i + 1+appEvent i (V.EvKey (V.KChar 'i') []) = M.invalidateCacheEntry ExpensiveWidget >> M.continue i+appEvent i (V.EvKey V.KEsc []) = M.halt i+appEvent i _ = M.continue i++emphAttr :: AttrName+emphAttr = "emphasis"++app :: M.App Int V.Event Name+app =+    M.App { M.appDraw = drawUi+          , M.appStartEvent = return+          , M.appHandleEvent = appEvent+          , M.appAttrMap = const $ attrMap V.defAttr [(emphAttr, V.white `on` V.blue)]+          , M.appLiftVtyEvent = id+          , M.appChooseCursor = M.neverShowCursor+          }++main :: IO ()+main = void $ M.defaultMain app 0

@@ -28,7 +28,7 @@ drawUi :: St -> [Widget ()] drawUi st =     [ C.centerLayer $-      B.border $ str "This layer is centered but other\nlayers are visible underneath it."+      B.border $ str "This layer is centered but other\nlayers are placed underneath it."     , topLayer st     , bottomLayer st     ]

@@ -22,11 +22,17 @@   , hScrollPage   , hScrollToBeginning   , hScrollToEnd+  , setTop+  , setLeft    -- * Cursor management functions   , neverShowCursor   , showFirstCursor   , showCursorNamed++  -- * Rendering cache management+  , invalidateCacheEntry+  , invalidateCache   ) where @@ -37,6 +43,10 @@ import Control.Monad.Trans.State import Control.Monad.Trans.Reader import Control.Concurrent (forkIO, Chan, newChan, readChan, writeChan, killThread)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+import Data.Monoid (mempty)+#endif import Data.Default import Data.Maybe (listToMaybe) import qualified Data.Map as M@@ -55,7 +65,7 @@   )  import Brick.Types (Viewport, Direction, Widget, rowL, columnL, CursorLocation(..), cursorLocationNameL, EventM(..))-import Brick.Types.Internal (ScrollRequest(..), RenderState(..), observedNamesL, Next(..))+import Brick.Types.Internal (ScrollRequest(..), RenderState(..), observedNamesL, Next(..), EventState(..), CacheInvalidateRequest(..)) import Brick.Widgets.Internal (renderFinal) import Brick.AttrMap @@ -101,7 +111,8 @@ -- | The default main entry point which takes an application and an -- initial state and returns the final state returned by a 'halt' -- operation.-defaultMain :: App s Event n+defaultMain :: (Ord n)+            => App s Event n             -- ^ The application.             -> s             -- ^ The initial application state.@@ -113,7 +124,8 @@ -- | A simple main entry point which takes a widget and renders it. This -- event loop terminates when the user presses any key, but terminal -- resize events cause redraws.-simpleMain :: Widget n+simpleMain :: (Ord n)+           => Widget n            -- ^ The widget to draw.            -> IO () simpleMain w =@@ -138,10 +150,16 @@ data InternalNext n a = InternalSuspendAndResume (RenderState n) (IO a)                       | InternalHalt a -runWithNewVty :: IO Vty -> Chan e -> App s e n -> RenderState n -> s -> IO (InternalNext n s)+runWithNewVty :: (Ord n)+              => IO Vty+              -> Chan (Either Event e)+              -> App s e n+              -> RenderState n+              -> s+              -> IO (InternalNext n s) runWithNewVty buildVty chan app initialRS initialSt =     withVty buildVty $ \vty -> do-        pid <- forkIO $ supplyVtyEvents vty (appLiftVtyEvent app) chan+        pid <- forkIO $ supplyVtyEvents vty chan         let runInner rs st = do               (result, newRS) <- runVty vty chan app st (rs & observedNamesL .~ S.empty)               case result of@@ -156,7 +174,8 @@  -- | The custom event loop entry point to use when the simpler ones -- don't permit enough control.-customMain :: IO Vty+customMain :: (Ord n)+           => IO Vty            -- ^ An IO action to build a Vty handle. This is used to            -- build a Vty handle whenever the event loop begins or is            -- resumed after suspension.@@ -169,32 +188,65 @@            -> s            -- ^ The initial application state.            -> IO s-customMain buildVty chan app initialAppState = do-    let run rs st = do+customMain buildVty userChan app initialAppState = do+    let run rs st chan = do             result <- runWithNewVty buildVty chan app rs st             case result of                 InternalHalt s -> return s                 InternalSuspendAndResume newRS action -> do                     newAppState <- action-                    run newRS newAppState+                    run newRS newAppState chan -    (st, initialScrollReqs) <- runStateT (runReaderT (runEventM (appStartEvent app initialAppState)) M.empty) []-    let initialRS = RS M.empty initialScrollReqs S.empty-    run initialRS st+        emptyES = ES [] []+    (st, eState) <- runStateT (runReaderT (runEventM (appStartEvent app initialAppState)) M.empty) emptyES+    let initialRS = RS M.empty (esScrollRequests eState) S.empty mempty+    chan <- newChan+    forkIO $ forever $ readChan userChan >>= (\userEvent -> writeChan chan (Right userEvent))+    run initialRS st chan -supplyVtyEvents :: Vty -> (Event -> e) -> Chan e -> IO ()-supplyVtyEvents vty mkEvent chan =+supplyVtyEvents :: Vty -> Chan (Either Event e) -> IO ()+supplyVtyEvents vty chan =     forever $ do         e <- nextEvent vty-        writeChan chan $ mkEvent e+        writeChan chan $ Left e -runVty :: Vty -> Chan e -> App s e n -> s -> RenderState n -> IO (Next s, RenderState n)+runVty :: (Ord n)+       => Vty+       -> Chan (Either Event e)+       -> App s e n+       -> s+       -> RenderState n+       -> IO (Next s, RenderState n) runVty vty chan app appState rs = do     firstRS <- renderApp vty app appState rs     e <- readChan chan-    (next, scrollReqs) <- runStateT (runReaderT (runEventM (appHandleEvent app appState e)) (viewportMap rs)) []-    return (next, firstRS { scrollRequests = scrollReqs }) +    -- If the event was a resize, redraw the UI to update the viewport+    -- states before we invoke the event handler since we want the event+    -- handler to have access to accurate viewport information.+    nextRS <- case e of+        Left (EvResize _ _) ->+            renderApp vty app appState $ firstRS & observedNamesL .~ S.empty+        _ -> return firstRS++    let emptyES = ES [] []+        userEvent = case e of+            Left e' -> appLiftVtyEvent app e'+            Right e' -> e'++    (next, eState) <- runStateT (runReaderT (runEventM (appHandleEvent app appState userEvent))+                                (viewportMap nextRS)) emptyES+    return (next, nextRS { rsScrollRequests = esScrollRequests eState+                         , renderCache = applyInvalidations (cacheInvalidateRequests eState) $+                                         renderCache nextRS+                         })++applyInvalidations :: (Ord n) => [CacheInvalidateRequest n] -> M.Map n v -> M.Map n v+applyInvalidations ns cache = foldr (.) id (mkFunc <$> ns) cache+    where+    mkFunc InvalidateEntire = const mempty+    mkFunc (InvalidateSingle n) = M.delete n+ -- | Given a viewport name, get the viewport's size and offset -- information from the most recent rendering. Returns 'Nothing' if -- no such state could be found, either because the name was invalid@@ -203,6 +255,16 @@ lookupViewport :: (Ord n) => n -> EventM n (Maybe Viewport) lookupViewport = EventM . asks . M.lookup +-- | Invalidate the rendering cache entry with the specified name.+invalidateCacheEntry :: n -> EventM n ()+invalidateCacheEntry n = EventM $ do+    lift $ modify (\s -> s { cacheInvalidateRequests = InvalidateSingle n : cacheInvalidateRequests s })++-- | Invalidate the entire rendering cache.+invalidateCache :: EventM n ()+invalidateCache = EventM $ do+    lift $ modify (\s -> s { cacheInvalidateRequests = InvalidateEntire : cacheInvalidateRequests s })+ withVty :: IO Vty -> (Vty -> IO a) -> IO a withVty buildVty useVty = do     vty <- buildVty@@ -274,20 +336,30 @@                    -- ^ Scroll vertically to the beginning of the viewport.                    , vScrollToEnd :: EventM n ()                    -- ^ Scroll vertically to the end of the viewport.+                   , setTop :: Int -> EventM n ()+                   -- ^ Set the top row offset of the viewport.+                   , setLeft :: Int -> EventM n ()+                   -- ^ Set the left column offset of the viewport.                    } +addScrollRequest :: (n, ScrollRequest) -> EventM n ()+addScrollRequest req = EventM $ do+    lift $ modify (\s -> s { esScrollRequests = req : esScrollRequests s })+ -- | Build a viewport scroller for the viewport with the specified name. viewportScroll :: n -> ViewportScroll n viewportScroll n =-    ViewportScroll { viewportName = n-                   , hScrollPage = \dir -> EventM $ lift $ modify ((n, HScrollPage dir) :)-                   , hScrollBy = \i -> EventM $ lift $ modify ((n, HScrollBy i) :)-                   , hScrollToBeginning = EventM $ lift $ modify ((n, HScrollToBeginning) :)-                   , hScrollToEnd = EventM $ lift $ modify ((n, HScrollToEnd) :)-                   , vScrollPage = \dir -> EventM $ lift $ modify ((n, VScrollPage dir) :)-                   , vScrollBy = \i -> EventM $ lift $ modify ((n, VScrollBy i) :)-                   , vScrollToBeginning = EventM $ lift $ modify ((n, VScrollToBeginning) :)-                   , vScrollToEnd = EventM $ lift $ modify ((n, VScrollToEnd) :)+    ViewportScroll { viewportName       = n+                   , hScrollPage        = \dir -> addScrollRequest (n, HScrollPage dir)+                   , hScrollBy          = \i ->   addScrollRequest (n, HScrollBy i)+                   , hScrollToBeginning =         addScrollRequest (n, HScrollToBeginning)+                   , hScrollToEnd       =         addScrollRequest (n, HScrollToEnd)+                   , vScrollPage        = \dir -> addScrollRequest (n, VScrollPage dir)+                   , vScrollBy          = \i ->   addScrollRequest (n, VScrollBy i)+                   , vScrollToBeginning =         addScrollRequest (n, VScrollToBeginning)+                   , vScrollToEnd       =         addScrollRequest (n, VScrollToEnd)+                   , setTop             = \i ->   addScrollRequest (n, SetTop i)+                   , setLeft            = \i ->   addScrollRequest (n, SetLeft i)                    }  -- | Continue running the event loop with the specified application

@@ -74,8 +74,7 @@ import Lens.Micro.Type (Getting) import Control.Monad.Trans.State.Lazy import Control.Monad.Trans.Reader-import Graphics.Vty (Event, Image, emptyImage, Attr)-import Data.Default (Default(..))+import Graphics.Vty (Event, Attr) import qualified Data.Map as M import Control.Monad.IO.Class @@ -142,30 +141,11 @@ -- communicate rendering parameters to widgets' rendering functions. type RenderM n a = ReaderT Context (State (RenderState n)) a --- | 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.-data Result n =-    Result { image :: Image-           -- ^ The final rendered image for a widget-           , cursors :: [CursorLocation n]-           -- ^ The list of reported cursor positions for the-           -- application to choose from-           , visibilityRequests :: [VisibilityRequest]-           -- ^ The list of visibility requests made by widgets rendered-           -- while rendering this one (used by viewports)-           }-           deriving Show--instance Default (Result n) where-    def = Result emptyImage [] []- -- | Get the current rendering context. getContext :: RenderM n Context getContext = ask  suffixLenses ''Context-suffixLenses ''Result  -- | The rendering context's current drawing attribute. attrL :: forall r. Getting r Context Attr

@@ -18,15 +18,21 @@   , cursorLocationL   , cursorLocationNameL   , Context(..)-  , EventState+  , EventState(..)   , Next(..)+  , Result(..)+  , CacheInvalidateRequest(..) -  , scrollRequestsL+  , rsScrollRequestsL   , viewportMapL+  , renderCacheL   , observedNamesL   , vpSize   , vpLeft   , vpTop+  , imageL+  , cursorsL+  , visibilityRequestsL   ) where @@ -39,18 +45,13 @@ import Lens.Micro.Internal (Field1, Field2) import qualified Data.Set as S import qualified Data.Map as M-import Graphics.Vty (DisplayRegion)+import Graphics.Vty (DisplayRegion, Image, emptyImage)+import Data.Default (Default(..))  import Brick.Types.TH import Brick.AttrMap (AttrName, AttrMap) import Brick.Widgets.Border.Style (BorderStyle) -data RenderState n =-    RS { viewportMap :: M.Map n Viewport-       , scrollRequests :: [(n, ScrollRequest)]-       , observedNames :: !(S.Set n)-       }- data ScrollRequest = HScrollBy Int                    | HScrollPage Direction                    | HScrollToBeginning@@ -59,6 +60,8 @@                    | VScrollPage Direction                    | VScrollToBeginning                    | VScrollToEnd+                   | SetTop Int+                   | SetLeft Int  data VisibilityRequest =     VR { vrPosition :: Location@@ -88,8 +91,13 @@                   -- ^ Viewports of this type are scrollable vertically and horizontally.                   deriving (Show, Eq) -type EventState n = [(n, ScrollRequest)]+data CacheInvalidateRequest n = InvalidateSingle n+                              | InvalidateEntire +data EventState n = ES { esScrollRequests :: [(n, ScrollRequest)]+                       , cacheInvalidateRequests :: [CacheInvalidateRequest n]+                       }+ -- | The type of actions to take upon completion of an event handler. data Next a = Continue a             | SuspendAndResume (IO a)@@ -148,6 +156,33 @@                    -- ^ The name of the widget associated with the location                    }                    deriving Show++-- | 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.+data Result n =+    Result { image :: Image+           -- ^ The final rendered image for a widget+           , cursors :: [CursorLocation n]+           -- ^ The list of reported cursor positions for the+           -- application to choose from+           , visibilityRequests :: [VisibilityRequest]+           -- ^ The list of visibility requests made by widgets rendered+           -- while rendering this one (used by viewports)+           }+           deriving Show++suffixLenses ''Result++instance Default (Result n) where+    def = Result emptyImage [] []++data RenderState n =+    RS { viewportMap :: M.Map n Viewport+       , rsScrollRequests :: [(n, ScrollRequest)]+       , observedNames :: !(S.Set n)+       , renderCache :: M.Map n (Result n)+       }  -- | The rendering context. This tells widgets how to render: how much -- space they have in which to render, which attribute they should use

@@ -60,6 +60,7 @@   , visible   , visibleRegion   , unsafeLookupViewport+  , cached    -- ** Adding offsets to cursor positions and visibility requests   , addResultOffset@@ -555,6 +556,31 @@         Fixed -> Just $ Widget (hSize p) Greedy $ withReaderT (& availHeightL .~ unrestricted) (render p)         Greedy -> Nothing +-- | Render the specified widget. If the widget has an entry in the+-- rendering cache using the specified name as the cache key, use the+-- rendered version from the cache instead. If not, render the widget+-- and update the cache.+--+-- See also 'invalidateCacheEntry'.+cached :: (Ord n) => n -> Widget n -> Widget n+cached n w =+    Widget (hSize w) (vSize w) $ do+        result <- cacheLookup n+        case result of+            Just prevResult -> return prevResult+            Nothing  -> do+                wResult <- render w+                cacheUpdate n wResult+                return wResult++cacheLookup :: (Ord n) => n -> RenderM n (Maybe (Result n))+cacheLookup n = do+    cache <- lift $ gets (^.renderCacheL)+    return $ M.lookup n cache++cacheUpdate :: (Ord n) => n -> Result n -> RenderM n ()+cacheUpdate n r = lift $ modify (& renderCacheL %~ M.insert n r)+ -- | Render the specified widget in a named viewport with the -- specified type. This permits widgets to be scrolled without being -- scrolling-aware. To make the most use of viewports, the specified@@ -623,7 +649,7 @@        -- If the rendering state includes any scrolling requests for this       -- viewport, apply those-      reqs <- lift $ gets $ (^.scrollRequestsL)+      reqs <- lift $ gets $ (^.rsScrollRequestsL)       let relevantRequests = snd <$> filter (\(n, _) -> n == vpname) reqs       when (not $ null relevantRequests) $ do           Just vp <- lift $ gets $ (^.viewportMapL.to (M.lookup vpname))@@ -710,6 +736,7 @@             VScrollPage Down -> vp^.vpTop + vp^.vpSize._2             VScrollToBeginning -> 0             VScrollToEnd -> V.imageHeight img - vp^.vpSize._2+            SetTop i -> i             _ -> vp^.vpTop scrollTo Horizontal req img vp = vp & vpLeft .~ newHStart     where@@ -720,6 +747,7 @@             HScrollPage Down -> vp^.vpLeft + vp^.vpSize._1             HScrollToBeginning -> 0             HScrollToEnd -> V.imageWidth img - vp^.vpSize._1+            SetLeft i -> i             _ -> vp^.vpLeft  scrollToView :: ViewportType -> VisibilityRequest -> Viewport -> Viewport

@@ -45,7 +45,8 @@  -- | Dialogs present a window with a title (optional), a body, and -- buttons (optional). They provide a 'HandleEvent' instance that knows--- about Tab and Shift-Tab for changing which button is active. Dialog+-- about Tab and Shift-Tab as well as ArrowLeft and ArrowRight+-- for changing which button is active. Dialog -- buttons are labeled with strings and map to values of type 'a', which -- you choose. --@@ -71,6 +72,8 @@     return $ case ev of         EvKey (KChar '\t') [] -> nextButtonBy 1 d         EvKey KBackTab [] -> nextButtonBy (-1) d+        EvKey KRight [] -> nextButtonBy 1 d+        EvKey KLeft [] -> nextButtonBy (-1) d         _ -> d  -- | Create a dialog.