module React.Flux.PropertiesAndEvents (
PropertyOrHandler
, property
, elementProperty
, nestedProperty
, CallbackFunction
, callback
, (@=)
, ($=)
, classNames
, Event(..)
, EventTarget(..)
, eventTargetProp
, target
, preventDefault
, stopPropagation
, capturePhase
, on
, 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 qualified Data.HashMap.Strict as M
import React.Flux.Internal
import React.Flux.Store
import React.Flux.Views (ViewEventHandler, StatefulViewEventHandler)
#ifdef __GHCJS__
import Data.Maybe (fromMaybe)
import GHCJS.Foreign (fromJSBool)
import GHCJS.Marshal (FromJSVal(..))
import GHCJS.Types (JSVal, nullRef, JSString, IsJSVal)
import JavaScript.Array as JSA
#else
type JSVal = ()
type JSString = String
type JSArray = ()
class FromJSVal a
class IsJSVal a
nullRef :: ()
nullRef = ()
#endif
elementProperty :: String -> ReactElementM handler () -> PropertyOrHandler handler
elementProperty = ElementProperty
nestedProperty :: String -> [PropertyOrHandler handler] -> PropertyOrHandler handler
nestedProperty = NestedProperty
class CallbackFunction handler a | a -> handler where
applyFromArguments :: JSArray -> Int -> a -> IO handler
instance CallbackFunction ViewEventHandler ViewEventHandler where
applyFromArguments _ _ h = return h
instance CallbackFunction (StatefulViewEventHandler s) (StatefulViewEventHandler s) where
applyFromArguments _ _ h = return h
instance (FromJSVal a, CallbackFunction handler b) => CallbackFunction handler (a -> b) where
#if __GHCJS__
applyFromArguments args k f = do
ma <- fromJSVal $ if k >= JSA.length args then nullRef else JSA.index k args
a <- maybe (error "Unable to decode callback argument") return ma
applyFromArguments args (k+1) $ f a
#else
applyFromArguments _ _ _ = error "Not supported in GHC"
#endif
callback :: CallbackFunction handler func => String -> func -> PropertyOrHandler handler
callback name func = CallbackPropertyWithArgumentArray name $ \arr -> applyFromArguments arr 0 func
(@=) :: A.ToJSON a => T.Text -> a -> PropertyOrHandler handler
n @= a = Property (T.unpack n) (A.toJSON a)
($=) :: T.Text -> T.Text -> PropertyOrHandler handler
n $= a = Property (T.unpack n) a
classNames :: [(T.Text, Bool)] -> PropertyOrHandler handler
classNames xs = "className" @= T.intercalate " " names
where
names = M.keys $ M.filter id $ M.fromList xs
newtype EventTarget = EventTarget JSVal
instance IsJSVal EventTarget
instance Show (EventTarget) where
show _ = "EventTarget"
eventTargetProp :: FromJSVal 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 :: FromJSVal 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 -> (Event -> handler) -> PropertyOrHandler handler
on name f = CallbackPropertyWithSingleArgument
{ csPropertyName = name
, csFunc = f . parseEvent
}
on2 :: String
-> (HandlerArg -> detail)
-> (Event -> detail -> handler)
-> PropertyOrHandler handler
on2 name parseDetail f = CallbackPropertyWithSingleArgument
{ csPropertyName = name
, csFunc = \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 :: JSVal -> IO ()
foreign import javascript unsafe
"$1['stopPropagation']();"
js_stopProp :: JSVal -> 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 (CallbackPropertyWithSingleArgument n h) = CallbackPropertyWithSingleArgument (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 = on2 "onKeyDown" parseKeyboardEvent
onKeyPress :: (Event -> KeyboardEvent -> handler) -> PropertyOrHandler handler
onKeyPress = on2 "onKeyPress" parseKeyboardEvent
onKeyUp :: (Event -> KeyboardEvent -> handler) -> PropertyOrHandler handler
onKeyUp = on2 "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 = on2 "onBlur" parseFocusEvent
onFocus :: (Event -> FocusEvent -> handler) -> PropertyOrHandler handler
onFocus = on2 "onFocus" parseFocusEvent
onChange :: (Event -> handler) -> PropertyOrHandler handler
onChange = on "onChange"
onInput :: (Event -> handler) -> PropertyOrHandler handler
onInput = on "onInput"
onSubmit :: (Event -> handler) -> PropertyOrHandler handler
onSubmit = on "onSubmit"
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 = on2 "onClick" parseMouseEvent
onContextMenu :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onContextMenu = on2 "onContextMenu" parseMouseEvent
onDoubleClick :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDoubleClick = on2 "onDoubleClick" parseMouseEvent
onDrag :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDrag = on2 "onDrag" parseMouseEvent
onDragEnd :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDragEnd = on2 "onDragEnd" parseMouseEvent
onDragEnter :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDragEnter = on2 "onDragEnter" parseMouseEvent
onDragExit :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDragExit = on2 "onDragExit" parseMouseEvent
onDragLeave :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDragLeave = on2 "onDragLeave" parseMouseEvent
onDragOver :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDragOver = on2 "onDragOver" parseMouseEvent
onDragStart :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDragStart = on2 "onDragStart" parseMouseEvent
onDrop :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onDrop = on2 "onDrop" parseMouseEvent
onMouseDown :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onMouseDown = on2 "onMouseDown" parseMouseEvent
onMouseEnter :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onMouseEnter = on2 "onMouseEnter" parseMouseEvent
onMouseLeave :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onMouseLeave = on2 "onMouseLeave" parseMouseEvent
onMouseMove :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onMouseMove = on2 "onMouseMove" parseMouseEvent
onMouseOut :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onMouseOut = on2 "onMouseOut" parseMouseEvent
onMouseOver :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onMouseOver = on2 "onMouseOver" parseMouseEvent
onMouseUp :: (Event -> MouseEvent -> handler) -> PropertyOrHandler handler
onMouseUp = on2 "onMouseUp" parseMouseEvent
#ifdef __GHCJS__
foreign import javascript unsafe
"React['initializeTouchEvents'] ? React['initializeTouchEvents'](true) : null"
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 :: JSVal -> 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 :: JSVal -> 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 = on2 "onTouchCancel" parseTouchEvent
onTouchEnd :: (Event -> TouchEvent -> handler) -> PropertyOrHandler handler
onTouchEnd = on2 "onTouchEnd" parseTouchEvent
onTouchMove :: (Event -> TouchEvent -> handler) -> PropertyOrHandler handler
onTouchMove = on2 "onTouchMove" parseTouchEvent
onTouchStart :: (Event -> TouchEvent -> handler) -> PropertyOrHandler handler
onTouchStart = on2 "onTouchStart" parseTouchEvent
onScroll :: (Event -> handler) -> PropertyOrHandler handler
onScroll = on "onScroll"
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 = CallbackPropertyWithSingleArgument
{ csPropertyName = "onWheel"
, csFunc = \raw -> f (parseEvent raw) (parseMouseEvent raw) (parseWheelEvent raw)
}
onLoad :: (Event -> handler) -> PropertyOrHandler handler
onLoad = on "onLoad"
onError :: (Event -> handler) -> PropertyOrHandler handler
onError = on "onError"
#ifdef __GHCJS__
foreign import javascript unsafe
"$1[$2]"
js_getProp :: JSVal -> JSString -> JSVal
foreign import javascript unsafe
"$1[$2]"
js_getArrayProp :: JSVal -> JSString -> JSArray
(.:) :: FromJSVal b => JSVal -> JSString -> b
obj .: key = fromMaybe (error "Unable to decode event target") $ unsafePerformIO $
fromJSVal $ js_getProp obj key
foreign import javascript unsafe
"$1['getModifierState']($2)"
js_GetModifierState :: JSVal -> JSString -> JSVal
getModifierState :: JSVal -> String -> Bool
getModifierState ref = fromJSBool . js_GetModifierState ref . toJSString
arrayLength :: JSArray -> Int
arrayLength = JSA.length
arrayIndex :: Int -> JSArray -> JSVal
arrayIndex = JSA.index
#else
js_getProp :: a -> String -> JSVal
js_getProp _ _ = ()
js_getArrayProp :: a -> String -> JSVal
js_getArrayProp _ _ = ()
(.:) :: JSVal -> String -> b
_ .: _ = undefined
getModifierState :: JSVal -> String -> Bool
getModifierState _ _ = False
arrayLength :: JSArray -> Int
arrayLength _ = 0
arrayIndex :: Int -> JSArray -> JSVal
arrayIndex _ _ = ()
#endif