{-|
  Description: Mouse clicks, drags, and scrolls
-}
module Reflex.Vty.Widget.Input.Mouse where

import Control.Monad.Fix
import qualified Graphics.Vty as V
import Reflex
import Reflex.Vty.Widget

-- | Information about a drag operation
data Drag = Drag
  { Drag -> (Int, Int)
_drag_from :: (Int, Int) -- ^ Where the drag began
  , Drag -> (Int, Int)
_drag_to :: (Int, Int) -- ^ Where the mouse currently is
  , Drag -> Button
_drag_button :: V.Button -- ^ Which mouse button is dragging
  , Drag -> [Modifier]
_drag_modifiers :: [V.Modifier] -- ^ What modifiers are held
  , Drag -> Bool
_drag_end :: Bool -- ^ Whether the drag ended (the mouse button was released)
  }
  deriving (Drag -> Drag -> Bool
(Drag -> Drag -> Bool) -> (Drag -> Drag -> Bool) -> Eq Drag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Drag -> Drag -> Bool
$c/= :: Drag -> Drag -> Bool
== :: Drag -> Drag -> Bool
$c== :: Drag -> Drag -> Bool
Eq, Eq Drag
Eq Drag
-> (Drag -> Drag -> Ordering)
-> (Drag -> Drag -> Bool)
-> (Drag -> Drag -> Bool)
-> (Drag -> Drag -> Bool)
-> (Drag -> Drag -> Bool)
-> (Drag -> Drag -> Drag)
-> (Drag -> Drag -> Drag)
-> Ord Drag
Drag -> Drag -> Bool
Drag -> Drag -> Ordering
Drag -> Drag -> Drag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Drag -> Drag -> Drag
$cmin :: Drag -> Drag -> Drag
max :: Drag -> Drag -> Drag
$cmax :: Drag -> Drag -> Drag
>= :: Drag -> Drag -> Bool
$c>= :: Drag -> Drag -> Bool
> :: Drag -> Drag -> Bool
$c> :: Drag -> Drag -> Bool
<= :: Drag -> Drag -> Bool
$c<= :: Drag -> Drag -> Bool
< :: Drag -> Drag -> Bool
$c< :: Drag -> Drag -> Bool
compare :: Drag -> Drag -> Ordering
$ccompare :: Drag -> Drag -> Ordering
$cp1Ord :: Eq Drag
Ord, Int -> Drag -> ShowS
[Drag] -> ShowS
Drag -> String
(Int -> Drag -> ShowS)
-> (Drag -> String) -> ([Drag] -> ShowS) -> Show Drag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Drag] -> ShowS
$cshowList :: [Drag] -> ShowS
show :: Drag -> String
$cshow :: Drag -> String
showsPrec :: Int -> Drag -> ShowS
$cshowsPrec :: Int -> Drag -> ShowS
Show)

-- | Converts raw vty mouse drag events into an event stream of 'Drag's
drag
  :: (Reflex t, MonadFix m, MonadHold t m, HasInput t m)
  => V.Button
  -> m (Event t Drag)
drag :: Button -> m (Event t Drag)
drag Button
btn = do
  Event t VtyEvent
inp <- m (Event t VtyEvent)
forall k (t :: k) (m :: * -> *).
HasInput t m =>
m (Event t VtyEvent)
input
  let f :: Maybe Drag -> V.Event -> Maybe Drag
      f :: Maybe Drag -> VtyEvent -> Maybe Drag
f Maybe Drag
Nothing = \case
        V.EvMouseDown Int
x Int
y Button
btn' [Modifier]
mods
          | Button
btn Button -> Button -> Bool
forall a. Eq a => a -> a -> Bool
== Button
btn' -> Drag -> Maybe Drag
forall a. a -> Maybe a
Just (Drag -> Maybe Drag) -> Drag -> Maybe Drag
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (Int, Int) -> Button -> [Modifier] -> Bool -> Drag
Drag (Int
x,Int
y) (Int
x,Int
y) Button
btn' [Modifier]
mods Bool
False
          | Bool
otherwise   -> Maybe Drag
forall a. Maybe a
Nothing
        VtyEvent
_ -> Maybe Drag
forall a. Maybe a
Nothing
      f (Just (Drag (Int, Int)
from (Int, Int)
_ Button
_ [Modifier]
mods Bool
end)) = \case
        V.EvMouseDown Int
x Int
y Button
btn' [Modifier]
mods'
          | Bool
