Add captureImages and avoid nested runImageWriter for scrollable elements

Author: ali-abrar

src-bin/example.hs

@@ -41,6 +41,7 @@ data Example = Example_TextEditor
              | Example_ScrollableTextDisplay
              | Example_ClickButtonsGetEmojis
              | Example_CPUStat
+             | Example_Scrollable
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 
 withCtrlC :: (Monad m, HasInput t m, Reflex t) => m () -> m (Event t ())
@@ -75,12 +76,14 @@ main = mainWidget $ withCtrlC $ do
           c <- t $ textButtonStatic def "Scrollable text display"
           d <- t $ textButtonStatic def "Clickable buttons"
           e <- t $ textButtonStatic def "CPU Usage"
+          f <- t $ textButtonStatic def "Scrollable"
           return $ leftmost
             [ Left Example_Todo <$ a
             , Left Example_TextEditor <$ b
             , Left Example_ScrollableTextDisplay <$ c
             , Left Example_ClickButtonsGetEmojis <$ d
             , Left Example_CPUStat <$ e
+            , Left Example_Scrollable <$ f
             ]
     let escapable w = do
           void w
@@ -94,9 +97,32 @@ main = mainWidget $ withCtrlC $ do
           Left Example_ScrollableTextDisplay -> escapable scrolling
           Left Example_ClickButtonsGetEmojis -> escapable easyExample
           Left Example_CPUStat -> escapable cpuStats
+          Left Example_Scrollable -> escapable scrollingWithLayout
           Right () -> buttons
     return ()
 
+scrollingWithLayout
+  :: forall t m.
+     ( VtyExample t m
+     , HasInput t m
+     , MonadHold t m
+     , Manager t m
+     , PostBuild t m
+     , MonadIO (Performable m)
+     , TriggerEvent t m
+     , PerformEvent t m
+     ) => m ()
+scrollingWithLayout = col $ do
+  scrollable def $ do
+    result <- boxTitle (constant def) (constant "Tracks") $ do
+      col $ forM [0..10] $ \n -> do
+        grout (fixed 1) $ do
+          textButtonStatic def $ T.pack (show n)
+        pure n
+    pure $ (never, result)
+  pure ()
+
+
 -- * Mouse button and emojis example
 easyExample :: (VtyExample t m, Manager t m, MonadHold t m) => m (Event t ())
 easyExample = do

src/Control/Monad/NodeId.hs

@@ -6,7 +6,7 @@ Description: Monad providing a supply of unique identifiers
 module Control.Monad.NodeId
   ( NodeId
   , MonadNodeId (..)
-  , NodeIdT
+  , NodeIdT (..)
   , runNodeIdT
   ) where
 

src/Reflex/Vty/Widget.hs

@@ -2,19 +2,23 @@
 Module: Reflex.Vty.Widget
 Description: Basic set of widgets and building blocks for reflex-vty applications
 -}
