-
Notifications
You must be signed in to change notification settings - Fork 0
/
Event.hs
330 lines (283 loc) · 11.5 KB
/
Event.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
{-# LANGUAGE CPP #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
-- | This module based on React/Flux/PropertiesAndEvents.hs.
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.Recast as JE
-- | The object that dispatched the event.
-- https://developer.mozilla.org/en-US/docs/Web/API/Event/target
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 = pure . Just $ DOMEventTarget a
fromJS _ = pure Nothing
-- | The native event
-- https://developer.mozilla.org/en-US/docs/Web/API/Event
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 = pure . Just $ DOMEvent a
fromJS _ = pure Nothing
-- | Every event in React is a synthetic event, a cross-browser wrapper around the native event.
-- 'SyntheticEvent' must only be used in the first part of 'eventHandler'.
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 = pure . Just $ SyntheticEvent a
fromJS _ = pure Nothing
-- | Using the NFData idea from React/Flux/PropertiesAndEvents.hs
-- React re-uses SyntheticEvent from a pool, which means it may no longer be valid if we lazily
-- parse it. However, we still want lazy parsing so we don't parse unnecessary fields.
-- This safe interface requires two input functions:
-- 1. a function to reduce SyntheticEvent to a NFData. The mkEventCallback will ensure that the
-- NFData is forced which will ensure all the required fields from Synthetic event has been parsed.
-- This function must not block.
-- 2. a second function that uses the NFData. This function is allowed to block.
-- mkEventHandler results in a function that you can safely pass into 'GHC.Foreign.Callback.syncCallback1'
-- with 'GHCJS.Foreign.Callback.ContinueAsync'.
-- The reason of this is because Javascript is single threaded, but Haskell is lazy.
-- Therefore GHCJS threads are a strange mixture of synchronous and asynchronous threads,
-- where a synchronous thread might be converted to an asynchronous thread if a "black hole" is encountered.
-- See https://github.com/ghcjs/ghcjs-base/blob/master/GHCJS/Concurrent.hs
eventHandler :: NFData a => (evt -> a) -> (a -> b) -> (evt -> b)
eventHandler goStrict goLazy evt = goLazy $!! goStrict evt
-- | a monadic version of eventHandler
-- The monad's effects must not block!
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
-- | Every `SyntheticEvent` can be parsed to an `Event`.
-- 'Event' must only be used in the first part of 'eventHandler'.
data Event = Event
{ bubbles :: Bool
, cancelable :: Bool
, currentTarget :: DOMEventTarget
, defaultPrevented :: Bool
, eventPhase :: Int
, isTrusted :: Bool
, nativeEvent :: DOMEvent
, target :: DOMEventTarget
, timeStamp :: Int
-- type is a reserved word, so prefix to eventType
, eventType :: J.JSString
}
-- | We can lie about this not being in IO because
-- within the strict part of 'eventHandlerM'
-- the SyntheticEvent is effectively immutable.
-- In reality SyntheticEvent is reused from a pool.
-- We want to maintain this lie so that we can lazily parse only the
-- properties the event handler is interested in.
-- This will throw if J.JSVal is null, or not convertible to the desired type
-- so we are assuming that SyntheticEvent will behave nicely.
unsafeProperty :: J.PFromJSVal a => J.JSVal -> J.JSString -> a
unsafeProperty v = J.pFromJSVal . js_unsafeProperty v
parseEvent :: SyntheticEvent -> IO Event
parseEvent (SyntheticEvent evt) =
pure $ 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"
}
-- | Mouse and Drag/Drop events
-- 'MouseEvent' must only be used in the first part of 'eventHandler'.
-- https://facebook.github.io/react/docs/events.html#mouse-events
-- https://developer.mozilla.org/en-US/docs/Web/Events
-- Event names (eventType)
-- onClick (click) onContextMenu (contextmenu) onDoubleClick (dblclick)
-- onDrag (drag) onDragEnd (dragend) onDragEnter (dragenter) onDragExit (dragexit)
-- onDragLeave (dragleave) onDragOver (dragover) onDragStart (dragstart)
-- onDrop (drop) onMouseDown (mousedown) onMouseEnter (mouseenter) onMouseLeave (mouseleave)
-- onMouseMove (mousemove) onMouseOut (mouseout) onMouseOver (mouseover) onMouseUp (mouseup)
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
}
-- | See https://www.w3.org/TR/DOM-Level-3-Events-key/#keys-modifier
-- This will throw if J.JSVal is null, but shouldn't happen since we've
-- already check for a valid SyntheticEvent
unsafeGetModifierState :: J.JSVal -> J.JSString -> Bool
unsafeGetModifierState obj k = J.fromJSBool $ js_unsafeGetModifierState obj k
-- | We can lie about this not being in IO because
-- within the strict part of 'eventHandlerM'
-- the SyntheticEvent is effectively immutable.
parseMouseEvent :: SyntheticEvent -> IO (Maybe MouseEvent)
parseMouseEvent (SyntheticEvent evt) | js_isMouseEvent (js_unsafeProperty evt "nativeEvent") = pure $ 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 = pure Nothing
-- | Keyboard events
-- 'KeyboardEvent' must only be used in the first part of 'eventHandler'.
-- https://facebook.github.io/react/docs/events.html#keyboard-events
-- Event names (eventType)
-- onKeyDown (keydown) onKeyPress (keypress) onKeyUp (keyyp)
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
}
-- | We can lie about this not being in IO because
-- within the strict part of 'eventHandlerM'
-- the SyntheticEvent is effectively immutable.
parseKeyboardEvent :: SyntheticEvent -> IO (Maybe KeyboardEvent)
parseKeyboardEvent (SyntheticEvent evt) | js_isKeyboardEvent (js_unsafeProperty evt "nativeEvent") = pure $ 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 = pure 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
-- | unsafe and non-IO to enable lazy parsing. See mkEventHandler
foreign import javascript unsafe "$1[$2]"
js_unsafeProperty :: J.JSVal -> J.JSString -> J.JSVal
-- | unsafe to enable lazy parsing. See mkEventHandler
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
-- | unsafe and non-IO to enable lazy parsing. See mkEventHandler
js_unsafeProperty :: J.JSVal -> J.JSString -> J.JSVal
js_unsafeProperty _ _ = J.nullRef
-- | unsafe to enable lazy parsing. See mkEventHandler
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