end Bool -> Bool -> Bool
&& Button
btn Button -> Button -> Bool
forall a. Eq a => a -> a -> Bool
== Button
btn'  -> Drag -> Maybe Drag
forall a. a -> Maybe a
Just (Drag -> Maybe Drag) -> Drag -> Maybe Drag
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (Int, Int) -> Button -> [Modifier] -> Bool -> Drag
Drag (Int
x,Int
y) (Int
x,Int
y) Button
btn' [Modifier]
mods' Bool
False
          | Button
btn Button -> Button -> Bool
forall a. Eq a => a -> a -> Bool
== Button
btn'         -> Drag -> Maybe Drag
forall a. a -> Maybe a
Just (Drag -> Maybe Drag) -> Drag -> Maybe Drag
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (Int, Int) -> Button -> [Modifier] -> Bool -> Drag
Drag (Int, Int)
from (Int
x,Int
y) Button
btn [Modifier]
mods' Bool
False
          | Bool
otherwise           -> Maybe Drag
forall a. Maybe a
Nothing -- Ignore other buttons.
        V.EvMouseUp Int
x Int
y (Just Button
btn')
          | Bool
end         -> Maybe Drag
forall a. Maybe a
Nothing
          | Button
btn Button -> Button -> Bool
forall a. Eq a => a -> a -> Bool
== Button
btn' -> Drag -> Maybe Drag
forall a. a -> Maybe a
Just (Drag -> Maybe Drag) -> Drag -> Maybe Drag
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (Int, Int) -> Button -> [Modifier] -> Bool -> Drag
Drag (Int, Int)
from (Int
x,Int
y) Button
btn [Modifier]
mods Bool
True
          | Bool
otherwise   -> Maybe Drag
forall a. Maybe a
Nothing
        V.EvMouseUp Int
x Int
y Maybe Button
Nothing -- Terminal doesn't specify mouse up button,
                                -- assume it's the right one.
          | Bool
end       -> Maybe Drag
forall a. Maybe a
Nothing
          | Bool
otherwise -> Drag -> Maybe Drag
forall a. a -> Maybe a
Just (Drag -> Maybe Drag) -> Drag -> Maybe Drag
forall a b. (a -> b) -> a -> b
$ (Int, Int) -> (Int, Int) -> Button -> [Modifier] -> Bool -> Drag
Drag (Int, Int)
from (Int
x,Int
y) Button
btn [Modifier]
mods Bool
True
        VtyEvent
_ -> Maybe Drag
forall a. Maybe a
Nothing
  rec let newDrag :: Event t Drag
newDrag = (Maybe Drag -> VtyEvent -> Maybe Drag)
-> Behavior t (Maybe Drag) -> Event t VtyEvent -> Event t Drag
forall k (t :: k) a b c.
Reflex t =>
(a -> b -> Maybe c) -> Behavior t a -> Event t b -> Event t c
attachWithMaybe Maybe Drag -> VtyEvent -> Maybe Drag
f (Dynamic t (Maybe Drag) -> Behavior t (Maybe Drag)
forall k (t :: k) a. Reflex t => Dynamic t a -> Behavior t a
current Dynamic t (Maybe Drag)
dragD) Event t VtyEvent
inp
      Dynamic t (Maybe Drag)
dragD <- Maybe Drag -> Event t (Maybe Drag) -> m (Dynamic t (Maybe Drag))
forall k (t :: k) (m :: * -> *) a.
MonadHold t m =>
a -> Event t a -> m (Dynamic t a)
holdDyn Maybe Drag
forall a. Maybe a
Nothing (Event t (Maybe Drag) -> m (Dynamic t (Maybe Drag)))
-> Event t (Maybe Drag) -> m (Dynamic t (Maybe Drag))
forall a b. (a -> b) -> a -> b
$ Drag -> Maybe Drag
forall a. a -> Maybe a
Just (Drag -> Maybe Drag) -> Event t Drag -> Event t (Maybe Drag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Event t Drag
newDrag
  Event t Drag -> m (Event t Drag)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Maybe Drag -> Maybe Drag) -> Event t (Maybe Drag) -> Event t Drag
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
fmapMaybe Maybe Drag -> Maybe Drag
forall a. a -> a
id (Event t (Maybe Drag) -> Event t Drag)
-> Event t (Maybe Drag) -> Event t Drag
forall a b. (a -> b) -> a -> b
$ Dynamic t (Maybe Drag) -> Event t (Maybe Drag)
forall k (t :: k) a. Reflex t => Dynamic t a -> Event t a
updated Dynamic t (Maybe Drag)
dragD)

