module React.Flux.PropertiesAndEvents (
PropertyOrHandler
, property
, elementProperty
, nestedProperty
, CallbackFunction
, callback
, callbackView
, ArgumentsToProps
, ReturnProps(..)
, callbackViewWithProps
, (@=)
, ($=)
, (&=)
, 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 Data.Typeable (Typeable)
import Data.Monoid ((<>))
import qualified Data.Text as T
import qualified Data.Aeson as A
import qualified Data.HashMap.Strict as M
import Data.Word
import Data.Int
import React.Flux.Internal
import React.Flux.Store
import React.Flux.Views (ReactView(..), ViewEventHandler, StatefulViewEventHandler, ArgumentsToProps(..), ReturnProps(..))
#ifdef __GHCJS__
import Data.Maybe (fromMaybe)
import GHCJS.Foreign (fromJSBool)
import GHCJS.Marshal (FromJSVal(..))
import GHCJS.Types (JSVal, nullRef, IsJSVal)
import JavaScript.Array as JSA
import qualified Data.JSString.Text as JSS
#else
type JSVal = ()
type JSArray = ()
class FromJSVal a
instance FromJSVal ()
instance FromJSVal a => FromJSVal [a]
instance FromJSVal a => FromJSVal (Maybe a)
instance FromJSVal T.Text
instance FromJSVal Char
instance FromJSVal Bool
instance FromJSVal Int
instance FromJSVal Int8
instance FromJSVal Int16
instance FromJSVal Int32
instance FromJSVal Word
instance FromJSVal Word8
instance FromJSVal Word16
instance FromJSVal Word32
instance FromJSVal Float
instance FromJSVal Double
instance FromJSVal A.Value
instance (FromJSVal a, FromJSVal b) => FromJSVal (a,b)
instance (FromJSVal a, FromJSVal b, FromJSVal c) => FromJSVal (a,b,c)
instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d) => FromJSVal (a,b,c,d)
instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e) => FromJSVal (a,b,c,d,e)
instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJSVal f) => FromJSVal (a,b,c,d,e,f)
instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJSVal f, FromJSVal g) => FromJSVal (a,b,c,d,e,f,g)
instance (FromJSVal a, FromJSVal b, FromJSVal c, FromJSVal d, FromJSVal e, FromJSVal f, FromJSVal g, FromJSVal h) => FromJSVal (a,b,c,d,e,f,g,h)
class IsJSVal a
nullRef :: ()
nullRef = ()
#endif
elementProperty :: JSString -> ReactElementM handler () -> PropertyOrHandler handler
elementProperty = ElementProperty
nestedProperty :: JSString -> [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 => JSString -> func -> PropertyOrHandler handler
callback name func = CallbackPropertyWithArgumentArray name $ \arr -> applyFromArguments arr 0 func
callbackView :: JSString -> ReactView () -> PropertyOrHandler handler
callbackView name v = CallbackPropertyReturningView name (const $ return ()) (reactView v)
callbackViewWithProps :: (Typeable props, ArgumentsToProps props func) => JSString -> ReactView props -> func -> PropertyOrHandler handler
callbackViewWithProps name v func = CallbackPropertyReturningView name (\arr -> returnViewFromArguments arr 0 func) (reactView v)
(@=) :: A.ToJSON a => JSString -> a -> PropertyOrHandler handler
n @= a = Property n (A.toJSON a)
($=) :: JSString -> JSString -> PropertyOrHandler handler
n $= a = Property 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 -> JSString -> val
eventTargetProp (EventTarget ref) key = ref .: key
data Event = Event
{ evtType :: T.Text
, evtBubbles :: Bool
, evtCancelable :: Bool
, evtCurrentTarget :: EventTarget
, evtDefaultPrevented :: Bool
, evtPhase :: Int
, evtIsTrusted :: Bool
, evtTarget :: EventTarget
, evtTimestamp :: Int
, evtHandlerArg :: HandlerArg
} deriving (Show)
target :: FromJSVal val => Event -> JSString -> 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 :: JSString -> (Event -> handler) -> PropertyOrHandler handler
on name f = CallbackPropertyWithSingleArgument
{ csPropertyName = name
, csFunc = f . parseEvent
}
on2 :: JSString
-> (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 :: T.Text -> Bool
, keyKey :: T.Text
, keyCode :: Int
, keyLocale :: Maybe T.Text
, 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 :: T.Text -> 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 :: T.Text -> 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 -> T.Text -> Bool
getModifierState ref = fromJSBool . js_GetModifierState ref . JSS.textToJSString
arrayLength :: JSArray -> Int
arrayLength = JSA.length
arrayIndex :: Int -> JSArray -> JSVal
arrayIndex = JSA.index
#else
js_getProp :: a -> JSString -> JSVal
js_getProp _ _ = ()
js_getArrayProp :: a -> JSString -> JSVal
js_getArrayProp _ _ = ()
(.:) :: JSVal -> JSString -> b
_ .: _ = undefined
getModifierState :: JSVal -> T.Text -> Bool
getModifierState _ _ = False
arrayLength :: JSArray -> Int
arrayLength _ = 0
arrayIndex :: Int -> JSArray -> JSVal
arrayIndex _ _ = ()
#endif