Merge pull request #64 from pdlla/POTATO

change `inputInFocusedRegion` such that mouse drags that start on/off the region are/are not reported respectively

ChangeLog.md

@@ -1,5 +1,15 @@
 # Revision history for reflex-vty
 
+## Unreleased
+
+* _Breaking Changes_:
+  * Added mouse tracking to the behavior of `pane` such that
+    * Mouse actions that start outside of the region are not tracked
+    * Mouse drag sequences that start OFF the region are NOT reported
+    * Mouse drag sequences that start ON the region and drag off ARE reported
+    * Introduce `MonadHold` constraint to `pane`
+  * Added `MonadHold` constraint to several methods that use `pane`
+
 ## 0.3.1.1
 
 * Loosen version bounds and support GHC 9.4

src-bin/Example/CPU.hs

@@ -117,6 +117,7 @@ cpuStats = do
 
 chart
   :: ( MonadFix m
+     , MonadHold t m
      , HasFocus t m
      , HasLayout t m
      , HasImageWriter t m

src-bin/example.hs

@@ -18,12 +18,14 @@ import Example.CPU
 
 type VtyExample t m =
   ( MonadFix m
+  , MonadHold t m
   , Reflex t
   , HasInput t m
   , HasImageWriter t m
   , HasDisplayRegion t m
   , HasFocus t m
-  , HasFocusReader t m, HasTheme t m
+  , HasFocusReader t m
+  , HasTheme t m
   )
 
 type Manager t m =

src/Reflex/Vty/Widget.hs

@@ -202,20 +202,52 @@ mouseInRegion (Region l t w h) e = case e of
       | otherwise =
         Just (con (x - l) (y - t))
 
+-- |
+-- * 'Tracking' state means actively tracking the current stream of mouse events
+-- * 'NotTracking' state means not tracking the current stream of mouse events
+-- * 'WaitingForInput' means state will be set on next 'EvMouseDown' event
+data MouseTrackingState = Tracking V.Button | NotTracking | WaitingForInput deriving (Show, Eq)
+
 -- | Filter mouse input outside the current display region and
 -- all input if the region is not focused
+-- mouse drag sequences that start OFF the region are NOT reported
+-- mouse drag sequences that start ON the region and drag off ARE reported
 inputInFocusedRegion
-  :: (HasDisplayRegion t m, HasFocusReader t m, HasInput t m)
+  :: forall t m. (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasFocusReader t m, HasInput t m)
   => m (Event t VtyEvent)
 inputInFocusedRegion = do
   inp <- input
   reg <- current <$> askRegion
   foc <- current <$> focus
-  pure $ fmapMaybe id $ attachWith filterInput ((,) <$> reg <*> foc) inp
-  where
-    filterInput (r, f) = \case
-      V.EvKey {} | not f -> Nothing
-      x -> mouseInRegion r x
+  let
+    trackMouse ::
+      VtyEvent
+      -> (MouseTrackingState, Maybe VtyEvent)
+      -> PushM t (Maybe (MouseTrackingState, Maybe VtyEvent))
+    trackMouse e (tracking, _) = do
+      -- sampling (as oppose to using attachPromptlyDyn) is necessary here as the focus may change from the event produced here
+      focused <- sample foc
+      -- strictly speaking the same could also happen here too
+      reg'@(Region l t _ _) <- sample reg
+      return $ case e of
+        V.EvKey _ _ | not focused -> Nothing
+        V.EvMouseDown x y btn m ->
+          if tracking == Tracking btn || (tracking == WaitingForInput && isWithin reg' x y)
+            then Just (Tracking btn, Just $ V.EvMouseDown (x - l) (y - t) btn m)
+            else Just (NotTracking, Nothing)
+        V.EvMouseUp x y mbtn -> case mbtn of
+          Nothing -> case tracking of
+            Tracking _ -> Just (WaitingForInput, Just $ V.EvMouseUp (x - l) (y - t) mbtn)
+            _ -> Just (WaitingForInput, Nothing)
+          Just btn -> if tracking == Tracking btn
+            -- NOTE we only report EvMouseUp for the button we are tracking
+            -- vty has mouse buttons override others (seems to be based on ordering of Button) when multiple are pressed.
+            -- so it IS possible for child widget to miss out on a 'EvMouseUp' event with this current implementation
+            then Just (WaitingForInput, Just $ V.EvMouseUp (x - l) (y - t) mbtn)
+            else Just (WaitingForInput, Nothing)
+        _ -> Just (tracking, Just e)
+  dynInputEvTracking <- foldDynMaybeM trackMouse (WaitingForInput, Nothing) $ inp
+  return (fmapMaybe snd $ updated dynInputEvTracking)
 
 -- * Getting and setting the display region
 
@@ -236,6 +268,12 @@ nilRegion = Region 0 0 0 0
 regionSize :: Region -> (Int, Int)
 regionSize (Region _ _ w h) = (w, h)
 
+isWithin :: Region -> Int -> Int -> Bool
+isWithin (Region l t w h) x y = not . or $ [ x < l
+                                           , y < t
+                                           , x >= l + w
+                                           , y >= t + h ]
+
 -- | Produces an 'Image' that fills a region with space characters
 regionBlankImage :: V.Attr -> Region -> Image
 regionBlankImage attr r@(Region _ _ width height) =
@@ -540,11 +578,12 @@ imagesInRegion reg = liftA2 (\r is -> map (withinImage r) is) reg
 -- a given region and context. This widget filters and modifies the input
 -- that the child widget receives such that:
 -- * unfocused widgets receive no key events
--- * mouse inputs outside the region are ignored
 -- * mouse inputs inside the region have their coordinates translated such
+-- * mouse drag sequences that start OFF the region are ignored
+-- * mouse drag sequences that start ON the region and drag off are NOT ignored
 --   that (0,0) is the top-left corner of the region
 pane
-  :: (Reflex t, Monad m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
+  :: (MonadFix m, MonadHold t m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
   => Dynamic t Region
   -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
   -> m a

src/Reflex/Vty/Widget/Box.hs

@@ -3,6 +3,7 @@
 -}
 module Reflex.Vty.Widget.Box where
 
+import Control.Monad.Fix (MonadFix)
 import Data.Default
 import Data.Text (Text)
 import qualified Data.Text as T
@@ -54,7 +55,7 @@ roundedBoxStyle :: BoxStyle
 roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'
 
 -- | Draws a titled box in the provided style and a child widget inside of that box
-boxTitle :: (Monad m, Reflex t ,HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)
+boxTitle :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)
     => Behavior t BoxStyle
     -> Behavior t Text
     -> m a
@@ -109,15 +110,15 @@ boxTitle boxStyle title child = do
         right = mkHalf delta
 
 -- | A box without a title
-box :: (Monad m, Reflex t, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)
+box :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)
     => Behavior t BoxStyle
     -> m a
     -> m a
 box boxStyle = boxTitle boxStyle mempty
 
 -- | A box whose style is static
 boxStatic
-  :: (Monad m, Reflex t, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)
+  :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m, HasFocusReader t m, HasTheme t m)
   => BoxStyle
   -> m a
   -> m a

