packages feed

reflex-vty 0.5.2.1 → 0.6.0.0

raw patch · 8 files changed

+124/−28 lines, 8 files

Files

ChangeLog.md view
@@ -1,5 +1,10 @@ # Revision history for reflex-vty +## 0.6.0.0++* *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 view
@@ -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 view
@@ -41,6 +41,7 @@              | 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 @@   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 @@           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,8 +97,37 @@           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 ())
src/Control/Monad/NodeId.hs view
@@ -6,7 +6,7 @@ module Control.Monad.NodeId   ( NodeId   , MonadNodeId (..)-  , NodeIdT+  , NodeIdT (..)   , runNodeIdT   ) where
src/Reflex/Vty/Widget.hs view
@@ -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 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 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 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 @@ -- * "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 @@   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,19 +508,45 @@   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 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 view
@@ -135,6 +135,10 @@  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 (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 view
@@ -4,6 +4,7 @@  import Control.Monad.Fix import Data.Default+import Data.List (foldl') import qualified Graphics.Vty as V import Reflex import Reflex.Vty.Widget@@ -47,13 +48,15 @@ -- | Scrollable widget. The output exposes the current scroll position and -- total number of lines (including those that are hidden) scrollable-  :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasTheme t m)+  :: forall t m a.+  ( 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 ()))-  -> m (Scrollable t)+  -> (m (Event t (), a))+  -> m (Scrollable t, a) scrollable (ScrollableConfig scrollBy scrollTo startingPos onAppend) mkImg = do-  (img, update) <- 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@@ -81,15 +84,19 @@         _ -> 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-  return $ Scrollable+        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 view
@@ -79,7 +79,6 @@   => ScrollableConfig t   -> Dynamic t Text   -> m (Scrollable t)-scrollableText cfg t = do-  scrollable cfg $ do-    ((), images) <- runImageWriter $ text (current t)-    pure $ (V.vertCat <$> images, () <$ updated t)+scrollableText cfg t = fmap fst $ scrollable cfg $ do+  text (current t)+  pure (() <$ updated t, ())