{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Redundant lambda" #-}
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)
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
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
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
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"
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
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 :: 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"
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
}