diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 --- diff --git a/brick.cabal b/brick.cabal --- a/brick.cabal +++ b/brick.cabal @@ -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) diff --git a/programs/CacheDemo.hs b/programs/CacheDemo.hs new file mode 100644 --- /dev/null +++ b/programs/CacheDemo.hs @@ -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 diff --git a/programs/LayerDemo.hs b/programs/LayerDemo.hs --- a/programs/LayerDemo.hs +++ b/programs/LayerDemo.hs @@ -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 ] diff --git a/src/Brick/Main.hs b/src/Brick/Main.hs --- a/src/Brick/Main.hs +++ b/src/Brick/Main.hs @@ -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 diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -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 diff --git a/src/Brick/Types/Internal.hs b/src/Brick/Types/Internal.hs --- a/src/Brick/Types/Internal.hs +++ b/src/Brick/Types/Internal.hs @@ -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 diff --git a/src/Brick/Widgets/Core.hs b/src/Brick/Widgets/Core.hs --- a/src/Brick/Widgets/Core.hs +++ b/src/Brick/Widgets/Core.hs @@ -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 diff --git a/src/Brick/Widgets/Dialog.hs b/src/Brick/Widgets/Dialog.hs --- a/src/Brick/Widgets/Dialog.hs +++ b/src/Brick/Widgets/Dialog.hs @@ -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.