diff --git a/src-bin/example.hs b/src-bin/example.hs index 9a2a2ea..874976b 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 ()) @@ -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 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..e79450e 100644 --- a/src/Reflex/Vty/Widget/Scroll.hs +++ b/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 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, ())