Merge pull request #90 from reflex-frp/aa/capture-images

Add captureImages and avoid nested runImageWriter for scrollable

ChangeLog.md

@@ -1,8 +1,9 @@
 # Revision history for reflex-vty
 
-## Unreleased
+## 0.6.0.0
 
-* *Breaking Change*: `Reflex.Vty.Widget.Scroll.scrollable` now require child widgets to return a value in addition to their images and update events. Specifically, the child widget type has gone from `m (Behavior t Image, Event t ())` to `m (Behavior t Image, Event t (), a)`.
+* *Breaking Change*: `Reflex.Vty.Widget.Scroll.scrollable`'s type has changed. The child widget no longer has to return images (see `captureImages` below), but can return a value. Specifically, the child widget type has gone from `m (Behavior t Image, Event t ())` to `m (Event t (), a)`.
+* *Breaking Change*: Instance of `HasImageWriter` must now implement `captureImages`, a function that allows the `Image`s produced by a widget to be intercepted and not rendered. This is used to implement `scrollable`.
 
 ## 0.5.2.1
 * Extend version bounds

reflex-vty.cabal

@@ -1,5 +1,5 @@
 name: reflex-vty
-version: 0.5.2.1
+version: 0.6.0.0
 synopsis: Reflex FRP host and widgets for VTY applications
 description:
   Build terminal applications using functional reactive programming (FRP) with Reflex FRP (<https://reflex-frp.org>).

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 ())
@@ -64,7 +65,7 @@ main = mainWidget $ withCtrlC $ do
   initManager_ $ do
     tabNavigation
     let gf = grout . fixed
-        t = tile flex
+        t = tile (fixed 3)
         buttons = col $ do
           gf 3 $ col $ do
             gf 1 $ text "Select an example."
@@ -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,38 @@ 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
+  (s, x) <- tile flex $ boxTitle (constant def) (constant "Tracks") $ scrollable def $ do
+    result <- do
+      forM_ [(0::Int)..10] $ \n -> do
+        tile (fixed 5) $ do
+          tile (fixed 4) $ textButtonStatic def $ T.pack (show n)
+      askRegion
+    pure (never, result)
+  grout (fixed 1) $
+    text $ ("Total Lines: "<>) . T.pack . show <$> _scrollable_totalLines s
+  grout (fixed 1) $
+    text $ ("Scroll Pos: "<>) . T.pack . show <$> _scrollable_scrollPosition s
+  grout (fixed 1) $
+    text $ ("Scroll Height: "<>) . T.pack . show <$> _scrollable_scrollHeight s
+  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

@@ -4,6 +4,7 @@ module Reflex.Vty.Widget.Scroll where
 
 import Control.Monad.Fix
 import Data.Default
+import Data.List (foldl')
 import qualified Graphics.Vty as V
 import Reflex
 import Reflex.Vty.Widget
@@ -51,11 +52,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
-  let sz = V.imageHeight <$> img
+  ((update, a), imgs) <- captureImages mkImg
+  let sz = foldl' max 0 . fmap V.imageHeight <$> imgs
   kup <- key V.KUp
   kdown <- key V.KDown
   m <- mouseScroll
@@ -83,15 +84,19 @@ scrollable (ScrollableConfig scrollBy scrollTo startingPos onAppend) mkImg = do
         _ -> Nothing) <$> tag onAppend update
     ]
   let imgsToTell height scrollPos totalLines images = case scrollPos of
-        ScrollPos_Bottom -> V.translateY ((-1) * max 0 (totalLines - height)) images
+        ScrollPos_Bottom -> cropFromTop ((1) * max 0 (totalLines - height)) <$> images
         ScrollPos_Top -> images -- take height images
-        ScrollPos_Line n -> V.translateY ((-1) * n) images
-  tellImages $ fmap (:[]) $ imgsToTell <$> current dh <*> current lineIndex <*> sz <*> img
+        ScrollPos_Line n -> cropFromTop ((1) * max 0 n) <$> images
+  tellImages $ imgsToTell <$> current dh <*> current lineIndex <*> sz <*> imgs
   return $ (,a) $ Scrollable
     { _scrollable_scrollPosition = current lineIndex
     , _scrollable_totalLines = sz
     , _scrollable_scrollHeight = current dh
     }
+  where
+    cropFromTop :: Int -> V.Image -> V.Image
+    cropFromTop rows i =
+      V.cropTop (max 0 $ V.imageHeight i - rows) i
 
 -- | Modify the scroll position by the given number of lines
 scrollByLines :: ScrollPos -> Int -> Int -> Int -> ScrollPos

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, ())