{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RecordWildCards          #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Redundant lambda" #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  HGeometry.Miso.Subscription.MouseExtra
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- Extra mouse event events/decoders
--
--------------------------------------------------------------------------------
module HGeometry.Miso.Subscription.MouseExtra
  ( onMouseEnterAt
  , onMouseMoveAt
  , onMouseClickAt
  , onTouchStartAt
  , onTouchMoveAt
  , onTouchEnd
  ) where

import           Control.Monad ((<=<))
import           Control.Monad.IO.Class
import           Data.Aeson (withObject, withArray, (.:), Value)
import           Data.Aeson.Types (Parser, parseEither)
import qualified Data.Foldable as F
import           GHCJS.Marshal
import           HGeometry.Miso.FFI.Extra
import           HGeometry.Point
import           HGeometry.Vector
import           JavaScript.Object
import           JavaScript.Object.Internal
import           Miso
import           Miso.String (MisoString, unpack)


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

-- | onMouseMove event, the position is relative to the target of the event
onMouseMoveAt :: (Point 2 Int -> action) -> Attribute action
onMouseMoveAt :: forall action. (Point 2 Int -> action) -> Attribute action
onMouseMoveAt = MisoString
-> Decoder (Point 2 Int)
-> (Point 2 Int -> action)
-> Attribute action
forall r action.
MisoString -> Decoder r -> (r -> action) -> Attribute action
on MisoString
"mousemove" Decoder (Point 2 Int)
mousePositionDecoder

-- | onMouseEnter event, the position is relative to the target of the event
onMouseEnterAt :: (Point 2 Int -> action) -> Attribute action
onMouseEnterAt :: forall action. (Point 2 Int -> action) -> Attribute action
onMouseEnterAt = MisoString
-> Decoder (Point 2 Int)
-> (Point 2 Int -> action)
-> Attribute action
forall r action.
MisoString -> Decoder r -> (r -> action) -> Attribute action
on MisoString
"mouseenter" Decoder (Point 2 Int)
mousePositionDecoder

-- | onMouseEnter event, the position is relative to the target of the event
onMouseClickAt :: (Point 2 Int -> action) -> Attribute action
onMouseClickAt :: forall action. (Point 2 Int -> action) -> Attribute action
onMouseClickAt = MisoString
-> Decoder (Point 2 Int)
-> (Point 2 Int -> action)
-> Attribute action
forall r action.
MisoString -> Decoder r -> (r -> action) -> Attribute action
on MisoString
"click" Decoder (Point 2 Int)
mousePositionDecoder

-- | Mouse position decoder that captures the position of the event relative to the
-- target. In particular, it reads the offsetX and offsetY values of the event.
mousePositionDecoder :: Decoder (Point 2 Int)
mousePositionDecoder :: Decoder (Point 2 Int)
mousePositionDecoder = (Value -> Parser (Point 2 Int))
-> DecodeTarget -> Decoder (Point 2 Int)
forall a. (Value -> Parser a) -> DecodeTarget -> Decoder a
Decoder Value -> Parser (Point 2 Int)
dec DecodeTarget
dt
  where
    dt :: DecodeTarget
dt = [MisoString] -> DecodeTarget
DecodeTarget [MisoString]
forall a. Monoid a => a
mempty
    dec :: Value -> Parser (Point 2 Int)
dec = String
-> (Object -> Parser (Point 2 Int))
-> Value
-> Parser (Point 2 Int)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"event" ((Object -> Parser (Point 2 Int)) -> Value -> Parser (Point 2 Int))
-> (Object -> Parser (Point 2 Int))
-> Value
-> Parser (Point 2 Int)
forall a b. (a -> b) -> a -> b
$ \Object
o -> Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 (Int -> Int -> Point 2 Int)
-> Parser Int -> Parser (Int -> Point 2 Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"offsetX" Parser (Int -> Point 2 Int) -> Parser Int -> Parser (Point 2 Int)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"offsetY"

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

-- | On start of a touch event,
onTouchStartAt :: (Point 2 Int -> action) -> Attribute action
onTouchStartAt :: forall action. (Point 2 Int -> action) -> Attribute action
onTouchStartAt = MisoString
-> Decoder (Point 2 Int)
-> (Point 2 Int -> action)
-> Attribute action
forall action.
MisoString
-> Decoder (Point 2 Int)
-> (Point 2 Int -> action)
-> Attribute action
onRelativeTo MisoString
"touchstart" Decoder (Point 2 Int)
touchDecoder

-- | On touchMove event
onTouchMoveAt :: (Point 2 Int -> action) -> Attribute action
onTouchMoveAt :: forall action. (Point 2 Int -> action) -> Attribute action
onTouchMoveAt = MisoString
-> Decoder (Point 2 Int)
-> (Point 2 Int -> action)
-> Attribute action
forall action.
MisoString
-> Decoder (Point 2 Int)
-> (Point 2 Int -> action)
-> Attribute action
onRelativeTo MisoString
"touchmove" Decoder (Point 2 Int)
touchDecoder

-- | onTouchEnd event
onTouchEnd     :: action -> Attribute action
onTouchEnd :: forall action. action -> Attribute action
onTouchEnd action
act = MisoString -> Decoder () -> (() -> action) -> Attribute action
forall r action.
MisoString -> Decoder r -> (r -> action) -> Attribute action
on MisoString
"touchend" Decoder ()
emptyDecoder (action -> () -> action
forall a b. a -> b -> a
const action
act)


touchDecoder :: Decoder (Point 2 Int)
touchDecoder :: Decoder (Point 2 Int)
touchDecoder = (Value -> Parser (Point 2 Int))
-> DecodeTarget -> Decoder (Point 2 Int)
forall a. (Value -> Parser a) -> DecodeTarget -> Decoder a
Decoder Value -> Parser (Point 2 Int)
dec DecodeTarget
dt
  where
    dt :: DecodeTarget
dt = [MisoString] -> DecodeTarget
DecodeTarget [MisoString
"targetTouches"]
    dec :: Value -> Parser (Point 2 Int)
    dec :: Value -> Parser (Point 2 Int)
dec = String
-> (Array -> Parser (Point 2 Int)) -> Value -> Parser (Point 2 Int)
forall a. String -> (Array -> Parser a) -> Value -> Parser a
withArray String
"targetTouches" ((Array -> Parser (Point 2 Int)) -> Value -> Parser (Point 2 Int))
-> (Array -> Parser (Point 2 Int)) -> Value -> Parser (Point 2 Int)
forall a b. (a -> b) -> a -> b
$ \Array
arr -> case Array -> [Value]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList Array
arr of
      (Value
tv:[Value]
_) -> ((Object -> Parser (Point 2 Int)) -> Value -> Parser (Point 2 Int))
-> Value
-> (Object -> Parser (Point 2 Int))
-> Parser (Point 2 Int)
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String
-> (Object -> Parser (Point 2 Int))
-> Value
-> Parser (Point 2 Int)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"touch") Value
tv ((Object -> Parser (Point 2 Int)) -> Parser (Point 2 Int))
-> (Object -> Parser (Point 2 Int)) -> Parser (Point 2 Int)
forall a b. (a -> b) -> a -> b
$ \Object
t ->
                  Int -> Int -> Point 2 Int
forall r. r -> r -> Point 2 r
Point2 (Int -> Int -> Point 2 Int)
-> Parser Int -> Parser (Int -> Point 2 Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
t Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"clientX"   Parser (Int -> Point 2 Int) -> Parser Int -> Parser (Point 2 Int)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
t Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"clientY"
      [Value]
_      -> String -> Parser (Point 2 Int)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"touchDecoder: expected at least one targetTouches"


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

-- -- | A DOMRect
-- data DOMRect = DOMRect { top    :: {-# UNPACK #-} !Int
--                        , left   :: {-# UNPACK #-} !Int
--                        , width  :: {-# UNPACK #-} !Int
--                        , height :: {-# UNPACK #-} !Int
--                        } deriving (Show,Eq)

-- getBoundingRect       :: JSVal -> JSM DOMRect
-- getBoundingRect elem' = do
--     rect  <- Object <$> getBoundingClientRect elem'
--     Just l <- fromJSVal =<< getProp "left"    rect
--     Just t <- fromJSVal =<< getProp "top"     rect
--     Just w <- fromJSVal =<< getProp "width"   rect
--     Just h <- fromJSVal =<< getProp "height"  rect
--     pure $ DOMRect l t w h

-- -- | Get the inner rectangle of an element (i.e. without its border) relative to the
-- -- viewport.
-- getInnerRect       :: JSVal -> JSM DOMRect
-- getInnerRect elem' = do
--   Just cl <- fromJSVal =<< getProp "clientLeft"   (Object elem')
--   Just ct <- fromJSVal =<< getProp "clientTop"    (Object elem')
--   Just cr <- fromJSVal =<< getProp "clientRight"  (Object elem')
--   Just cb <- fromJSVal =<< getProp "clientBottom" (Object elem')
--   DOMRect l t w h <- getBoundingRect elem'
--   pure $ DOMRect (l-cl) (t-ct) (w - cr) (h - cb)


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

-- | A version of onWithOptions that also decodes the left, top, and clientLeft and clientTop
-- values of the target element.
onRelativeTo :: MisoString -> Decoder (Point 2 Int) -> (Point 2 Int -> action)
                -> Attribute action
onRelativeTo :: forall action.
MisoString
-> Decoder (Point 2 Int)
-> (Point 2 Int -> action)
-> Attribute action
onRelativeTo MisoString
eventName Decoder{DecodeTarget
Value -> Parser (Point 2 Int)
decoder :: Value -> Parser (Point 2 Int)
decodeAt :: DecodeTarget
decoder :: forall a. Decoder a -> Value -> Parser a
decodeAt :: forall a. Decoder a -> DecodeTarget
..} Point 2 Int -> action
toAction =
    (Sink action -> Object -> JSM ()) -> Attribute action
forall action.
(Sink action -> Object -> JSM ()) -> Attribute action
E ((Sink action -> Object -> JSM ()) -> Attribute action)
-> (Sink action -> Object -> JSM ()) -> Attribute action
forall a b. (a -> b) -> a -> b
$ \Sink action
sink Object
n -> do
     JSVal
eventObj <- JSString -> Object -> JSM JSVal
getProp JSString
"events" Object
n
     eventHandlerObject :: Object
eventHandlerObject@(Object JSVal
eo) <- JSM Object
create
     JSVal
jsOptions <- Options -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal Options
options
     JSVal
decodeAtVal <- DecodeTarget -> JSM JSVal
forall a. ToJSVal a => a -> JSM JSVal
toJSVal DecodeTarget
decodeAt
     JSVal
cb <- Function -> JSM JSVal
callbackToJSVal (Function -> JSM JSVal)
-> ((JSVal -> JSM ()) -> JSM Function)
-> (JSVal -> JSM ())
-> JSM JSVal
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< (JSVal -> JSM ()) -> JSM Function
asyncCallback1 ((JSVal -> JSM ()) -> JSM JSVal) -> (JSVal -> JSM ()) -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ \JSVal
event -> do
         Just JSVal
target <- JSVal -> JSM (Maybe JSVal)
forall a. FromJSVal a => JSVal -> JSM (Maybe a)
fromJSVal (JSVal -> JSM (Maybe JSVal)) -> JSM JSVal -> JSM (Maybe JSVal)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSString -> Object -> JSM JSVal
unsafeGetProp JSString
"target" (JSVal -> Object
Object JSVal
event)
         Object
rect        <- JSVal -> Object
Object (JSVal -> Object) -> JSM JSVal -> JSM Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JSVal -> JSM JSVal
getBoundingClientRect JSVal
target
         Just Int
l      <- JSVal -> JSM (Maybe Int)
forall a. FromJSVal a => JSVal -> JSM (Maybe a)
fromJSVal (JSVal -> JSM (Maybe Int)) -> JSM JSVal -> JSM (Maybe Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSString -> Object -> JSM JSVal
unsafeGetProp JSString
"left"    Object
rect
         Just Int
t      <- JSVal -> JSM (Maybe Int)
forall a. FromJSVal a => JSVal -> JSM (Maybe a)
fromJSVal (JSVal -> JSM (Maybe Int)) -> JSM JSVal -> JSM (Maybe Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSString -> Object -> JSM JSVal
unsafeGetProp JSString
"top"     Object
rect
         Just Int
cl     <- JSVal -> JSM (Maybe Int)
forall a. FromJSVal a => JSVal -> JSM (Maybe a)
fromJSVal (JSVal -> JSM (Maybe Int)) -> JSM JSVal -> JSM (Maybe Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSString -> Object -> JSM JSVal
unsafeGetProp JSString
"clientLeft" (JSVal -> Object
Object JSVal
target)
         Just Int
ct     <- JSVal -> JSM (Maybe Int)
forall a. FromJSVal a => JSVal -> JSM (Maybe a)
fromJSVal (JSVal -> JSM (Maybe Int)) -> JSM JSVal -> JSM (Maybe Int)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSString -> Object -> JSM JSVal
unsafeGetProp JSString
"clientTop"  (JSVal -> Object
Object JSVal
target)
         Just Value
v      <- JSVal -> JSM (Maybe Value)
forall a. FromJSVal a => JSVal -> JSM (Maybe a)
fromJSVal (JSVal -> JSM (Maybe Value)) -> JSM JSVal -> JSM (Maybe Value)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal -> JSVal -> JSM JSVal
objectToJSON JSVal
decodeAtVal JSVal
event
         case (Value -> Parser (Point 2 Int))
-> Value -> Either String (Point 2 Int)
forall a b. (a -> Parser b) -> a -> Either String b
parseEither Value -> Parser (Point 2 Int)
decoder Value
v of
           Left String
s  -> String -> JSM ()
forall a. HasCallStack => String -> a
error (String -> JSM ()) -> String -> JSM ()
forall a b. (a -> b) -> a -> b
$ String
"Parse error on " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> MisoString -> String
unpack MisoString
eventName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s
           Right Point 2 Int
p -> do let p' :: Point 2 Int
p' = Point 2 Int
p Point 2 Int -> Vector 2 Int -> Point 2 Int
forall point (d :: Nat) r.
(Affine_ point d r, Num r) =>
point -> Vector d r -> point
.-^ Int -> Int -> Vector 2 Int
forall r. r -> r -> Vector 2 r
Vector2 (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
cl) (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
ct)
                         IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall a. Show a => a -> IO ()
print (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ MisoString -> String
forall a. Show a => a -> String
show MisoString
eventName String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Int, Int, Int, Int, Point 2 Int, Point 2 Int) -> String
forall a. Show a => a -> String
show (Int
l,Int
t,Int
cl,Int
ct,Point 2 Int
p, Point 2 Int
p')
                         IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ Sink action
sink (Point 2 Int -> action
toAction Point 2 Int
p')
     MisoString -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"runEvent" JSVal
cb Object
eventHandlerObject
     JSVal -> JSM ()
registerCallback JSVal
cb
     MisoString -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
"options" JSVal
jsOptions Object
eventHandlerObject
     MisoString -> JSVal -> Object -> JSM ()
forall v. ToJSVal v => MisoString -> v -> Object -> JSM ()
set MisoString
eventName JSVal
eo (JSVal -> Object
Object JSVal
eventObj)
  where
    options :: Options
options = Options
defaultOptions { preventDefault  = True
                             , stopPropagation = False
                             }