Merge pull request #13 from reflex-frp/aa-scrollabletext

Add scrollable text widget

ChangeLog.md

@@ -1,7 +1,11 @@
 # Revision history for reflex-vty
 
-## 0.1.2.1
+## 0.1.3.0
+* Add `mouseScroll` to capture scroll wheel events
+* Add `scrollableText`: a text display widget that can be scrolled using the mouse or keyboard
+* Add widget to the example executable that displays scrollable text
 
+## 0.1.2.1
 * Add `keyCombo` function (single-key-combination version of `keyCombos`)
 * Use upstream `NotReady` instances instead of orphans defined in this package if reflex-0.6.3 is available
 

reflex-platform/stable/github.json

@@ -2,6 +2,6 @@
   "owner": "reflex-frp",
   "repo": "reflex-platform",
   "branch": "master",
-  "rev": "04672fbd55bb6d97d4efcc3657af9f4bc0d1215d",
-  "sha256": "1xzvjzrclh1qvw7ccnpwdhpg534ghyfg4kz1zdy063wr50hsqgna"
+  "rev": "510b990d0b11f0626afbec5fe8575b5b2395391b",
+  "sha256": "09cmahsbxr0963wq171c7j139iyzz49hramr4v9nsf684wcwkngv"
 }

reflex-platform/unstable/github.json

@@ -2,6 +2,6 @@
   "owner": "reflex-frp",
   "repo": "reflex-platform",
   "branch": "ghc865-nixpkgs1903",
-  "rev": "33907557fad929a19cd82df44bb4cd0276e1ffa5",
-  "sha256": "1066pydpk7w8yhq9nlcv2r21zmiir7nr6c4hr10gdf6ar3vs965a"
+  "rev": "02389f2a709a3f28ae2f3224d2c8ba81cc64c40b",
+  "sha256": "10g2yhf4la929aa1km0184asikmn0kayzlra16mqmni2f684v3z3"
 }

reflex-vty.cabal

@@ -1,5 +1,5 @@
 name: reflex-vty
-version: 0.1.2.1
+version: 0.1.3.0
 synopsis: Reflex FRP host and widgets for vty applications
 description:
   Host and widget library for Reflex-based FRP applications
@@ -46,7 +46,7 @@ library
     exception-transformers            >= 0.4.0 && < 0.5,
     primitive                         >= 0.6.3 && < 0.7,
     ref-tf                            >= 0.4.0 && < 0.5,
-    reflex                            >= 0.6.2.4 && < 0.7,
+    reflex                            >= 0.6.2 && < 0.7,
     time                              >= 1.8.0 && < 1.9,
     vty                               >= 5.21 && < 5.26
   hs-source-dirs: src

src-bin/example.hs

@@ -28,6 +28,7 @@ import Reflex.Vty
 
 data Example = Example_TextEditor
              | Example_Todo
+             | Example_ScrollableTextDisplay
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 
 main :: IO ()
@@ -40,9 +41,11 @@ main = mainWidget $ do
           fixed 1 $ text "Ctrl+c to quit."
         a <- fixed 5 $ textButtonStatic def "Todo List"
         b <- fixed 5 $ textButtonStatic def "Text Editor"
+        c <- fixed 5 $ textButtonStatic def "Scrollable text display"
         return $ leftmost
           [ Left Example_Todo <$ a
           , Left Example_TextEditor <$ b
+          , Left Example_ScrollableTextDisplay <$ c
           ]
       escapable w = do
         void w
@@ -53,11 +56,12 @@ main = mainWidget $ do
   rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
         Left Example_TextEditor -> escapable testBoxes
         Left Example_Todo -> escapable taskList
+        Left Example_ScrollableTextDisplay -> escapable scrolling
         Right () -> buttons
   return $ fforMaybe inp $ \case
     V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
     _ -> Nothing
-
+ 
 taskList
   :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m, MonadNodeId m)
   => VtyWidget t m ()
