Add rendering cache and "cached" constructor (API: note Ord constraints on "n")

src/Brick/Main.hs

@@ -27,6 +27,10 @@ module Brick.Main
   , neverShowCursor
   , showFirstCursor
   , showCursorNamed
+
+  -- * Rendering cache management
+  , invalidateCacheEntry
+  , invalidateCache
   )
 where
 
@@ -55,7 +59,7 @@ import Graphics.Vty
   )
 
 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 +105,8 @@ data App s e n =
 -- | 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 +118,8 @@ defaultMain app st = do
 -- | 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,7 +144,7 @@ resizeOrQuit s _ = halt s
 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 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
@@ -156,7 +162,8 @@ runWithNewVty buildVty chan app initialRS initialSt =
 
 -- | 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.
@@ -178,8 +185,9 @@ customMain buildVty chan app initialAppState = do
                     newAppState <- action
                     run newRS newAppState
 
-    (st, initialScrollReqs) <- runStateT (runReaderT (runEventM (appStartEvent app initialAppState)) M.empty) []
+        emptyES = ES [] []
-    let initialRS = RS M.empty initialScrollReqs S.empty
+    (st, eState) <- runStateT (runReaderT (runEventM (appStartEvent app initialAppState)) M.empty) emptyES
+    let initialRS = RS M.empty (esScrollRequests eState) S.empty mempty
     run initialRS st
 
 supplyVtyEvents :: Vty -> (Event -> e) -> Chan e -> IO ()
@@ -188,12 +196,22 @@ supplyVtyEvents vty mkEvent chan =
         e <- nextEvent vty
         writeChan chan $ mkEvent e
 
-runVty :: Vty -> Chan e -> App s e n -> s -> RenderState n -> IO (Next s, RenderState n)
+runVty :: (Ord n) => Vty -> Chan 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)) []
+    let emptyES = ES [] []
-    return (next, firstRS { scrollRequests = scrollReqs })
+    (next, eState) <- runStateT (runReaderT (runEventM (appHandleEvent app appState e)) (viewportMap rs)) emptyES
+    return (next, firstRS { rsScrollRequests = esScrollRequests eState
+                          , renderCache = applyInvalidations (cacheInvalidateRequests eState) $
+                                          renderCache firstRS
+                          })
+
+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
@@ -203,6 +221,16 @@ runVty vty chan app appState rs = do
 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
@@ -276,18 +304,22 @@ data ViewportScroll n =
                    -- ^ Scroll vertically to the end 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
+    ViewportScroll { viewportName       = n
-                   , hScrollPage = \dir -> EventM $ lift $ modify ((n, HScrollPage dir) :)
+                   , hScrollPage        = \dir -> addScrollRequest (n, HScrollPage dir)
-                   , hScrollBy = \i -> EventM $ lift $ modify ((n, HScrollBy i) :)
+                   , hScrollBy          = \i ->   addScrollRequest (n, HScrollBy i)
-                   , hScrollToBeginning = EventM $ lift $ modify ((n, HScrollToBeginning) :)
+                   , hScrollToBeginning =         addScrollRequest (n, HScrollToBeginning)
-                   , hScrollToEnd = EventM $ lift $ modify ((n, HScrollToEnd) :)
+                   , hScrollToEnd       =         addScrollRequest (n, HScrollToEnd)
-                   , vScrollPage = \dir -> EventM $ lift $ modify ((n, VScrollPage dir) :)
+                   , vScrollPage        = \dir -> addScrollRequest (n, VScrollPage dir)
-                   , vScrollBy = \i -> EventM $ lift $ modify ((n, VScrollBy i) :)
+                   , vScrollBy          = \i ->   addScrollRequest (n, VScrollBy i)
-                   , vScrollToBeginning = EventM $ lift $ modify ((n, VScrollToBeginning) :)
+                   , vScrollToBeginning =         addScrollRequest (n, VScrollToBeginning)
-                   , vScrollToEnd = EventM $ lift $ modify ((n, VScrollToEnd) :)
+                   , vScrollToEnd       =         addScrollRequest (n, VScrollToEnd)
                    }
 
 -- | Continue running the event loop with the specified application

src/Brick/Types.hs

@@ -74,8 +74,7 @@ import Lens.Micro (_1, _2, to, (^.), (&), (.~), Lens')
 import Lens.Micro.Type (Getting)
 import Control.Monad.Trans.State.Lazy
 import Control.Monad.Trans.Reader
-import Graphics.Vty (Event, Image, emptyImage, Attr)
+import Graphics.Vty (Event, Attr)
-import Data.Default (Default(..))
 import qualified Data.Map as M
 import Control.Monad.IO.Class
 
@@ -142,30 +141,11 @@ data Widget n =
 -- 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

src/Brick/Types/Internal.hs

@@ -18,15 +18,21 @@ module Brick.Types.Internal
   , 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.TH (makeLenses)
 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
@@ -88,7 +89,12 @@ data ViewportType = Vertical
                   -- ^ 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
@@ -149,6 +155,33 @@ data CursorLocation n =
                    }
                    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
 -- to render, which bordering style should be used, and the attribute map

src/Brick/Widgets/Core.hs

@@ -60,6 +60,7 @@ module Brick.Widgets.Core
   , visible
   , visibleRegion
   , unsafeLookupViewport
+  , cached
 
   -- ** Adding offsets to cursor positions and visibility requests
   , addResultOffset
@@ -555,6 +556,31 @@ vRelease p =
         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 @@ viewport vpname typ p =
 
       -- 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))