module Glazier.React.Event
( DOMEventTarget
, DOMEvent
, SyntheticEvent
, eventHandler
, eventHandlerM
, Event(..)
, preventDefault
, isDefaultPrevented
, stopPropagation
, isPropagationStopped
, parseEvent
, MouseEvent(..)
, parseMouseEvent
, KeyboardEvent(..)
, parseKeyboardEvent
)
where
import Control.DeepSeq
import qualified Data.JSString as J
import qualified GHCJS.Foreign as J
import qualified GHCJS.Marshal.Pure as J
import qualified GHCJS.Types as J
import qualified JavaScript.Extras.Cast as JE
newtype DOMEventTarget = DOMEventTarget J.JSVal
instance J.IsJSVal DOMEventTarget
instance J.PToJSVal DOMEventTarget where
pToJSVal = J.jsval
instance JE.ToJS DOMEventTarget
instance JE.FromJS DOMEventTarget where
fromJS a | js_isDOMEventTarget a = Just $ DOMEventTarget a
fromJS _ = Nothing
newtype DOMEvent = DOMEvent J.JSVal
instance J.IsJSVal DOMEvent
instance J.PToJSVal DOMEvent where
pToJSVal = J.jsval
instance JE.ToJS DOMEvent
instance JE.FromJS DOMEvent where
fromJS a | js_isDOMEvent a = Just $ DOMEvent a
fromJS _ = Nothing
newtype SyntheticEvent = SyntheticEvent J.JSVal
instance J.IsJSVal SyntheticEvent
instance J.PToJSVal SyntheticEvent where
pToJSVal = J.jsval
instance JE.ToJS SyntheticEvent
instance JE.FromJS SyntheticEvent where
fromJS a | js_isSyntheticEvent a = Just $ SyntheticEvent a
fromJS _ = Nothing
eventHandler :: NFData a => (evt -> a) -> (a -> b) -> (evt -> b)
eventHandler goStrict goLazy evt = goLazy $!! goStrict evt
eventHandlerM :: (Monad m, NFData a) => (evt -> m a) -> (a -> m b) -> (evt -> m b)
eventHandlerM goStrict goLazy evt = do
r <- goStrict evt
goLazy $!! r
preventDefault :: SyntheticEvent -> IO ()
preventDefault = js_preventDefault
isDefaultPrevented :: SyntheticEvent -> Bool
isDefaultPrevented = js_isDefaultPrevented
stopPropagation :: SyntheticEvent -> IO ()
stopPropagation = js_stopPropagation
isPropagationStopped :: SyntheticEvent -> Bool
isPropagationStopped = js_isPropagationStopped
data Event = Event
{ bubbles :: Bool
, cancelable :: Bool
, currentTarget :: DOMEventTarget
, defaultPrevented :: Bool
, eventPhase :: Int
, isTrusted :: Bool
, nativeEvent :: DOMEvent
, target :: DOMEventTarget
, timeStamp :: Int
, eventType :: J.JSString
}
unsafeProperty :: J.PFromJSVal a => J.JSVal -> J.JSString -> a
unsafeProperty v = J.pFromJSVal . js_unsafeProperty v
parseEvent :: SyntheticEvent -> Event
parseEvent (SyntheticEvent evt) =
Event
{ bubbles = unsafeProperty evt "bubbles"
, cancelable = unsafeProperty evt "cancelable"
, currentTarget = DOMEventTarget $ js_unsafeProperty evt "currentTarget"
, defaultPrevented = unsafeProperty evt "defaultPrevented"
, eventPhase = unsafeProperty evt "eventPhase"
, isTrusted = unsafeProperty evt "isTrusted"
, nativeEvent = DOMEvent evt
, target = DOMEventTarget $ js_unsafeProperty evt "target"
, timeStamp = unsafeProperty evt "timeStamp"
, eventType = unsafeProperty evt "type"
}
data MouseEvent = MouseEvent
{ altKey :: Bool
, button :: Int
, buttons :: Int
, clientX :: Int
, clientY :: Int
, ctrlKey :: Bool
, getModifierState :: J.JSString -> Bool
, metaKey :: Bool
, pageX :: Int
, pageY :: Int
, relatedTarget :: DOMEventTarget
, screenX :: Int
, screenY :: Int
, shiftKey :: Bool
}
unsafeGetModifierState :: J.JSVal -> J.JSString -> Bool
unsafeGetModifierState obj k = J.fromJSBool $ js_unsafeGetModifierState obj k
parseMouseEvent :: SyntheticEvent -> Maybe MouseEvent
parseMouseEvent (SyntheticEvent evt) | js_isMouseEvent (js_unsafeProperty evt "nativeEvent") = Just $
MouseEvent
{ altKey = unsafeProperty evt "altKey"
, button = unsafeProperty evt "button"
, buttons = unsafeProperty evt "buttons"
, clientX = unsafeProperty evt "clientX"
, clientY = unsafeProperty evt "clientY"
, ctrlKey = unsafeProperty evt "ctrlKey"
, getModifierState = unsafeGetModifierState evt
, metaKey = unsafeProperty evt "metaKey"
, pageX = unsafeProperty evt "pageX"
, pageY = unsafeProperty evt "pageY"
, relatedTarget = DOMEventTarget $ js_unsafeProperty evt "relatedTarget"
, screenX = unsafeProperty evt "screenX"
, screenY = unsafeProperty evt "xcreenY"
, shiftKey = unsafeProperty evt "shiftKey"
}
parseMouseEvent _ | otherwise = Nothing
data KeyboardEvent = KeyboardEvent
{ altKey :: Bool
, charCode ::Int
, ctrlKey :: Bool
, getModifierState :: J.JSString -> Bool
, key :: J.JSString
, keyCode :: Int
, locale :: J.JSString
, location ::Int
, metaKey :: Bool
, repeat :: Bool
, shiftkey :: Bool
, which :: Int
}
parseKeyboardEvent :: SyntheticEvent -> Maybe KeyboardEvent
parseKeyboardEvent (SyntheticEvent evt) | js_isKeyboardEvent (js_unsafeProperty evt "nativeEvent") = Just $
KeyboardEvent
{ altKey = unsafeProperty evt "altKey"
, charCode = unsafeProperty evt "charCode"
, ctrlKey = unsafeProperty evt "ctrlKey"
, getModifierState = unsafeGetModifierState evt
, key = unsafeProperty evt "key"
, keyCode = unsafeProperty evt "keyCode"
, locale = unsafeProperty evt "locale"
, location = unsafeProperty evt "location"
, metaKey = unsafeProperty evt "metaKey"
, repeat = unsafeProperty evt "repeat"
, shiftkey = unsafeProperty evt "shiftkey"
, which = unsafeProperty evt "which"
}
parseKeyboardEvent _ | otherwise = Nothing
#ifdef __GHCJS__
foreign import javascript unsafe
"$1 instanceof EventTarget"
js_isDOMEventTarget :: J.JSVal -> Bool
foreign import javascript unsafe
"$1 instanceof Event"
js_isDOMEvent :: J.JSVal -> Bool
foreign import javascript unsafe
"($1 && $1['nativeEvent'] && $1['nativeEvent'] instanceof Event)"
js_isSyntheticEvent :: J.JSVal -> Bool
foreign import javascript unsafe
"$1['preventDefault']()"
js_preventDefault :: SyntheticEvent -> IO ()
foreign import javascript unsafe
"$1['isDefaultPrevented']()"
js_isDefaultPrevented :: SyntheticEvent -> Bool
foreign import javascript unsafe
"$1['stopPropagation']()"
js_stopPropagation :: SyntheticEvent -> IO ()
foreign import javascript unsafe
"$1['isPropagationStopped']()"
js_isPropagationStopped :: SyntheticEvent -> Bool
foreign import javascript unsafe "$1[$2]"
js_unsafeProperty :: J.JSVal -> J.JSString -> J.JSVal
foreign import javascript unsafe
"$1['getModifierState']($2)"
js_unsafeGetModifierState :: J.JSVal -> J.JSString -> J.JSVal
foreign import javascript unsafe
"($1 instanceof MouseEvent)"
js_isMouseEvent :: J.JSVal -> Bool
foreign import javascript unsafe
"($1 instanceof KeyboardEvent)"
js_isKeyboardEvent :: J.JSVal -> Bool
#else
js_isDOMEventTarget :: J.JSVal -> Bool
js_isDOMEventTarget _ = False
js_isDOMEvent :: J.JSVal -> Bool
js_isDOMEvent _ = False
js_isSyntheticEvent :: J.JSVal -> Bool
js_isSyntheticEvent _ = False
js_preventDefault :: SyntheticEvent -> IO ()
js_preventDefault _ = pure ()
js_isDefaultPrevented :: SyntheticEvent -> Bool
js_isDefaultPrevented _ = False
js_stopPropagation :: SyntheticEvent -> IO ()
js_stopPropagation _ = pure ()
js_isPropagationStopped :: SyntheticEvent -> Bool
js_isPropagationStopped _ = False
js_unsafeProperty :: J.JSVal -> J.JSString -> J.JSVal
js_unsafeProperty _ _ = J.nullRef
js_unsafeGetModifierState :: J.JSVal -> J.JSString -> J.JSVal
js_unsafeGetModifierState _ _ = J.nullRef
js_isMouseEvent :: J.JSVal -> Bool
js_isMouseEvent _ = False
js_isKeyboardEvent :: J.JSVal -> Bool
js_isKeyboardEvent _ = False
#endif