-- | Mouse down events for a particular mouse button
mouseDown
  :: (Reflex t, Monad m, HasInput t m)
  => V.Button
  -> m (Event t MouseDown)
mouseDown :: Button -> m (Event t MouseDown)
mouseDown Button
btn = do
  Event t VtyEvent
i <- m (Event t VtyEvent)
forall k (t :: k) (m :: * -> *).
HasInput t m =>
m (Event t VtyEvent)
input
  Event t MouseDown -> m (Event t MouseDown)
forall (m :: * -> *) a. Monad m => a -> m a
return (Event t MouseDown -> m (Event t MouseDown))
-> Event t MouseDown -> m (Event t MouseDown)
forall a b. (a -> b) -> a -> b
$ Event t VtyEvent
-> (VtyEvent -> Maybe MouseDown) -> Event t MouseDown
forall (f :: * -> *) a b.
Filterable f =>
f a -> (a -> Maybe b) -> f b
fforMaybe Event t VtyEvent
i ((VtyEvent -> Maybe MouseDown) -> Event t MouseDown)
-> (VtyEvent -> Maybe MouseDown) -> Event t MouseDown
forall a b. (a -> b) -> a -> b
$ \case
    V.EvMouseDown Int
x Int
y Button
btn' [Modifier]
mods -> if Button
btn Button -> Button -> Bool
forall a. Eq a => a -> a -> Bool
== Button
btn'
      then MouseDown -> Maybe MouseDown
forall a. a -> Maybe a
Just (MouseDown -> Maybe MouseDown) -> MouseDown -> Maybe MouseDown
forall a b. (a -> b) -> a -> b
$ Button -> (Int, Int) -> [Modifier] -> MouseDown
MouseDown Button
btn' (Int
x, Int
y) [Modifier]
mods
      else Maybe MouseDown
forall a. Maybe a
Nothing
    VtyEvent
_ -> Maybe MouseDown
forall a. Maybe a
Nothing

-- | Mouse up events for a particular mouse button
mouseUp
  :: (Reflex t, Monad m, HasInput t m)
  => m (Event t MouseUp)
mouseUp :: m (Event t MouseUp)
mouseUp = do
  Event t VtyEvent
i <- m (Event t VtyEvent)
forall k (t :: k) (m :: * -> *).
HasInput t m =>
m (Event t VtyEvent)
input
  Event t MouseUp -> m (Event t MouseUp)
forall (m :: * -> *) a. Monad m => a -> m a
return (Event t MouseUp -> m (Event t MouseUp))
-> Event t MouseUp -> m (Event t MouseUp)
forall a b. (a -> b) -> a -> b
$ Event t VtyEvent -> (VtyEvent -> Maybe MouseUp) -> Event t MouseUp
forall (f :: * -> *) a b.
Filterable f =>
f a -> (a -> Maybe b) -> f b
fforMaybe Event t VtyEvent
i ((VtyEvent -> Maybe MouseUp) -> Event t MouseUp)
-> (VtyEvent -> Maybe MouseUp) -> Event t MouseUp
forall a b. (a -> b) -> a -> b
$ \case
    V.EvMouseUp Int
x Int
y Maybe Button
btn' -> MouseUp -> Maybe MouseUp
forall a. a -> Maybe a
Just (MouseUp -> Maybe MouseUp) -> MouseUp -> Maybe MouseUp
forall a b. (a -> b) -> a -> b
$ Maybe Button -> (Int, Int) -> MouseUp
MouseUp Maybe Button
btn' (Int
x, Int
y)
    VtyEvent
_ -> Maybe MouseUp
forall a. Maybe a
Nothing

