module Reflex.Vty.Widget.Input.Mouse where
import Control.Monad.Fix
import qualified Graphics.Vty as V
import Reflex
import Reflex.Vty.Widget
data Drag = Drag
{ _drag_from :: (Int, Int)
, _drag_to :: (Int, Int)
, _drag_button :: V.Button
, _drag_modifiers :: [V.Modifier]
, _drag_end :: Bool
}
deriving (Eq, Ord, Show)
drag
:: (Reflex t, MonadFix m, MonadHold t m, HasInput t m)
=> V.Button
-> m (Event t Drag)
drag btn = do
inp <- input
let f :: Maybe Drag -> V.Event -> Maybe Drag
f Nothing = \case
V.EvMouseDown x y btn' mods
| btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods False
| otherwise -> Nothing
_ -> Nothing
f (Just (Drag from _ _ mods end)) = \case
V.EvMouseDown x y btn' mods'
| end && btn == btn' -> Just $ Drag (x,y) (x,y) btn' mods' False
| btn == btn' -> Just $ Drag from (x,y) btn mods' False
| otherwise -> Nothing
V.EvMouseUp x y (Just btn')
| end -> Nothing
| btn == btn' -> Just $ Drag from (x,y) btn mods True
| otherwise -> Nothing
V.EvMouseUp x y Nothing
| end -> Nothing
| otherwise -> Just $ Drag from (x,y) btn mods True
_ -> Nothing
rec let newDrag = attachWithMaybe f (current dragD) inp
dragD <- holdDyn Nothing $ Just <$> newDrag
return (fmapMaybe id $ updated dragD)
mouseDown
:: (Reflex t, Monad m, HasInput t m)
=> V.Button
-> m (Event t MouseDown)
mouseDown btn = do
i <- input
return $ fforMaybe i $ \case
V.EvMouseDown x y btn' mods -> if btn == btn'
then Just $ MouseDown btn' (x, y) mods
else Nothing
_ -> Nothing
mouseUp
:: (Reflex t, Monad m, HasInput t m)
=> m (Event t MouseUp)
mouseUp = do
i <- input
return $ fforMaybe i $ \case
V.EvMouseUp x y btn' -> Just $ MouseUp btn' (x, y)
_ -> Nothing
data MouseDown = MouseDown
{ _mouseDown_button :: V.Button
, _mouseDown_coordinates :: (Int, Int)
, _mouseDown_modifiers :: [V.Modifier]
}
deriving (Eq, Ord, Show)
data MouseUp = MouseUp
{ _mouseUp_button :: Maybe V.Button
, _mouseUp_coordinates :: (Int, Int)
}
deriving (Eq, Ord, Show)
data ScrollDirection = ScrollDirection_Up | ScrollDirection_Down
deriving (Eq, Ord, Show)
mouseScroll
:: (Reflex t, Monad m, HasInput t m)
=> m (Event t ScrollDirection)
mouseScroll = do
up <- mouseDown V.BScrollUp
down <- mouseDown V.BScrollDown
return $ leftmost
[ ScrollDirection_Up <$ up
, ScrollDirection_Down <$ down
]