@@ -167,6 +171,12 @@ todo t0 = do
       V.EvKey V.KBS _ | T.null v -> Just ()
       _ -> Nothing
 
+scrolling :: (Reflex t, MonadHold t m, MonadFix m, PostBuild t m, MonadNodeId m) => VtyWidget t m ()
+scrolling = col $ do
+  fixed 2 $ text "Use your mouse wheel or up and down arrows to scroll:"
+  out <- fixed 5 $ boxStatic def $ scrollableText never $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant."
+  fixed 1 $ text $ ffor out $ \(ix, total) -> "Scrolled to line " <> T.pack (show ix) <> " of " <> T.pack (show total)
+
 todos
   :: forall t m.
      ( MonadHold t m

src/Reflex/Vty/Widget.hs

@@ -39,6 +39,8 @@ module Reflex.Vty.Widget
   , MouseUp(..)
   , mouseDown
   , mouseUp
+  , ScrollDirection(..)
+  , mouseScroll
   , pane
   , splitV
   , splitVDrag
@@ -47,6 +49,7 @@ module Reflex.Vty.Widget
   , RichTextConfig(..)
   , richText
   , text
+  , scrollableText
   , display
   , BoxStyle(..)
   , hyphenBoxStyle
@@ -393,6 +396,22 @@ data MouseUp = MouseUp
   }
   deriving (Eq, Ord, Show)
 
+-- | Mouse scroll direction
+data ScrollDirection = ScrollDirection_Up | ScrollDirection_Down
+  deriving (Eq, Ord, Show)
+
+-- | Produce an event that fires when the mouse wheel is scrolled
+mouseScroll
+  :: (Reflex t, Monad m)
+  => VtyWidget t m (Event t ScrollDirection)
+mouseScroll = do
+  up <- mouseDown V.BScrollUp
+  down <- mouseDown V.BScrollDown
+  return $ leftmost
+    [ ScrollDirection_Up <$ up
+    , ScrollDirection_Down <$ down
+    ]
+
 -- | Type synonym for a key and modifier combination
 type KeyCombo = (V.Key, [V.Modifier])
 
@@ -625,6 +644,38 @@ text
   -> VtyWidget t m ()
 text = richText def
 
+-- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those
+-- that are hidden)
+scrollableText
+  :: forall t m. (Reflex t, MonadHold t m, MonadFix m)
+  => Event t Int
+  -- ^ Number of lines to scroll by
+  -> Behavior t Text
+  -> VtyWidget t m (Behavior t (Int, Int))
+  -- ^ (Current scroll position, total number of lines)
+scrollableText scrollBy t = do
+  dw <- displayWidth
+  let imgs = wrap <$> current dw <*> t
+  kup <- key V.KUp
+  kdown <- key V.KDown
+  m <- mouseScroll
+  let requestedScroll :: Event t Int
+      requestedScroll = leftmost
+        [ 1 <$ kdown
+        , (-1) <$ kup
+        , ffor m $ \case
+            ScrollDirection_Up -> (-1)
+            ScrollDirection_Down -> 1
+        , scrollBy
+        ]
+      updateLine maxN delta ix = min (max 0 (ix + delta)) maxN
+  lineIndex :: Dynamic t Int <- foldDyn (\(maxN, delta) ix -> updateLine (maxN - 1) delta ix) 0 $
+    attach (length <$> imgs) requestedScroll
+  tellImages $ fmap ((:[]) . V.vertCat) $ drop <$> current lineIndex <*> imgs
+  return $ (,) <$> ((+) <$> current lineIndex <*> pure 1) <*> (length <$> imgs)
+  where
+    wrap maxWidth = concatMap (fmap (V.string V.defAttr . T.unpack) . TZ.wrapWithOffset maxWidth 0) . T.split (=='\n')
+
 -- | Renders any behavior whose value can be converted to
 -- 'String' as text
 display