module React.Flux.PropertiesAndEvents (
PropertyOrHandler
, (@=)
, ($=)
, callback
, Event(..)
, EventTarget(..)
, eventTargetProp
, target
, preventDefault
, stopPropagation
, capturePhase
, KeyboardEvent(..)
, onKeyDown
, onKeyPress
, onKeyUp
, FocusEvent(..)
, onBlur
, onFocus
, onChange
, onInput
, onSubmit
, MouseEvent(..)
, onClick
, onContextMenu
, onDoubleClick
, onDrag
, onDragEnd
, onDragEnter
, onDragExit
, onDragLeave
, onDragOver
, onDragStart
, onDrop
, onMouseDown
, onMouseEnter
, onMouseLeave
, onMouseMove
, onMouseOut
, onMouseOver
, onMouseUp
, initializeTouchEvents
, Touch(..)
, TouchEvent(..)
, onTouchCancel
, onTouchEnd
, onTouchMove
, onTouchStart
, onScroll
, WheelEvent(..)
, onWheel
, onLoad
, onError
) where
import Control.Monad (forM)
import Control.Concurrent.MVar (newMVar)
import Control.DeepSeq
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Text as T
import qualified Data.Aeson as A
import React.Flux.Internal
import React.Flux.Store
#ifdef __GHCJS__
import Data.Maybe (fromMaybe)
import qualified Data.JSString as JSS
import GHCJS.Foreign (fromJSBool)
import GHCJS.Marshal (FromJSRef(..))
import GHCJS.Types (JSRef, nullRef, JSString)
import JavaScript.Array as JSA
#else
type JSRef a = ()
type JSString = String
type JSArray = ()
class FromJSRef a
nullRef :: ()
nullRef = ()
#endif
(@=) :: A.ToJSON a => T.Text -> a -> PropertyOrHandler handler
n @= a = Property (n, A.toJSON a)
($=) :: T.Text -> T.Text -> PropertyOrHandler handler
n $= a = Property (n, A.toJSON a)
callback :: String -> (A.Value -> handler) -> PropertyOrHandler handler
callback = CallbackProperty
newtype EventTarget = EventTarget (JSRef ())
instance Show (EventTarget) where
show _ = "EventTarget"
eventTargetProp :: FromJSRef val => EventTarget -> String -> val
eventTargetProp (EventTarget ref) key = ref .: toJSString key
data Event = Event
{ evtType :: String
, evtBubbles :: Bool
, evtCancelable :: Bool
, evtCurrentTarget :: EventTarget
, evtDefaultPrevented :: Bool
, evtPhase :: Int
, evtIsTrusted :: Bool
, evtTarget :: EventTarget
, evtTimestamp :: Int
, evtHandlerArg :: HandlerArg
} deriving (Show)
target :: FromJSRef val => Event -> String -> val
target e s = eventTargetProp (evtTarget e) s
parseEvent :: HandlerArg -> Event
parseEvent arg@(HandlerArg o) = Event
{ evtType = o .: "type"
, evtBubbles = o .: "bubbles"
, evtCancelable = o .: "cancelable"
, evtCurrentTarget = EventTarget $ js_getProp o "currentTarget"
, evtDefaultPrevented = o .: "defaultPrevented"
, evtPhase = o .: "eventPhase"
, evtIsTrusted = o .: "isTrusted"
, evtTarget = EventTarget $ js_getProp o "target"
, evtTimestamp = o .: "timeStamp"
, evtHandlerArg = arg
}
on :: String -> (HandlerArg -> handler) -> PropertyOrHandler handler
on = EventHandler
mkHandler :: String
-> (HandlerArg -> detail)
-> (Event -> detail -> handler)
-> PropertyOrHandler handler
mkHandler name parseDetail f = EventHandler
{ evtHandlerName = name
, evtHandler = \raw -> f (parseEvent raw) (parseDetail raw)
}
data FakeEventStoreData = FakeEventStoreData
fakeEventStore :: ReactStore FakeEventStoreData
fakeEventStore = unsafePerformIO (ReactStore (ReactStoreRef nullRef) <$> newMVar FakeEventStoreData)
data FakeEventStoreAction = PreventDefault HandlerArg
| StopPropagation HandlerArg
instance StoreData FakeEventStoreData where
type StoreAction FakeEventStoreData = FakeEventStoreAction
transform _ _ = return FakeEventStoreData
#ifdef __GHCJS__
instance NFData FakeEventStoreAction where
rnf (PreventDefault (HandlerArg ref)) = unsafePerformIO (js_preventDefault ref) `deepseq` ()
rnf (StopPropagation (HandlerArg ref)) = unsafePerformIO (js_stopProp ref) `deepseq` ()
foreign import javascript unsafe
"$1['preventDefault']();"
js_preventDefault :: JSRef () -> IO ()
foreign import javascript unsafe
"$1['stopPropagation']();"
js_stopProp :: JSRef () -> IO ()
#else
instance NFData FakeEventStoreAction where
rnf _ = ()
#endif
preventDefault :: Event -> SomeStoreAction
preventDefault = SomeStoreAction fakeEventStore . PreventDefault . evtHandlerArg
stopPropagation :: Event -> SomeStoreAction
stopPropagation = SomeStoreAction fakeEventStore . StopPropagation . evtHandlerArg
capturePhase :: PropertyOrHandler handler -> PropertyOrHandler handler
capturePhase (EventHandler n h) = EventHandler (n ++ "Capture") h
capturePhase _ = error "You must use React.Flux.PropertiesAndEvents.capturePhase on an event handler"
data KeyboardEvent = KeyboardEvent
{ keyEvtAltKey :: Bool
, keyEvtCharCode :: Int
, keyEvtCtrlKey :: Bool
, keyGetModifierState :: String -> Bool
, keyKey :: String
, keyCode :: Int
, keyLocale :: String
, keyLocation :: Int
, keyMetaKey :: Bool
, keyRepeat :: Bool
, keyShiftKey :: Bool
, keyWhich :: Int
}
instance Show KeyboardEvent where
show (KeyboardEvent k1 k2 k3 _ k4 k5 k6 k7 k8 k9 k10 k11) =
show (k1, k2, k3, k4, k5, k6, k7, k8, k9, k10, k11)
parseKeyboardEvent :: HandlerArg -> KeyboardEvent
parseKeyboardEvent (HandlerArg o) = KeyboardEvent
{ keyEvtAltKey = o .: "altKey"
, keyEvtCharCode = o .: "charCode"
, keyEvtCtrlKey = o .: "ctrlKey"
, keyGetModifierState = getModifierState o
, keyKey = o .: "key"
, keyCode = o .: "keyCode"
, keyLocale = o .: "locale"
, keyLocation = o .: "location"
, keyMetaKey = o .: "metaKey"
, keyRepeat = o .: "repeat"
, keyShiftKey = o .: "shiftKey"
, keyWhich = o .: "which"
}
onKeyDown :: (Event -> KeyboardEvent -> handler) -> PropertyOrHandler handler
onKeyDown = mkHandler "onKeyDown" parseKeyboardEvent
onKeyPress :: (Event -> KeyboardEvent -> handler) -> PropertyOrHandler handler
onKeyPress = mkHandler "onKeyPress" parseKeyboardEvent
onKeyUp :: (Event -> KeyboardEvent -> handler) -> PropertyOrHandler handler
onKeyUp = mkHandler "onKeyUp" parseKeyboardEvent
data FocusEvent = FocusEvent {
focusRelatedTarget :: EventTarget
} deriving (Show)
parseFocusEvent :: HandlerArg -> FocusEvent
parseFocusEvent (HandlerArg ref) = FocusEvent $ EventTarget $ js_getProp ref "relatedTarget"
onBlur :: (Event -> FocusEvent -> handler) -> PropertyOrHandler handler
onBlur = mkHandler "onBlur" parseFocusEvent
onFocus :: (Event -> FocusEvent -> handler) -> PropertyOrHandler handler
onFocus = mkHandler "onFocus" parseFocusEvent
onChange :: (Event -> handler) -> PropertyOrHandler handler
onChange f = on "onChange" (f . parseEvent)
onInput :: (Event -> handler) -> PropertyOrHandler handler
onInput f = on "onInput" (f . parseEvent)
onSubmit :: (Event -> handler) -> PropertyOrHandler handler
onSubmit f = on "onSubmit" (f . parseEvent)
data MouseEvent = MouseEvent
{ mouseAltKey :: Bool
, mouseButton :: Int
, mouseButtons :: Int
, mouseClientX :: Int
, mouseClientY :: Int
, mouseCtrlKey :: Bool
, mouseGetModifierState :: String -> Bool
, mouseMetaKey :: Bool
, mousePageX :: Int
, mousePageY :: Int
, mouseRelatedTarget :: EventTarget
, mouseScreenX :: Int
, mouseScreenY :: Int
, mouseShiftKey :: Bool
}
instance Show MouseEvent where
show (MouseEvent m1 m2 m3 m4 m5 m6 _ m7 m8 m9 m10 m11 m12 m13)
= show (m1, m2, m3, m4, m5, m6, m7, m8, m9, m10, m11, m12, m13)
parseMouseEvent :: HandlerArg -> MouseEvent
parseMouseEvent (HandlerArg o) = MouseEvent
{ mouseAltKey = o .: "altKey"
, mouseButton = o .: "button"
, mouseButtons = o .: "buttons"
, mouseClientX = o .: "clientX"
, mouseClientY = o .: "clientY"
, mouseCtrlKey = o .: "ctrlKey"
, mouseGetModifierState = getModifierState o
, mouseMetaKey = o .: "metaKey"
, mousePageX = o .: "pageX"
, mousePageY = o .: "pageY"
, mouseRelatedTarget = EventTarget $ js_getProp o "relatedTarget"
, mouseScreenX = o .: "screenX"
, mouseScreenY = o .: "screenY"
, mouseShiftKey = o .: "shiftKey"
}
onClick :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onClick = mkHandler "onClick" parseMouseEvent
onContextMenu :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onContextMenu = mkHandler "onContextMenu" parseMouseEvent
onDoubleClick :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDoubleClick = mkHandler "onDoubleClick" parseMouseEvent
onDrag :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDrag = mkHandler "onDrag" parseMouseEvent
onDragEnd :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDragEnd = mkHandler "onDragEnd" parseMouseEvent
onDragEnter :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDragEnter = mkHandler "onDragEnter" parseMouseEvent
onDragExit :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDragExit = mkHandler "onDragExit" parseMouseEvent
onDragLeave :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDragLeave = mkHandler "onDragLeave" parseMouseEvent
onDragOver :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDragOver = mkHandler "onDragOver" parseMouseEvent
onDragStart :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDragStart = mkHandler "onDragStart" parseMouseEvent
onDrop :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDrop = mkHandler "onDrop" parseMouseEvent
onMouseDown :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onMouseDown = mkHandler "onMouseDown" parseMouseEvent
onMouseEnter :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onMouseEnter = mkHandler "onMouseEnter" parseMouseEvent
onMouseLeave :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onMouseLeave = mkHandler "onMouseLeave" parseMouseEvent
onMouseMove :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onMouseMove = mkHandler "onMouseMove" parseMouseEvent
onMouseOut :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onMouseOut = mkHandler "onMouseOut" parseMouseEvent
onMouseOver :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onMouseOver = mkHandler "onMouseOver" parseMouseEvent
onMouseUp :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onMouseUp = mkHandler "onMouseUp" parseMouseEvent
#ifdef __GHCJS__
foreign import javascript unsafe
"React['initializeTouchEvents'](true)"
initializeTouchEvents :: IO ()
#else
initializeTouchEvents :: IO ()
initializeTouchEvents = return ()
#endif
data Touch = Touch {
touchIdentifier :: Int
, touchTarget :: EventTarget
, touchScreenX :: Int
, touchScreenY :: Int
, touchClientX :: Int
, touchClientY :: Int
, touchPageX :: Int
, touchPageY :: Int
} deriving (Show)
data TouchEvent = TouchEvent {
touchAltKey :: Bool
, changedTouches :: [Touch]
, touchCtrlKey :: Bool
, touchGetModifierState :: String -> Bool
, touchMetaKey :: Bool
, touchShiftKey :: Bool
, touchTargets :: [Touch]
, touches :: [Touch]
}
instance Show TouchEvent where
show (TouchEvent t1 t2 t3 _ t4 t5 t6 t7)
= show (t1, t2, t3, t4, t5, t6, t7)
parseTouch :: JSRef a -> Touch
parseTouch o = Touch
{ touchIdentifier = o .: "identifier"
, touchTarget = EventTarget $ js_getProp o "target"
, touchScreenX = o .: "screenX"
, touchScreenY = o .: "screenY"
, touchClientX = o .: "clientX"
, touchClientY = o .: "clientY"
, touchPageX = o .: "pageX"
, touchPageY = o .: "pageY"
}
parseTouchList :: JSRef a -> JSString -> [Touch]
parseTouchList obj key = unsafePerformIO $ do
let arr = js_getArrayProp obj key
len = arrayLength arr
forM [0..len1] $ \idx -> do
let jsref = arrayIndex idx arr
return $ parseTouch jsref
parseTouchEvent :: HandlerArg -> TouchEvent
parseTouchEvent (HandlerArg o) = TouchEvent
{ touchAltKey = o .: "altKey"
, changedTouches = parseTouchList o "changedTouches"
, touchCtrlKey = o .: "ctrlKey"
, touchGetModifierState = getModifierState o
, touchMetaKey = o .: "metaKey"
, touchShiftKey = o .: "shiftKey"
, touchTargets = parseTouchList o "targetTouches"
, touches = parseTouchList o "touches"
}
onTouchCancel :: (Event -> TouchEvent -> handler) -> PropertyOrHandler handler
onTouchCancel = mkHandler "onTouchCancel" parseTouchEvent
onTouchEnd :: (Event -> TouchEvent -> handler) -> PropertyOrHandler handler
onTouchEnd = mkHandler "onTouchEnd" parseTouchEvent
onTouchMove :: (Event -> TouchEvent -> handler) -> PropertyOrHandler handler
onTouchMove = mkHandler "onTouchMove" parseTouchEvent
onTouchStart :: (Event -> TouchEvent -> handler) -> PropertyOrHandler handler
onTouchStart = mkHandler "onTouchStart" parseTouchEvent
onScroll :: (Event -> handler) -> PropertyOrHandler handler
onScroll f = on "onScroll" (f . parseEvent)
data WheelEvent = WheelEvent {
wheelDeltaMode :: Int
, wheelDeltaX :: Int
, wheelDeltaY :: Int
, wheelDeltaZ :: Int
} deriving (Show)
parseWheelEvent :: HandlerArg -> WheelEvent
parseWheelEvent (HandlerArg o) = WheelEvent
{ wheelDeltaMode = o .: "deltaMode"
, wheelDeltaX = o .: "deltaX"
, wheelDeltaY = o .: "deltaY"
, wheelDeltaZ = o .: "deltaZ"
}
onWheel :: (Event -> MouseEvent -> WheelEvent -> handler) -> PropertyOrHandler handler
onWheel f = EventHandler
{ evtHandlerName = "onWheel"
, evtHandler = \raw -> f (parseEvent raw) (parseMouseEvent raw) (parseWheelEvent raw)
}
onLoad :: (Event -> handler) -> PropertyOrHandler handler
onLoad f = on "onLoad" (f . parseEvent)
onError :: (Event -> handler) -> PropertyOrHandler handler
onError f = on "onError" (f . parseEvent)
#ifdef __GHCJS__
foreign import javascript unsafe
"$1[$2]"
js_getProp :: JSRef a -> JSString -> JSRef b
foreign import javascript unsafe
"$1[$2]"
js_getArrayProp :: JSRef a -> JSString -> JSA.JSArray
(.:) :: FromJSRef b => JSRef a -> JSString -> b
obj .: key = fromMaybe (error "Unable to decode event target") $ unsafePerformIO $
fromJSRef $ js_getProp obj key
foreign import javascript unsafe
"$1['getModifierState']($2)"
js_GetModifierState :: JSRef () -> JSString -> JSRef Bool
getModifierState :: JSRef () -> String -> Bool
getModifierState ref = fromJSBool . js_GetModifierState ref . toJSString
arrayLength :: JSArray -> Int
arrayLength = JSA.length
arrayIndex :: Int -> JSArray -> JSRef a
arrayIndex = JSA.index
#else
js_getProp :: a -> String -> JSRef b
js_getProp _ _ = ()
js_getArrayProp :: a -> String -> JSRef b
js_getArrayProp _ _ = ()
(.:) :: JSRef () -> String -> b
_ .: _ = undefined
getModifierState :: JSRef () -> String -> Bool
getModifierState _ _ = False
arrayLength :: JSArray -> Int
arrayLength _ = 0
arrayIndex :: Int -> JSArray -> JSRef ()
arrayIndex _ _ = ()
#endif