src/Reflex/Vty/Widget/Input.hs

@@ -35,7 +35,7 @@ instance Reflex t => Default (ButtonConfig t) where
 
 -- | A button widget that contains a sub-widget
 button
-  :: (Reflex t, Monad m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m)
+  :: (MonadFix m, MonadHold t m, HasFocusReader t m, HasTheme t m, HasDisplayRegion t m, HasImageWriter t m, HasInput t m)
   => ButtonConfig t
   -> m ()
   -> m (Event t ())
@@ -53,15 +53,15 @@ button cfg child = do
 
 -- | A button widget that displays text that can change
 textButton
-  :: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m)
+  :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m)
   => ButtonConfig t
   -> Behavior t Text
   -> m (Event t ())
 textButton cfg = button cfg . text -- TODO Centering etc.
 
 -- | A button widget that displays a static bit of text
 textButtonStatic
-  :: (Reflex t, Monad m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m)
+  :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m, HasImageWriter t m, HasInput t m)
   => ButtonConfig t
   -> Text
   -> m (Event t ())

src/Reflex/Vty/Widget/Input/Text.hs

@@ -144,7 +144,7 @@ multilineTextInput cfg = do
 -- the computed line count to greedily size the tile when vertically
 -- oriented, and uses the fallback width when horizontally oriented.
 textInputTile
