{-# LANGUAGE OverloadedStrings          #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  HGeometry.Miso.Event.Extra
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Some extra event helpers, in partricular for touch and wheel events
--
--------------------------------------------------------------------------------
module HGeometry.Miso.Event.Extra
  ( WheelDirection(..)
  , onWheel
  , Button(..)
  , onClickWithButton
  , onRightClick
  -- , Touch(..), TouchEvent(..)
  -- , onTouchStart
  -- , onTouchMove
  -- , onTouchEnd
  ) where

import Data.Map qualified as Map
import Miso.JSON
import Miso
import Miso.Html.Event
import Miso.Event.Types as Event
import Miso.Util.Parser ()

--------------------------------------------------------------------------------

-- | Scroll-wheel direction
data WheelDirection = Up | Down deriving (Int -> WheelDirection -> ShowS
[WheelDirection] -> ShowS
WheelDirection -> String
(Int -> WheelDirection -> ShowS)
-> (WheelDirection -> String)
-> ([WheelDirection] -> ShowS)
-> Show WheelDirection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WheelDirection -> ShowS
showsPrec :: Int -> WheelDirection -> ShowS
$cshow :: WheelDirection -> String
show :: WheelDirection -> String
$cshowList :: [WheelDirection] -> ShowS
showList :: [WheelDirection] -> ShowS
Show,WheelDirection -> WheelDirection -> Bool
(WheelDirection -> WheelDirection -> Bool)
-> (WheelDirection -> WheelDirection -> Bool) -> Eq WheelDirection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WheelDirection -> WheelDirection -> Bool
== :: WheelDirection -> WheelDirection -> Bool
$c/= :: WheelDirection -> WheelDirection -> Bool
/= :: WheelDirection -> WheelDirection -> Bool
Eq)

-- | A type modelling the mouse buttons
data Button = LeftButton
            | MiddleButton
            | RightButton
            deriving (Int -> Button -> ShowS
[Button] -> ShowS
Button -> String
(Int -> Button -> ShowS)
-> (Button -> String) -> ([Button] -> ShowS) -> Show Button
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Button -> ShowS
showsPrec :: Int -> Button -> ShowS
$cshow :: Button -> String
show :: Button -> String
$cshowList :: [Button] -> ShowS
showList :: [Button] -> ShowS
Show,Button -> Button -> Bool
(Button -> Button -> Bool)
-> (Button -> Button -> Bool) -> Eq Button
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Button -> Button -> Bool
== :: Button -> Button -> Bool
$c/= :: Button -> Button -> Bool
/= :: Button -> Button -> Bool
Eq)

-- | on wheel events
onWheel          :: (WheelDirection -> action) -> Attribute action
onWheel :: forall action. (WheelDirection -> action) -> Attribute action
onWheel WheelDirection -> action
toAction = MisoString
-> Decoder WheelDirection
-> (WheelDirection -> DOMRef -> action)
-> Attribute action
forall r action.
MisoString
-> Decoder r -> (r -> DOMRef -> action) -> Attribute action
on MisoString
"wheel" ((Value -> Parser WheelDirection)
-> DecodeTarget -> Decoder WheelDirection
forall a. (Value -> Parser a) -> DecodeTarget -> Decoder a
Decoder Value -> Parser WheelDirection
dec DecodeTarget
dt) (\WheelDirection
res DOMRef
_ -> WheelDirection -> action
toAction WheelDirection
res)
  where
    dt :: DecodeTarget
dt = [MisoString] -> DecodeTarget
DecodeTarget [MisoString]
forall a. Monoid a => a
mempty
    dec :: Value -> Parser WheelDirection
dec = MisoString
-> (Object -> Parser WheelDirection)
-> Value
-> Parser WheelDirection
forall a. MisoString -> (Object -> Parser a) -> Value -> Parser a
withObject MisoString
"event" ((Object -> Parser WheelDirection)
 -> Value -> Parser WheelDirection)
-> (Object -> Parser WheelDirection)
-> Value
-> Parser WheelDirection
forall a b. (a -> b) -> a -> b
$ \Object
o -> Double -> WheelDirection
f (Double -> WheelDirection)
-> Parser Double -> Parser WheelDirection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o Object -> MisoString -> Parser Double
forall a. FromJSON a => Object -> MisoString -> Parser a
.: MisoString
"deltaY")
    f   :: Double -> WheelDirection
    f :: Double -> WheelDirection
f Double
x = if Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
0 then WheelDirection
Up else WheelDirection
Down

-- | get the mouse button that was clicked
onClickWithButton          :: (Button -> action) -> Attribute action
onClickWithButton :: forall action. (Button -> action) -> Attribute action
onClickWithButton Button -> action
toAction = MisoString
-> Decoder Button
-> (Button -> DOMRef -> action)
-> Attribute action
forall r action.
MisoString
-> Decoder r -> (r -> DOMRef -> action) -> Attribute action
on MisoString
"click" ((Value -> Parser Button) -> DecodeTarget -> Decoder Button
forall a. (Value -> Parser a) -> DecodeTarget -> Decoder a
Decoder Value -> Parser Button
dec DecodeTarget
dt) (\Button
res DOMRef
_ -> Button -> action
toAction Button
res)
  where
    dt :: DecodeTarget
dt  = [MisoString] -> DecodeTarget
DecodeTarget [MisoString]
forall a. Monoid a => a
mempty
    dec :: Value -> Parser Button
    dec :: Value -> Parser Button
dec = MisoString -> (Object -> Parser Button) -> Value -> Parser Button
forall a. MisoString -> (Object -> Parser a) -> Value -> Parser a
withObject MisoString
"event" ((Object -> Parser Button) -> Value -> Parser Button)
-> (Object -> Parser Button) -> Value -> Parser Button
forall a b. (a -> b) -> a -> b
$ \Object
o -> case MisoString -> Object -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup MisoString
"button" Object
o of
            Maybe Value
Nothing -> String -> Parser Button
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"button not found?"
            Just Value
v  -> ((Double -> Parser Button) -> Value -> Parser Button)
-> Value -> (Double -> Parser Button) -> Parser Button
forall a b c. (a -> b -> c) -> b -> a -> c
flip (MisoString -> (Double -> Parser Button) -> Value -> Parser Button
forall a. MisoString -> (Double -> Parser a) -> Value -> Parser a
withNumber MisoString
"Button") Value
v ((Double -> Parser Button) -> Parser Button)
-> (Double -> Parser Button) -> Parser Button
forall a b. (a -> b) -> a -> b
$ \case
              Double
0 -> Button -> Parser Button
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Button
LeftButton
              Double
1 -> Button -> Parser Button
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Button
MiddleButton
              Double
2 -> Button -> Parser Button
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Button
RightButton
              Double
_ -> String -> Parser Button
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"unknown button"

-- | Get right clicks
onRightClick :: action -> Attribute action
onRightClick :: forall action. action -> Attribute action
onRightClick = Options -> action -> Attribute action
forall action. Options -> action -> Attribute action
onContextMenuWithOptions Options
disabled
  where
    disabled :: Options
disabled = Options
Event.defaultOptions { _preventDefault  = True
                                    , _stopPropagation = False
                                    }