-- | Information about a mouse down event
data MouseDown = MouseDown
  { MouseDown -> Button
_mouseDown_button :: V.Button
  , MouseDown -> (Int, Int)
_mouseDown_coordinates :: (Int, Int)
  , MouseDown -> [Modifier]
_mouseDown_modifiers :: [V.Modifier]
  }
  deriving (MouseDown -> MouseDown -> Bool
(MouseDown -> MouseDown -> Bool)
-> (MouseDown -> MouseDown -> Bool) -> Eq MouseDown
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MouseDown -> MouseDown -> Bool
$c/= :: MouseDown -> MouseDown -> Bool
== :: MouseDown -> MouseDown -> Bool
$c== :: MouseDown -> MouseDown -> Bool
Eq, Eq MouseDown
Eq MouseDown
-> (MouseDown -> MouseDown -> Ordering)
-> (MouseDown -> MouseDown -> Bool)
-> (MouseDown -> MouseDown -> Bool)
-> (MouseDown -> MouseDown -> Bool)
-> (MouseDown -> MouseDown -> Bool)
-> (MouseDown -> MouseDown -> MouseDown)
-> (MouseDown -> MouseDown -> MouseDown)
-> Ord MouseDown
MouseDown -> MouseDown -> Bool
MouseDown -> MouseDown -> Ordering
MouseDown -> MouseDown -> MouseDown
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MouseDown -> MouseDown -> MouseDown
$cmin :: MouseDown -> MouseDown -> MouseDown
max :: MouseDown -> MouseDown -> MouseDown
$cmax :: MouseDown -> MouseDown -> MouseDown
>= :: MouseDown -> MouseDown -> Bool
$c>= :: MouseDown -> MouseDown -> Bool
> :: MouseDown -> MouseDown -> Bool
$c> :: MouseDown -> MouseDown -> Bool
<= :: MouseDown -> MouseDown -> Bool
$c<= :: MouseDown -> MouseDown -> Bool
< :: MouseDown -> MouseDown -> Bool
$c< :: MouseDown -> MouseDown -> Bool
compare :: MouseDown -> MouseDown -> Ordering
$ccompare :: MouseDown -> MouseDown -> Ordering
$cp1Ord :: Eq MouseDown
Ord, Int -> MouseDown -> ShowS
[MouseDown] -> ShowS
MouseDown -> String
(Int -> MouseDown -> ShowS)
-> (MouseDown -> String)
-> ([MouseDown] -> ShowS)
-> Show MouseDown
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MouseDown] -> ShowS
$cshowList :: [MouseDown] -> ShowS
show :: MouseDown -> String
$cshow :: MouseDown -> String
showsPrec :: Int -> MouseDown -> ShowS
$cshowsPrec :: Int -> MouseDown -> ShowS
Show)

-- | Information about a mouse up event
data MouseUp = MouseUp
  { MouseUp -> Maybe Button
_mouseUp_button :: Maybe V.Button
  , MouseUp -> (Int, Int)
_mouseUp_coordinates :: (Int, Int)
  }
  deriving (MouseUp -> MouseUp -> Bool
(MouseUp -> MouseUp -> Bool)
-> (MouseUp -> MouseUp -> Bool) -> Eq MouseUp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MouseUp -> MouseUp -> Bool
$c/= :: MouseUp -> MouseUp -> Bool
== :: MouseUp -> MouseUp -> Bool
$c== :: MouseUp -> MouseUp -> Bool
Eq, Eq MouseUp
Eq MouseUp
-> (MouseUp -> MouseUp -> Ordering)
-> (MouseUp -> MouseUp -> Bool)
-> (MouseUp -> MouseUp -> Bool)
-> (MouseUp -> MouseUp -> Bool)
-> (MouseUp -> MouseUp -> Bool)
-> (MouseUp -> MouseUp -> MouseUp)
-> (MouseUp -> MouseUp -> MouseUp)
-> Ord MouseUp
MouseUp -> MouseUp -> Bool
MouseUp -> MouseUp -> Ordering
MouseUp -> MouseUp -> MouseUp
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MouseUp -> MouseUp -> MouseUp
$cmin :: MouseUp -> MouseUp -> MouseUp
max :: MouseUp -> MouseUp -> MouseUp
$cmax :: MouseUp -> MouseUp -> MouseUp
>= :: MouseUp -> MouseUp -> Bool
$c>= :: MouseUp -> MouseUp -> Bool
> :: MouseUp -> MouseUp -> Bool
$c> :: MouseUp -> MouseUp -> Bool
<= :: MouseUp -> MouseUp -> Bool
$c<= :: MouseUp -> MouseUp -> Bool
< :: MouseUp -> MouseUp -> Bool
$c< :: MouseUp -> MouseUp -> Bool
compare :: MouseUp -> MouseUp -> Ordering
$ccompare :: MouseUp -> MouseUp -> Ordering
$cp1Ord :: Eq MouseUp
Ord, Int -> MouseUp -> ShowS
[MouseUp] -> ShowS
MouseUp -> String
(Int -> MouseUp -> ShowS)
-> (MouseUp -> String) -> ([MouseUp] -> ShowS) -> Show MouseUp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MouseUp] -> ShowS
$cshowList :: [MouseUp] -> ShowS
show :: MouseUp -> String
$cshow :: MouseUp -> String
showsPrec :: Int -> MouseUp -> ShowS
$cshowsPrec :: Int -> MouseUp -> ShowS
Show)

