diff --git a/ChangeLog.md b/ChangeLog.md index 9b61a6c..4dddf1e 100644 --- a/ChangeLog.md +++ b/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 diff --git a/reflex-vty.cabal b/reflex-vty.cabal index baf9f59..e9139a9 100644 --- a/reflex-vty.cabal +++ b/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 (). diff --git a/src-bin/example.hs b/src-bin/example.hs index 9a2a2ea..d53ccf0 100644 --- a/src-bin/example.hs +++ b/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 diff --git a/src/Control/Monad/NodeId.hs b/src/Control/Monad/NodeId.hs index 6c1a8db..721cc09 100644 --- a/src/Control/Monad/NodeId.hs +++ b/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 diff --git a/src/Reflex/Vty/Widget.hs b/src/Reflex/Vty/Widget.hs index 3a0bfca..feb5988 100644 --- a/src/Reflex/Vty/Widget.hs +++ b/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,11 +508,34 @@ 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 @@ -505,6 +543,9 @@ instance (Monad m, Reflex t) => HasImageWriter t (ImageWriter t m) where (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 diff --git a/src/Reflex/Vty/Widget/Layout.hs b/src/Reflex/Vty/Widget/Layout.hs index 3c708a9..ccbb4e1 100644 --- a/src/Reflex/Vty/Widget/Layout.hs +++ b/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) diff --git a/src/Reflex/Vty/Widget/Scroll.hs b/src/Reflex/Vty/Widget/Scroll.hs index 6245d7a..0a2fc70 100644 --- a/src/Reflex/Vty/Widget/Scroll.hs +++ b/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 diff --git a/src/Reflex/Vty/Widget/Text.hs b/src/Reflex/Vty/Widget/Text.hs index 283138f..a16249d 100644 --- a/src/Reflex/Vty/Widget/Text.hs +++ b/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, ())