Translate mouse inputs in scrollable elements

ChangeLog.md

@@ -1,5 +1,9 @@
 # Revision history for reflex-vty
 
+## 0.6.1.0
+
+* Fix mouse input translation in scrollable elements
+
 ## 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)`.

reflex-vty.cabal

@@ -1,5 +1,5 @@
 name: reflex-vty
-version: 0.6.0.0
+version: 0.6.1.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

@@ -56,7 +56,7 @@
 darkTheme = V.Attr {
   V.attrStyle = V.SetTo V.standout
   , V.attrForeColor = V.SetTo V.black
-  , V.attrBackColor = V.Default
+  , V.attrBackColor = V.SetTo V.green
   , V.attrURL = V.Default
 }
 
@@ -113,7 +113,7 @@
      , 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
@@ -334,7 +334,7 @@
     div' = liftA2 div
 
 debugFocus :: (VtyExample t m) => m ()
 debugFocus = do
   f <- focus
   text $ T.pack . show <$> current f
 
@@ -349,5 +349,5 @@
   text $ T.pack <$> lastEvent
 
 testStringBox :: VtyExample t m => m ()
 testStringBox = boxStatic singleBoxStyle .
   text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])

src/Reflex/Vty/Widget/Scroll.hs

@@ -55,8 +55,7 @@ scrollable
   -> (m (Event t (), a))
   -> m (Scrollable t, a)
 scrollable (ScrollableConfig scrollBy scrollTo startingPos onAppend) mkImg = do
-  ((update, a), imgs) <- captureImages mkImg
-  let sz = foldl' max 0 . fmap V.imageHeight <$> imgs
+  dh <- displayHeight
   kup <- key V.KUp
   kdown <- key V.KDown
   m <- mouseScroll
@@ -69,25 +68,28 @@ scrollable (ScrollableConfig scrollBy scrollTo startingPos onAppend) mkImg = do
             ScrollDirection_Down -> 1
         , scrollBy
         ]
-  dh <- displayHeight
-  lineIndex <- foldDynMaybe ($) startingPos $ leftmost
-    [ (\((totalLines, h), d) sp -> Just $ scrollByLines sp totalLines h d) <$> attach ((,) <$> sz <*> current dh) requestedScroll
-    , (\((totalLines, h), newScrollPosition) _ -> Just $ case newScrollPosition of
-        ScrollPos_Line n -> scrollToLine totalLines h n
-        ScrollPos_Top -> ScrollPos_Top
-        ScrollPos_Bottom -> ScrollPos_Bottom
-      ) <$> attach ((,) <$> sz <*> current dh) scrollTo
-    , (\cfg sp -> case cfg of
-        Just ScrollToBottom_Always -> case sp of
-          ScrollPos_Bottom -> Nothing
-          _ -> Just ScrollPos_Bottom
-        _ -> Nothing) <$> tag onAppend update
-    ]
-  let imgsToTell height scrollPos totalLines images = case scrollPos of
-        ScrollPos_Bottom -> cropFromTop ((1) * max 0 (totalLines - height)) <$> images
-        ScrollPos_Top -> images -- take height images
-        ScrollPos_Line n -> cropFromTop ((1) * max 0 n) <$> images
-  tellImages $ imgsToTell <$> current dh <*> current lineIndex <*> sz <*> imgs
+  rec
+    ((update, a), imgs) <- captureImages $ localInput (translateMouseEvents translation) $ mkImg
+    let sz = foldl' max 0 . fmap V.imageHeight <$> imgs
+    lineIndex <- foldDynMaybe ($) startingPos $ leftmost
+      [ (\((totalLines, h), d) sp -> Just $ scrollByLines sp totalLines h d) <$> attach ((,) <$> sz <*> current dh) requestedScroll
+      , (\((totalLines, h), newScrollPosition) _ -> Just $ case newScrollPosition of
+          ScrollPos_Line n -> scrollToLine totalLines h n
+          ScrollPos_Top -> ScrollPos_Top
+          ScrollPos_Bottom -> ScrollPos_Bottom
+        ) <$> attach ((,) <$> sz <*> current dh) scrollTo
+      , (\cfg sp -> case cfg of
+          Just ScrollToBottom_Always -> case sp of
+            ScrollPos_Bottom -> Nothing
+            _ -> Just ScrollPos_Bottom
+          _ -> Nothing) <$> tag onAppend update
+      ]
+    let translation = calculateTranslation
+          <$> current dh
+          <*> current lineIndex
+          <*> sz
+  let cropImages dy images = cropFromTop dy <$> images
+  tellImages $ cropImages <$> translation <*> imgs
   return $ (,a) $ Scrollable
     { _scrollable_scrollPosition = current lineIndex
     , _scrollable_totalLines = sz
@@ -97,6 +99,16 @@ scrollable (ScrollableConfig scrollBy scrollTo startingPos onAppend) mkImg = do
     cropFromTop :: Int -> V.Image -> V.Image
     cropFromTop rows i =
       V.cropTop (max 0 $ V.imageHeight i - rows) i
+    calculateTranslation height scrollPos totalLines = case scrollPos of
+      ScrollPos_Bottom -> max 0 (totalLines - height)
+      ScrollPos_Top -> 0
+      ScrollPos_Line n -> max 0 n
+    translateMouseEvents translation vtyEvent =
+          let e = attach translation vtyEvent
+          in ffor e $ \case
+                (dy, V.EvMouseDown x y btn mods) -> V.EvMouseDown x (y + dy) btn mods
+                (dy, V.EvMouseUp x y btn) -> V.EvMouseUp x (y + dy) btn
+                (_, otherEvent) -> otherEvent
 
 -- | Modify the scroll position by the given number of lines
 scrollByLines :: ScrollPos -> Int -> Int -> Int -> ScrollPos