-- | Mouse scroll direction
data ScrollDirection = ScrollDirection_Up | ScrollDirection_Down
  deriving (ScrollDirection -> ScrollDirection -> Bool
(ScrollDirection -> ScrollDirection -> Bool)
-> (ScrollDirection -> ScrollDirection -> Bool)
-> Eq ScrollDirection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScrollDirection -> ScrollDirection -> Bool
$c/= :: ScrollDirection -> ScrollDirection -> Bool
== :: ScrollDirection -> ScrollDirection -> Bool
$c== :: ScrollDirection -> ScrollDirection -> Bool
Eq, Eq ScrollDirection
Eq ScrollDirection
-> (ScrollDirection -> ScrollDirection -> Ordering)
-> (ScrollDirection -> ScrollDirection -> Bool)
-> (ScrollDirection -> ScrollDirection -> Bool)
-> (ScrollDirection -> ScrollDirection -> Bool)
-> (ScrollDirection -> ScrollDirection -> Bool)
-> (ScrollDirection -> ScrollDirection -> ScrollDirection)
-> (ScrollDirection -> ScrollDirection -> ScrollDirection)
-> Ord ScrollDirection
ScrollDirection -> ScrollDirection -> Bool
ScrollDirection -> ScrollDirection -> Ordering
ScrollDirection -> ScrollDirection -> ScrollDirection
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ScrollDirection -> ScrollDirection -> ScrollDirection
$cmin :: ScrollDirection -> ScrollDirection -> ScrollDirection
max :: ScrollDirection -> ScrollDirection -> ScrollDirection
$cmax :: ScrollDirection -> ScrollDirection -> ScrollDirection
>= :: ScrollDirection -> ScrollDirection -> Bool
$c>= :: ScrollDirection -> ScrollDirection -> Bool
> :: ScrollDirection -> ScrollDirection -> Bool
$c> :: ScrollDirection -> ScrollDirection -> Bool
<= :: ScrollDirection -> ScrollDirection -> Bool
$c<= :: ScrollDirection -> ScrollDirection -> Bool
< :: ScrollDirection -> ScrollDirection -> Bool
$c< :: ScrollDirection -> ScrollDirection -> Bool
compare :: ScrollDirection -> ScrollDirection -> Ordering
$ccompare :: ScrollDirection -> ScrollDirection -> Ordering
$cp1Ord :: Eq ScrollDirection
Ord, Int -> ScrollDirection -> ShowS
[ScrollDirection] -> ShowS
ScrollDirection -> String
(Int -> ScrollDirection -> ShowS)
-> (ScrollDirection -> String)
-> ([ScrollDirection] -> ShowS)
-> Show ScrollDirection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScrollDirection] -> ShowS
$cshowList :: [ScrollDirection] -> ShowS
show :: ScrollDirection -> String
$cshow :: ScrollDirection -> String
showsPrec :: Int -> ScrollDirection -> ShowS
$cshowsPrec :: Int -> ScrollDirection -> ShowS
Show)

-- | Produce an event that fires when the mouse wheel is scrolled
mouseScroll
  :: (Reflex t, Monad m, HasInput t m)
  => m (Event t ScrollDirection)
mouseScroll :: m (Event t ScrollDirection)
mouseScroll = do
  Event t MouseDown
up <- Button -> m (Event t MouseDown)
forall k (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasInput t m) =>
Button -> m (Event t MouseDown)
mouseDown Button
V.BScrollUp
  Event t MouseDown
down <- Button -> m (Event t MouseDown)
forall k (t :: k) (m :: * -> *).
(Reflex t, Monad m, HasInput t m) =>
Button -> m (Event t MouseDown)
mouseDown Button
V.BScrollDown
  Event t ScrollDirection -> m (Event t ScrollDirection)
forall (m :: * -> *) a. Monad m => a -> m a
return (Event t ScrollDirection -> m (Event t ScrollDirection))
-> Event t ScrollDirection -> m (Event t ScrollDirection)
forall a b. (a -> b) -> a -> b
$ [Event t ScrollDirection] -> Event t ScrollDirection
forall k (t :: k) a. Reflex t => [Event t a] -> Event t a
leftmost
    [ ScrollDirection
ScrollDirection_Up ScrollDirection -> Event t MouseDown -> Event t ScrollDirection
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t MouseDown
up
    , ScrollDirection
ScrollDirection_Down ScrollDirection -> Event t MouseDown -> Event t ScrollDirection
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Event t MouseDown
down
    ]