+{-# Language ScopedTypeVariables #-}
 {-# Language UndecidableInstances #-}
+{-# Language PolyKinds #-}
+{-# Language RankNTypes #-}
 
 module Reflex.Vty.Widget where
 
 import Control.Applicative (liftA2)
-import Control.Monad.Catch (MonadCatch, MonadThrow, MonadMask)
+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
 import Control.Monad.Fix (MonadFix)
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Morph (MFunctor(..))
 import Control.Monad.NodeId
-import Control.Monad.Reader (ReaderT, ask, local, runReaderT)
+import Control.Monad.Reader (ReaderT(..), ask, local, runReaderT)
 import Control.Monad.Ref
 import Control.Monad.Trans (MonadTrans, lift)
+import Control.Monad.Trans.State.Strict
 import Data.Set (Set)
 import qualified Data.Set as Set
 import Graphics.Vty (Image)
@@ -129,7 +133,10 @@ deriving instance NotReady t m => NotReady t (Input t m)
 deriving instance PerformEvent t m => PerformEvent t (Input t m)
 deriving instance PostBuild t m => PostBuild t (Input t m)
 deriving instance TriggerEvent t m => TriggerEvent t (Input t m)
-instance HasImageWriter t m => HasImageWriter t (Input t m)
+instance HasImageWriter t m => HasImageWriter t (Input t m) where
+  captureImages x = do
+    a <- input
+    lift $ captureImages $ runInput a x
 instance HasDisplayRegion t m => HasDisplayRegion t (Input t m)
 instance HasFocusReader t m => HasFocusReader t (Input t m)
 
@@ -354,7 +361,10 @@ deriving instance NotReady t m => NotReady t (DisplayRegion t m)
 deriving instance PerformEvent t m => PerformEvent t (DisplayRegion t m)
 deriving instance PostBuild t m => PostBuild t (DisplayRegion t m)
 deriving instance TriggerEvent t m => TriggerEvent t (DisplayRegion t m)
-instance HasImageWriter t m => HasImageWriter t (DisplayRegion t m)
+instance HasImageWriter t m => HasImageWriter t (DisplayRegion t m) where
+  captureImages x = do
+    reg <- askRegion
+    lift $ captureImages $ runDisplayRegion reg x
 instance HasFocusReader t m => HasFocusReader t (DisplayRegion t m)
 
 instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (DisplayRegion t m) where
@@ -422,7 +432,10 @@ deriving instance NotReady t m => NotReady t (FocusReader t m)
 deriving instance PerformEvent t m => PerformEvent t (FocusReader t m)
 deriving instance PostBuild t m => PostBuild t (FocusReader t m)
 deriving instance TriggerEvent t m => TriggerEvent t (FocusReader t m)
-instance HasImageWriter t m => HasImageWriter t (FocusReader t m)
+instance HasImageWriter t m => HasImageWriter t (FocusReader t m) where
+  captureImages x = do
+    a <- focus
+    lift $ captureImages $ runFocusReader a x
 
 instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (FocusReader t m) where
   runWithReplace (FocusReader a) e = FocusReader $ runWithReplace a $ fmap unFocusReader e
@@ -449,7 +462,7 @@ runFocusReader b = flip runReaderT b . unFocusReader
 -- * "Image" output
 
 -- | A class for widgets that can produce images to draw to the display
-class (Reflex t, Monad m) => HasImageWriter t m | m -> t where
+class (Reflex t, Monad m) => HasImageWriter (t :: *) m | m -> t where
   -- | Send images upstream for rendering
   tellImages :: Behavior t [Image] -> m ()
   default tellImages :: (f m' ~ m, Monad m', MonadTrans f, HasImageWriter t m') => Behavior t [Image] -> m ()
@@ -458,6 +471,8 @@ class (Reflex t, Monad m) => HasImageWriter t m | m -> t where
   mapImages :: (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a
   default mapImages :: (f m' ~ m, Monad m', MFunctor f, HasImageWriter t m') => (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a
   mapImages f = hoist (mapImages f)
+  -- | Capture images, preventing them from being drawn
+  captureImages :: m a -> m (a, Behavior t [Image])
 
 -- | A widget that can produce images to draw onto the display
 newtype ImageWriter t m a = ImageWriter
@@ -493,18 +508,44 @@ instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (ImageWrite
   traverseDMapWithKeyWithAdjust f m e = ImageWriter $ traverseDMapWithKeyWithAdjust (\k v -> unImageWriter $ f k v) m e
   traverseDMapWithKeyWithAdjustWithMove f m e = ImageWriter $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unImageWriter $ f k v) m e
 
-instance HasImageWriter t m => HasImageWriter t (ReaderT x m)
-instance HasImageWriter t m => HasImageWriter t (BehaviorWriterT t x m)
-instance HasImageWriter t m => HasImageWriter t (DynamicWriterT t x m)
-instance HasImageWriter t m => HasImageWriter t (EventWriterT t x m)
-instance HasImageWriter t m => HasImageWriter t (NodeIdT m)
+instance HasImageWriter t m => HasImageWriter t (ReaderT x m) where
+  captureImages x = do
+    a <- ask
+    lift $ captureImages $ runReaderT x a
+instance HasImageWriter t m => HasImageWriter t (BehaviorWriterT t x m) where
+  captureImages (BehaviorWriterT x) = BehaviorWriterT $ do
+    s <- get
+    ((result, s'), images) <- lift $ captureImages $ runStateT x s
+    put s'
+    return (result, images)
+instance HasImageWriter t m => HasImageWriter t (DynamicWriterT t x m) where
+  captureImages (DynamicWriterT x) = DynamicWriterT $ do
+    s <- get
+    ((result, s'), images) <- lift $ captureImages $ runStateT x s
+    put s'
+    return (result, images)
+
+instance HasImageWriter t m => HasImageWriter t (EventWriterT t x m) where
+  captureImages (EventWriterT x) = EventWriterT $ do
+    s <- get
+    ((result, s'), images) <- lift $ captureImages $ runStateT x s
+    put s'
+    return (result, images)
+
+instance HasImageWriter t m => HasImageWriter t (NodeIdT m) where
+  captureImages x = NodeIdT $ do
+    ref <- ask
+    lift $ captureImages $ flip runReaderT ref . unNodeIdT  $ x
 
 instance (Monad m, Reflex t) => HasImageWriter t (ImageWriter t m) where
   tellImages = ImageWriter . tellBehavior
   mapImages f (ImageWriter x) = ImageWriter $ do
     (a, images) <- lift $ runBehaviorWriterT x
     tellBehavior $ f images
     pure a
+  captureImages (ImageWriter x) = ImageWriter $ do
+    lift $ runBehaviorWriterT x
+
 
 instance HasDisplayRegion t m => HasDisplayRegion t (ImageWriter t m)
 instance HasFocusReader t m => HasFocusReader t (ImageWriter t m)
@@ -563,7 +604,10 @@ deriving instance NotReady t m => NotReady t (ThemeReader t m)
 deriving instance PerformEvent t m => PerformEvent t (ThemeReader t m)
 deriving instance PostBuild t m => PostBuild t (ThemeReader t m)
 deriving instance TriggerEvent t m => TriggerEvent t (ThemeReader t m)
-instance HasImageWriter t m => HasImageWriter t (ThemeReader t m)
+instance HasImageWriter t m => HasImageWriter t (ThemeReader t m) where
+  captureImages x = ThemeReader $ do
+    a <- ask
+    lift $ captureImages $ flip runReaderT a $ unThemeReader x
 
 instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (ThemeReader t m) where
   runWithReplace (ThemeReader a) e = ThemeReader $ runWithReplace a $ fmap unThemeReader e

src/Reflex/Vty/Widget/Layout.hs

@@ -135,6 +135,10 @@ instance (Reflex t, MonadFix m, HasInput t m) => HasInput t (Focus t m) where
 
 instance (HasImageWriter t m, MonadFix m) => HasImageWriter t (Focus t m) where
   mapImages f = hoist (mapImages f)
+  captureImages (Focus x) = Focus $ do
+    ((a, fs), images) <- lift $ captureImages $ runDynamicWriterT x
+    tellDyn fs
+    return (a, images)
 
 instance (HasFocusReader t m, Monad m) => HasFocusReader t (Focus t m)
 
@@ -437,6 +441,11 @@ instance (HasInput t m, HasDisplayRegion t m, MonadFix m, Reflex t) => HasInput
 
 instance (HasDisplayRegion t m, HasImageWriter t m, MonadFix m) => HasImageWriter t (Layout t m) where
   mapImages f = hoistRunLayout (mapImages f)
+  captureImages (Layout x) = Layout $ do
+    y <- ask
+    ((a, w), images) <- lift $ lift $ captureImages $ flip runReaderT y $ runDynamicWriterT x
+    tellDyn w
+    pure (a, images)
 
 instance (HasFocusReader t m, Monad m) => HasFocusReader t (Layout t m)
 

src/Reflex/Vty/Widget/Scroll.hs

@@ -51,10 +51,11 @@ scrollable
   ( Reflex t, MonadHold t m, MonadFix m
   , HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m)
   => ScrollableConfig t
-  -> (m (Behavior t V.Image, Event t (), a))
+  -> (m (Event t (), a))
   -> m (Scrollable t, a)
 scrollable (ScrollableConfig scrollBy scrollTo startingPos onAppend) mkImg = do
-  (img, update, a) <- mkImg
+  ((update, a), imgs) <- captureImages mkImg
+  let img = V.vertCat <$> imgs
   let sz = V.imageHeight <$> img
   kup <- key V.KUp
   kdown <- key V.KDown

src/Reflex/Vty/Widget/Text.hs

@@ -80,5 +80,5 @@ scrollableText
   -> Dynamic t Text
   -> m (Scrollable t)
 scrollableText cfg t = fmap fst $ scrollable cfg $ do
-  ((), images) <- runImageWriter $ text (current t)
-  pure $ (V.vertCat <$> images, () <$ updated t, ())
+  text (current t)
+  pure (() <$ updated t, ())