-  :: (Monad m, Reflex t, MonadFix m, HasLayout t m, HasInput t m, HasFocus t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m)
+  :: (MonadFix m, MonadHold t m, HasLayout t m, HasInput t m, HasFocus t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m, HasTheme t m)
   => m (TextInput t)
   -> Dynamic t Int
   -> m (TextInput t)

src/Reflex/Vty/Widget/Layout.hs

@@ -510,7 +510,7 @@ initManager_ = fmap fst . initManager
 -- provided constraint. Returns the 'FocusId' allowing for manual focus
 -- management.
 tile'
-  :: (MonadFix m, Reflex t, HasInput t m, HasFocus t m, HasLayout t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
+  :: (MonadFix m, MonadHold t m, HasInput t m, HasFocus t m, HasLayout t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
   => Dynamic t Constraint
   -> m a
   -> m (FocusId, a)
@@ -529,7 +529,7 @@ tile' c w = do
 -- | A widget that is focusable and occupies a layout region based on the
 -- provided constraint.
 tile
-  :: (MonadFix m, Reflex t, HasInput t m, HasFocus t m, HasLayout t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
+  :: (MonadFix m, MonadHold t m, HasInput t m, HasFocus t m, HasLayout t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
   => Dynamic t Constraint
   -> m a
   -> m a
@@ -540,7 +540,7 @@ tile c = fmap snd . tile' c
 -- | A widget that is not focusable and occupies a layout region based on the
 -- provided constraint.
 grout
-  :: (Reflex t, HasLayout t m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
+  :: (MonadFix m, MonadHold t m, HasLayout t m, HasInput t m, HasImageWriter t m, HasDisplayRegion t m, HasFocusReader t m)
   => Dynamic t Constraint
   -> m a
   -> m a

src/Reflex/Vty/Widget/Split.hs

@@ -13,7 +13,7 @@ import Reflex.Vty.Widget.Input.Mouse
 -- | A split of the available space into two parts with a draggable separator.
 -- Starts with half the space allocated to each, and the first pane has focus.
 -- Clicking in a pane switches focus.
-splitVDrag :: (Reflex t, MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)
+splitVDrag :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)
   => m ()
   -> m a
   -> m b
@@ -52,7 +52,7 @@ splitVDrag wS wA wB = do
 
 -- | A plain split of the available space into vertically stacked panes.
 -- No visual separator is built in here.
-splitV :: (Reflex t, Monad m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)
+splitV :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)
        => Dynamic t (Int -> Int)
        -- ^ Function used to determine size of first pane based on available size
        -> Dynamic t (Bool, Bool)
@@ -73,7 +73,7 @@ splitV sizeFunD focD wA wB = do
 
 -- | A plain split of the available space into horizontally stacked panes.
 -- No visual separator is built in here.
-splitH :: (Reflex t, Monad m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)
+splitH :: (MonadFix m, MonadHold t m, HasDisplayRegion t m, HasInput t m, HasImageWriter t m, HasFocusReader t m)
        => Dynamic t (Int -> Int)
        -- ^ Function used to determine size of first pane based on available size
        -> Dynamic t (Bool, Bool)
@@ -89,4 +89,3 @@ splitH sizeFunD focD wA wB = do
   let regA = Region 0 0 <$> (sizeFunD <*> dw) <*> dh
       regB = Region <$> (_region_width <$> regA) <*> 0 <*> liftA2 (-) dw (_region_width <$> regA) <*> dh
   liftA2 (,) (pane regA (fmap fst focD) wA) (pane regB (fmap snd focD) wB)
-