git.iko.soy/reflex-dom
on 2ea6efe help sign in
reflex-dom/src/Reflex/Dom/Widget/Basic.hs
819 lines 34 kB history raw
1{-# LANGUAGE ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo, GADTs, DataKinds, RankNTypes, TemplateHaskell #-}
3module Reflex.Dom.Widget.Basic where
5import Reflex.Dom.Class
6import Reflex.Dom.Internal.Foreign ()
8import Prelude hiding (mapM, mapM_, sequence, sequence_)
9import Reflex
10import Reflex.Host.Class
11import Data.Functor.Misc
12import Data.Map (Map)
13import qualified Data.Map as Map
14import Data.Set (Set)
15import qualified Data.Set as Set
16import Data.Dependent.Sum (DSum (..))
17import Data.Foldable
18import Data.Traversable
19import Control.Monad.Trans
20import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_)
21import Control.Monad.State hiding (state, mapM, mapM_, forM, forM_, sequence, sequence_)
22import GHCJS.DOM.Node
23import GHCJS.DOM.UIEvent
24import GHCJS.DOM.EventM (event, EventM)
25import GHCJS.DOM.Document
26import GHCJS.DOM.Element
27import GHCJS.DOM.HTMLElement
28import GHCJS.DOM.Types hiding (Widget (..), unWidget, Event)
29import GHCJS.DOM.NamedNodeMap
30import Control.Lens hiding (element, children)
31import Data.These
32import Data.Align
33import Data.Maybe
34import Data.GADT.Compare.TH
35import Data.Bitraversable
36import GHCJS.DOM.MouseEvent
38type AttributeMap = Map String String
40data El t
41 = El { _el_element :: HTMLElement
42 , _el_events :: EventSelector t (WrapArg EventResult EventName)
43 }
45class Attributes m a where
46 addAttributes :: IsElement e => a -> e -> m ()
48instance MonadIO m => Attributes m AttributeMap where
49 addAttributes curAttrs e = liftIO $ imapM_ (elementSetAttribute e) curAttrs
51instance MonadWidget t m => Attributes m (Dynamic t AttributeMap) where
52 addAttributes attrs e = do
53 schedulePostBuild $ do
54 curAttrs <- sample $ current attrs
55 liftIO $ imapM_ (elementSetAttribute e) curAttrs
56 addVoidAction $ flip fmap (updated attrs) $ \newAttrs -> liftIO $ do
57 oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< elementGetAttributes e
58 forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ elementRemoveAttribute e
59 imapM_ (elementSetAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell
61buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m HTMLElement
62buildEmptyElement elementTag attrs = do
63 doc <- askDocument
64 p <- askParent
65 Just e <- liftIO $ documentCreateElement doc elementTag
66 addAttributes attrs e
67 _ <- liftIO $ nodeAppendChild p $ Just e
68 return $ castToHTMLElement e
70-- We need to decide what type of attrs we've got statically, because it will often be a recursively defined value, in which case inspecting it will lead to a cycle
71buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (HTMLElement, a)
72buildElement elementTag attrs child = do
73 e <- buildEmptyElement elementTag attrs
74 result <- subWidget (toNode e) child
75 return (e, result)
77namedNodeMapGetNames :: IsNamedNodeMap self => self -> IO (Set String)
78namedNodeMapGetNames self = do
79 l <- namedNodeMapGetLength self
80 let locations = if l == 0 then [] else [0..l-1] -- Can't use 0..l-1 if l is 0 because l is unsigned and will wrap around
81 liftM Set.fromList $ forM locations $ \i -> do
82 Just n <- namedNodeMapItem self i
83 nodeGetNodeName n
85text :: MonadWidget t m => String -> m ()
86text = void . text'
88--TODO: Wrap the result
89text' :: MonadWidget t m => String -> m Text
90text' s = do
91 doc <- askDocument
92 p <- askParent
93 Just n <- liftIO $ documentCreateTextNode doc s
94 _ <- liftIO $ nodeAppendChild p $ Just n
95 return n
97dynText :: MonadWidget t m => Dynamic t String -> m ()
98dynText s = do
99 n <- text' ""
100 schedulePostBuild $ do
101 curS <- sample $ current s
102 liftIO $ nodeSetNodeValue n curS
103 addVoidAction $ fmap (liftIO . nodeSetNodeValue n) $ updated s
105display :: (MonadWidget t m, Show a) => Dynamic t a -> m ()
106display a = dynText =<< mapDyn show a
108--TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'?
109dyn :: MonadWidget t m => Dynamic t (m a) -> m (Event t a)
110dyn child = do
111 startPlaceholder <- text' ""
112 endPlaceholder <- text' ""
113 (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
114 let e = fmap snd newChildBuilt --TODO: Get rid of this hack
115 childVoidAction <- hold never e
116 performEvent_ $ fmap (const $ return ()) e --TODO: Get rid of this hack
117 addVoidAction $ switch childVoidAction
118 doc <- askDocument
119 runWidget <- getRunWidget
120 let build c = do
121 Just df <- liftIO $ documentCreateDocumentFragment doc
122 (result, postBuild, voidActions) <- runWidget df c
123 scheduleFollowup newChildBuiltTriggerRef (result, voidActions)
124 postBuild
125 Just p <- liftIO $ nodeGetParentNode endPlaceholder
126 _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
127 return ()
128 schedulePostBuild $ do
129 c <- sample $ current child
130 build c
131 addVoidAction $ ffor (updated child) $ \newChild -> do
132 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
133 build newChild
134 return $ fmap fst newChildBuilt
136widgetHold :: MonadWidget t m => m a -> Event t (m a) -> m (Dynamic t a)
137widgetHold child0 newChild = do
138 startPlaceholder <- text' ""
139 result0 <- child0 -- I'm pretty sure this is wrong; the void actions should get removed when the child is swapped out
140 endPlaceholder <- text' ""
141 (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef
142 performEvent_ $ fmap (const $ return ()) newChildBuilt --TODO: Get rid of this hack
143 childVoidAction <- hold never $ fmap snd newChildBuilt
144 addVoidAction $ switch childVoidAction --TODO: Should this be a switchPromptly?
145 doc <- askDocument
146 runWidget <- getRunWidget
147 let build c = do
148 Just df <- liftIO $ documentCreateDocumentFragment doc
149 (result, postBuild, voidActions) <- runWidget df c
150 scheduleFollowup newChildBuiltTriggerRef (result, voidActions)
151 postBuild
152 mp <- liftIO $ nodeGetParentNode endPlaceholder
153 case mp of
154 Nothing -> return () --TODO: Is this right?
155 Just p -> do
156 _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
157 return ()
158 return ()
159 addVoidAction $ ffor newChild $ \c -> do
160 liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder
161 build c
162 holdDyn result0 $ fmap fst newChildBuilt
164--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
165listWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a))
166listWithKey vals mkChild = do
167 doc <- askDocument
168 endPlaceholder <- text' ""
169 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
170 performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
171 children <- hold Map.empty newChildren
172 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
173 runWidget <- getRunWidget
174 let buildChild df k v = runWidget df $ do
175 childStart <- text' ""
176 result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
177 childEnd <- text' ""
178 return (result, (childStart, childEnd))
179 schedulePostBuild $ do
180 Just df <- liftIO $ documentCreateDocumentFragment doc
181 curVals <- sample $ current vals
182 initialState <- iforM curVals $ \k v -> do
183 (result, postBuild, voidAction) <- buildChild df k v
184 return ((result, voidAction), postBuild)
185 scheduleFollowup newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame
186 sequence_ $ fmap snd initialState
187 Just p <- liftIO $ nodeGetParentNode endPlaceholder
188 _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
189 return ()
190 addVoidAction $ flip fmap (updated vals) $ \newVals -> do
191 curState <- sample children
192 --TODO: Should we remove the parent from the DOM first to avoid reflows?
193 (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
194 This ((_, (start, end)), _) -> do
195 liftIO $ deleteBetweenInclusive start end
196 return Nothing
197 That v -> do
198 Just df <- liftIO $ documentCreateDocumentFragment doc
199 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
200 let s = (childResult, childVoidAction)
201 modify (>>childPostBuild)
202 let placeholder = case Map.lookupGT k curState of
203 Nothing -> endPlaceholder
204 Just (_, ((_, (start, _)), _)) -> start
205 Just p <- liftIO $ nodeGetParentNode placeholder
206 _ <- liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
207 return $ Just s
208 These state _ -> do
209 return $ Just state
210 scheduleFollowup newChildrenTriggerRef newState
211 postBuild
212 holdDyn Map.empty $ fmap (fmap (fst . fst)) newChildren
214listWithKey' :: forall t m k v a. (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a))
215listWithKey' initialVals valsChanged mkChild = do
216 doc <- askDocument
217 endPlaceholder <- text' ""
218 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
219-- performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
220 runWidget <- getRunWidget
221 let childValChangedSelector :: EventSelector t (Const2 k v)
222 childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged
223 buildChild df k v = runWidget df $ wrapChild k v
224 wrapChild k v = do
225 childStart <- text' ""
226 result <- mkChild k v $ select childValChangedSelector $ Const2 k
227 childEnd <- text' ""
228 return (result, (childStart, childEnd))
229 Just dfOrig <- liftIO $ documentCreateDocumentFragment doc
230 initialState <- iforM initialVals $ \k v -> subWidgetWithVoidActions (toNode dfOrig) $ wrapChild k v --Note: we have to use subWidgetWithVoidActions rather than runWidget here, because running post-build actions during build can cause not-yet-constructed values to be read
231 children <- holdDyn initialState newChildren
232 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children
233 Just pOrig <- liftIO $ nodeGetParentNode endPlaceholder
234 _ <- liftIO $ nodeInsertBefore pOrig (Just dfOrig) (Just endPlaceholder)
235 addVoidAction $ flip fmap valsChanged $ \newVals -> do
236 curState <- sample $ current children
237 --TODO: Should we remove the parent from the DOM first to avoid reflows?
238 (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
239 These ((_, (start, end)), _) Nothing -> do -- Deleting child
240 liftIO $ deleteBetweenInclusive start end
241 return Nothing
242 These ((_, (start, end)), _) (Just v) -> do -- Replacing existing child
243 liftIO $ deleteBetweenExclusive start end
244 Just df <- liftIO $ documentCreateDocumentFragment doc
245 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
246 let s = (childResult, childVoidAction)
247 modify (>>childPostBuild)
248 Just p <- liftIO $ nodeGetParentNode end
249 _ <- liftIO $ nodeInsertBefore p (Just df) (Just end)
250 return $ Just s
251 That Nothing -> return Nothing -- Deleting non-existent child
252 That (Just v) -> do -- Creating new child
253 Just df <- liftIO $ documentCreateDocumentFragment doc
254 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
255 let s = (childResult, childVoidAction)
256 modify (>>childPostBuild)
257 let placeholder = case Map.lookupGT k curState of
258 Nothing -> endPlaceholder
259 Just (_, ((_, (start, _)), _)) -> start
260 Just p <- liftIO $ nodeGetParentNode placeholder
261 _ <- liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
262 return $ Just s
263 This state -> do -- No change
264 return $ Just state
265 scheduleFollowup newChildrenTriggerRef newState
266 postBuild
267 mapDyn (fmap (fst . fst)) children
269--TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value
270listViewWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a))
271listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild
273listViewWithKey' :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a))
274listViewWithKey' vals mkChild = do
275 doc <- askDocument
276 endPlaceholder <- text' ""
277 (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef
278 performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack
279 children <- hold Map.empty newChildren
280 addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) children
281 runWidget <- getRunWidget
282 let buildChild df k v = runWidget df $ do
283 childStart <- text' ""
284 result <- mkChild k =<< holdDyn v (fmapMaybe (Map.lookup k) (updated vals))
285 childEnd <- text' ""
286 return (result, (childStart, childEnd))
287 schedulePostBuild $ do
288 Just df <- liftIO $ documentCreateDocumentFragment doc
289 curVals <- sample $ current vals
290 initialState <- iforM curVals $ \k v -> do
291 (result, postBuild, voidAction) <- buildChild df k v
292 return ((result, voidAction), postBuild)
293 scheduleFollowup newChildrenTriggerRef $ fmap fst initialState --TODO: Do all these in a single runFrame
294 sequence_ $ fmap snd initialState
295 Just p <- liftIO $ nodeGetParentNode endPlaceholder
296 _ <- liftIO $ nodeInsertBefore p (Just df) (Just endPlaceholder)
297 return ()
298 addVoidAction $ flip fmap (updated vals) $ \newVals -> do
299 curState <- sample children
300 --TODO: Should we remove the parent from the DOM first to avoid reflows?
301 (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case
302 This ((_, (start, end)), _) -> do
303 liftIO $ deleteBetweenInclusive start end
304 return Nothing
305 That v -> do
306 Just df <- liftIO $ documentCreateDocumentFragment doc
307 (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v
308 let s = (childResult, childVoidAction)
309 modify (>>childPostBuild)
310 let placeholder = case Map.lookupGT k curState of
311 Nothing -> endPlaceholder
312 Just (_, ((_, (start, _)), _)) -> start
313 Just p <- liftIO $ nodeGetParentNode placeholder
314 _ <- liftIO $ nodeInsertBefore p (Just df) (Just placeholder)
315 return $ Just s
316 These state _ -> do
317 return $ Just state
318 scheduleFollowup newChildrenTriggerRef newState
319 postBuild
320 return $ fmap (fmap (fst . fst)) children
322--TODO: Deduplicate the various list*WithKey* implementations
324selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k) => Dynamic t k -> Dynamic t (Map k v) -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -> m (Event t k)
325selectViewListWithKey_ selection vals mkChild = do
326 let selectionDemux = demux selection -- For good performance, this value must be shared across all children
327 selectChild <- listWithKey vals $ \k v -> do
328 selected <- getDemuxed selectionDemux k
329 selectSelf <- mkChild k v selected
330 return $ fmap (const k) selectSelf
331 liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild
333--------------------------------------------------------------------------------
334-- Basic DOM manipulation helpers
335--------------------------------------------------------------------------------
337-- | s and e must both be children of the same node and s must precede e
338deleteBetweenExclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
339deleteBetweenExclusive s e = do
340 mCurrentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
341 case mCurrentParent of
342 Nothing -> return () --TODO: Is this the right behavior?
343 Just currentParent -> do
344 let go = do
345 Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
346 when (toNode s /= toNode x) $ do
347 _ <- nodeRemoveChild currentParent $ Just x
348 go
349 go
351-- | s and e must both be children of the same node and s must precede e
352deleteBetweenInclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
353deleteBetweenInclusive s e = do
354 mCurrentParent <- nodeGetParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
355 case mCurrentParent of
356 Nothing -> return () --TODO: Is this the right behavior?
357 Just currentParent -> do
358 let go = do
359 Just x <- nodeGetPreviousSibling e -- This can't be Nothing because we should hit 's' first
360 _ <- nodeRemoveChild currentParent $ Just x
361 when (toNode s /= toNode x) go
362 go
363 _ <- nodeRemoveChild currentParent $ Just e
364 return ()
366--------------------------------------------------------------------------------
367-- Adapters
368--------------------------------------------------------------------------------
370wrapDomEvent :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM event e () -> IO (IO ())) -> EventM event e a -> m (Event t a)
371wrapDomEvent element elementOnevent getValue = wrapDomEventMaybe element elementOnevent $ liftM Just getValue
373wrapDomEventMaybe :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM event e () -> IO (IO ())) -> EventM event e (Maybe a) -> m (Event t a)
374wrapDomEventMaybe element elementOnevent getValue = do
375 postGui <- askPostGui
376 runWithActions <- askRunWithActions
377 e <- newEventWithTrigger $ \et -> do
378 unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent element $ {-# SCC "c" #-} do
379 mv <- {-# SCC "d" #-} getValue
380 forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> v]
381 return $ liftIO $ do
382 {-# SCC "e" #-} unsubscribe
383 return $! {-# SCC "f" #-} e
385data EventTag
386 = AbortTag
387 | BlurTag
388 | ChangeTag
389 | ClickTag
390 | ContextmenuTag
391 | DblclickTag
392 | DragTag
393 | DragendTag
394 | DragenterTag
395 | DragleaveTag
396 | DragoverTag
397 | DragstartTag
398 | DropTag
399 | ErrorTag
400 | FocusTag
401 | InputTag
402 | InvalidTag
403 | KeydownTag
404 | KeypressTag
405 | KeyupTag
406 | LoadTag
407 | MousedownTag
408 | MouseenterTag
409 | MouseleaveTag
410 | MousemoveTag
411 | MouseoutTag
412 | MouseoverTag
413 | MouseupTag
414-- | MousewheelTag -- webkitgtk only provides elementOnmousewheel (not elementOnwheel), but firefox does not support the mousewheel event; we should provide wheel (the equivalent, standard event), but we will need to make sure webkitgtk supports it first
415 | ScrollTag
416 | SelectTag
417 | SubmitTag
418-- | WheelTag -- See MousewheelTag
419 | BeforecutTag
420 | CutTag
421 | BeforecopyTag
422 | CopyTag
423 | BeforepasteTag
424 | PasteTag
425 | ResetTag
426 | SearchTag
427 | SelectstartTag
428 | TouchstartTag
429 | TouchmoveTag
430 | TouchendTag
431 | TouchcancelTag
433data EventName :: EventTag -> * where
434 Abort :: EventName 'AbortTag
435 Blur :: EventName 'BlurTag
436 Change :: EventName 'ChangeTag
437 Click :: EventName 'ClickTag
438 Contextmenu :: EventName 'ContextmenuTag
439 Dblclick :: EventName 'DblclickTag
440 Drag :: EventName 'DragTag
441 Dragend :: EventName 'DragendTag
442 Dragenter :: EventName 'DragenterTag
443 Dragleave :: EventName 'DragleaveTag
444 Dragover :: EventName 'DragoverTag
445 Dragstart :: EventName 'DragstartTag
446 Drop :: EventName 'DropTag
447 Error :: EventName 'ErrorTag
448 Focus :: EventName 'FocusTag
449 Input :: EventName 'InputTag
450 Invalid :: EventName 'InvalidTag
451 Keydown :: EventName 'KeydownTag
452 Keypress :: EventName 'KeypressTag
453 Keyup :: EventName 'KeyupTag
454 Load :: EventName 'LoadTag
455 Mousedown :: EventName 'MousedownTag
456 Mouseenter :: EventName 'MouseenterTag
457 Mouseleave :: EventName 'MouseleaveTag
458 Mousemove :: EventName 'MousemoveTag
459 Mouseout :: EventName 'MouseoutTag
460 Mouseover :: EventName 'MouseoverTag
461 Mouseup :: EventName 'MouseupTag
462 --Mousewheel :: EventName 'MousewheelTag
463 Scroll :: EventName 'ScrollTag
464 Select :: EventName 'SelectTag
465 Submit :: EventName 'SubmitTag
466 --Wheel :: EventName 'WheelTag
467 Beforecut :: EventName 'BeforecutTag
468 Cut :: EventName 'CutTag
469 Beforecopy :: EventName 'BeforecopyTag
470 Copy :: EventName 'CopyTag
471 Beforepaste :: EventName 'BeforepasteTag
472 Paste :: EventName 'PasteTag
473 Reset :: EventName 'ResetTag
474 Search :: EventName 'SearchTag
475 Selectstart :: EventName 'SelectstartTag
476 Touchstart :: EventName 'TouchstartTag
477 Touchmove :: EventName 'TouchmoveTag
478 Touchend :: EventName 'TouchendTag
479 Touchcancel :: EventName 'TouchcancelTag
481type family EventType en where
482 EventType 'AbortTag = UIEvent
483 EventType 'BlurTag = UIEvent
484 EventType 'ChangeTag = UIEvent
485 EventType 'ClickTag = MouseEvent
486 EventType 'ContextmenuTag = MouseEvent
487 EventType 'DblclickTag = MouseEvent
488 EventType 'DragTag = MouseEvent
489 EventType 'DragendTag = MouseEvent
490 EventType 'DragenterTag = MouseEvent
491 EventType 'DragleaveTag = MouseEvent
492 EventType 'DragoverTag = MouseEvent
493 EventType 'DragstartTag = MouseEvent
494 EventType 'DropTag = MouseEvent
495 EventType 'ErrorTag = UIEvent
496 EventType 'FocusTag = UIEvent
497 EventType 'InputTag = UIEvent
498 EventType 'InvalidTag = UIEvent
499 EventType 'KeydownTag = UIEvent
500 EventType 'KeypressTag = UIEvent
501 EventType 'KeyupTag = UIEvent
502 EventType 'LoadTag = UIEvent
503 EventType 'MousedownTag = MouseEvent
504 EventType 'MouseenterTag = UIEvent
505 EventType 'MouseleaveTag = UIEvent
506 EventType 'MousemoveTag = MouseEvent
507 EventType 'MouseoutTag = MouseEvent
508 EventType 'MouseoverTag = MouseEvent
509 EventType 'MouseupTag = MouseEvent
510 --EventType 'MousewheelTag = MouseEvent
511 EventType 'ScrollTag = UIEvent
512 EventType 'SelectTag = UIEvent
513 EventType 'SubmitTag = UIEvent
514 --EventType 'WheelTag = UIEvent
515 EventType 'BeforecutTag = UIEvent
516 EventType 'CutTag = UIEvent
517 EventType 'BeforecopyTag = UIEvent
518 EventType 'CopyTag = UIEvent
519 EventType 'BeforepasteTag = UIEvent
520 EventType 'PasteTag = UIEvent
521 EventType 'ResetTag = UIEvent
522 EventType 'SearchTag = UIEvent
523 EventType 'SelectstartTag = UIEvent
524 EventType 'TouchstartTag = UIEvent
525 EventType 'TouchmoveTag = UIEvent
526 EventType 'TouchendTag = UIEvent
527 EventType 'TouchcancelTag = UIEvent
529onEventName :: IsElement e => EventName en -> e -> EventM (EventType en) e () -> IO (IO ())
530onEventName en = case en of
531 Abort -> elementOnabort
532 Blur -> elementOnblur
533 Change -> elementOnchange
534 Click -> elementOnclick
535 Contextmenu -> elementOncontextmenu
536 Dblclick -> elementOndblclick
537 Drag -> elementOndrag
538 Dragend -> elementOndragend
539 Dragenter -> elementOndragenter
540 Dragleave -> elementOndragleave
541 Dragover -> elementOndragover
542 Dragstart -> elementOndragstart
543 Drop -> elementOndrop
544 Error -> elementOnerror
545 Focus -> elementOnfocus
546 Input -> elementOninput
547 Invalid -> elementOninvalid
548 Keydown -> elementOnkeydown
549 Keypress -> elementOnkeypress
550 Keyup -> elementOnkeyup
551 Load -> elementOnload
552 Mousedown -> elementOnmousedown
553 Mouseenter -> elementOnmouseenter
554 Mouseleave -> elementOnmouseleave
555 Mousemove -> elementOnmousemove
556 Mouseout -> elementOnmouseout
557 Mouseover -> elementOnmouseover
558 Mouseup -> elementOnmouseup
559 --Mousewheel -> elementOnmousewheel
560 Scroll -> elementOnscroll
561 Select -> elementOnselect
562 Submit -> elementOnsubmit
563 --Wheel -> elementOnwheel
564 Beforecut -> elementOnbeforecut
565 Cut -> elementOncut
566 Beforecopy -> elementOnbeforecopy
567 Copy -> elementOncopy
568 Beforepaste -> elementOnbeforepaste
569 Paste -> elementOnpaste
570 Reset -> elementOnreset
571 Search -> elementOnsearch
572 Selectstart -> elementOnselectstart
573 Touchstart -> elementOntouchstart
574 Touchmove -> elementOntouchmove
575 Touchend -> elementOntouchend
576 Touchcancel -> elementOntouchcancel
578newtype EventResult en = EventResult { unEventResult :: EventResultType en }
580type family EventResultType (en :: EventTag) :: * where
581 EventResultType 'ClickTag = ()
582 EventResultType 'DblclickTag = ()
583 EventResultType 'KeypressTag = Int
584 EventResultType 'ScrollTag = Int
585 EventResultType 'MousemoveTag = (Int, Int)
586 EventResultType 'MousedownTag = (Int, Int)
587 EventResultType 'MouseupTag = (Int, Int)
588 EventResultType 'MouseenterTag = ()
589 EventResultType 'MouseleaveTag = ()
590 EventResultType 'FocusTag = ()
591 EventResultType 'BlurTag = ()
593wrapDomEventsMaybe :: (Functor (Event t), IsElement e, MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (forall en. EventName en -> EventM (EventType en) e (Maybe (f en))) -> m (EventSelector t (WrapArg f EventName))
594wrapDomEventsMaybe element handlers = do
595 postGui <- askPostGui
596 runWithActions <- askRunWithActions
597 e <- newFanEventWithTrigger $ \(WrapArg en) et -> do
598 unsubscribe <- liftIO $ (onEventName en) element $ do
599 mv <- handlers en
600 forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> v]
601 return $ liftIO $ do
602 unsubscribe
603 return $! e
605getKeyEvent :: EventM UIEvent e Int
606getKeyEvent = do
607 e <- event
608 liftIO $ do
609 which <- uiEventGetWhich e
610 if which /= 0 then return which else do
611 charCode <- uiEventGetCharCode e
612 if charCode /= 0 then return charCode else
613 uiEventGetKeyCode e
615getMouseEventCoords :: EventM MouseEvent e (Int, Int)
616getMouseEventCoords = do
617 e <- event
618 liftIO $ bisequence (mouseEventGetX e, mouseEventGetY e)
620defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM (EventType en) e (Maybe (EventResult en))
621defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
622 Click -> return ()
623 Dblclick -> return ()
624 Keypress -> getKeyEvent
625 Scroll -> liftIO $ elementGetScrollTop e
626 Mousemove -> getMouseEventCoords
627 Mouseup -> getMouseEventCoords
628 Mousedown -> getMouseEventCoords
629 Mouseenter -> return ()
630 Mouseleave -> return ()
631 Focus -> return ()
632 Blur -> return ()
634wrapElement :: forall t h m. (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => HTMLElement -> m (El t)
635wrapElement e = do
636 es <- wrapDomEventsMaybe e $ defaultDomEventHandler e
637 return $ El e es
639elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)
640elDynAttr' elementTag attrs child = do
641 (e, result) <- buildElement elementTag attrs child
642 e' <- wrapElement e
643 return (e', result)
645{-# INLINABLE elAttr #-}
646elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a
647elAttr elementTag attrs child = do
648 (_, result) <- buildElement elementTag attrs child
649 return result
651{-# INLINABLE el' #-}
652el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)
653el' elementTag child = elAttr' elementTag (Map.empty :: AttributeMap) child
655{-# INLINABLE elAttr' #-}
656elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)
657elAttr' elementTag attrs child = do
658 (e, result) <- buildElement elementTag attrs child
659 e' <- wrapElement e
660 return (e', result)
662{-# INLINABLE elDynAttr #-}
663elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a
664elDynAttr elementTag attrs child = do
665 (_, result) <- buildElement elementTag attrs child
666 return result
668{-# INLINABLE el #-}
669el :: forall t m a. MonadWidget t m => String -> m a -> m a
670el elementTag child = elAttr elementTag Map.empty child
672elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a
673elClass elementTag c child = elAttr elementTag ("class" =: c) child
675--------------------------------------------------------------------------------
676-- Copied and pasted from Reflex.Widget.Class
677--------------------------------------------------------------------------------
679list :: (MonadWidget t m, Ord k) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a))
680list dm mkChild = listWithKey dm (\_ dv -> mkChild dv)
682simpleList :: MonadWidget t m => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a])
683simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<< mapDyn (Map.fromList . zip [(1::Int)..]) xs
685elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
686elDynHtml' elementTag html = do
687 e <- buildEmptyElement elementTag (Map.empty :: Map String String)
688 schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)
689 addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html
690 wrapElement e
692elDynHtmlAttr' :: MonadWidget t m => String -> Map String String -> Dynamic t String -> m (El t)
693elDynHtmlAttr' elementTag attrs html = do
694 e <- buildEmptyElement elementTag attrs
695 schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)
696 addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html
697 wrapElement e
699{-
701--TODO: Update dynamically
702{-# INLINABLE dynHtml #-}
703dynHtml :: MonadWidget t m => Dynamic t String -> m ()
704dynHtml ds = do
705 let mkSelf h = do
706 doc <- askDocument
707 Just e <- liftIO $ liftM (fmap castToHTMLElement) $ documentCreateElement doc "div"
708 liftIO $ htmlElementSetInnerHTML e h
709 return e
710 eCreated <- performEvent . fmap mkSelf . tagDyn ds =<< getEInit
711 putEChildren $ fmap ((:[]) . toNode) eCreated
713-}
715data Link t
716 = Link { _link_clicked :: Event t ()
717 }
719class HasDomEvent t a where
720 domEvent :: EventName en -> a -> Event t (EventResultType en)
722instance Reflex t => HasDomEvent t (El t) where
723 domEvent en el = fmap unEventResult $ select (_el_events el) (WrapArg en)
725linkClass :: MonadWidget t m => String -> String -> m (Link t)
726linkClass s c = do
727 (l,_) <- elAttr' "a" ("class" =: c) $ text s
728 return $ Link $ domEvent Click l
730link :: MonadWidget t m => String -> m (Link t)
731link s = linkClass s ""
733button :: MonadWidget t m => String -> m (Event t ())
734button s = do
735 (e, _) <- el' "button" $ text s
736 return $ domEvent Click e
738newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
740workflow :: forall t m a. MonadWidget t m => Workflow t m a -> m (Dynamic t a)
741workflow w0 = do
742 rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ fmap snd $ current eResult
743 mapDyn fst eResult
745workflowView :: forall t m a. MonadWidget t m => Workflow t m a -> m (Event t a)
746workflowView w0 = do
747 rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace
748 eReplace <- liftM switch $ hold never $ fmap snd eResult
749 return $ fmap fst eResult
751divClass :: forall t m a. MonadWidget t m => String -> m a -> m a
752divClass = elClass "div"
754dtdd :: forall t m a. MonadWidget t m => String -> m a -> m a
755dtdd h w = do
756 el "dt" $ text h
757 el "dd" $ w
759blank :: forall t m. MonadWidget t m => m ()
760blank = return ()
762tableDynAttr :: forall t m r k v. (MonadWidget t m, Show k, Ord k) => String -> [(String, k -> Dynamic t r -> m v)] -> Dynamic t (Map k r) -> (k -> m (Dynamic t (Map String String))) -> m (Dynamic t (Map k (El t, [v])))
763tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do
764 elAttr "table" (Map.singleton "class" klass) $ do
765 el "thead" $ el "tr" $ do
766 mapM_ (\(h, _) -> el "th" $ text h) cols
767 el "tbody" $ do
768 listWithKey dRows (\k r -> do
769 dAttrs <- rowAttrs k
770 elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols)
772--TODO preselect a tab on open
773tabDisplay :: forall t m k. (MonadFix m, MonadWidget t m, Show k, Ord k) => String -> String -> Map k (String, m ()) -> m ()
774tabDisplay ulClass activeClass tabItems = do
775 rec dCurrentTab <- holdDyn Nothing (updated dTabClicks)
776 dTabClicks :: Dynamic t (Maybe k) <- elAttr "ul" (Map.singleton "class" ulClass) $ do
777 tabClicksList :: [Event t k] <- (liftM Map.elems) $ imapM (\k (s,_) -> headerBarLink s k =<< mapDyn (== (Just k)) dCurrentTab) tabItems
778 let eTabClicks :: Event t k = leftmost tabClicksList
779 holdDyn Nothing $ fmap Just eTabClicks :: m (Dynamic t (Maybe k))
780 divClass "" $ do
781 let dTabs :: Dynamic t (Map k (String, m ())) = constDyn tabItems
782 _ <- listWithKey dTabs (\k dTab -> do
783 dAttrs <- mapDyn (\sel -> do
784 let t1 = listToMaybe $ Map.keys tabItems
785 if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab
786 elDynAttr "div" dAttrs $ dyn =<< mapDyn snd dTab)
787 return ()
788 where
789 headerBarLink :: (MonadWidget t m, Ord k) => String -> k -> Dynamic t Bool -> m (Event t k)
790 headerBarLink x k dBool = do
791 dAttributes <- mapDyn (\b -> if b then Map.singleton "class" activeClass else Map.empty) dBool
792 elDynAttr "li" dAttributes $ do
793 a <- link x
794 return $ fmap (const k) (_link_clicked a)
796-- | Place an element into the DOM and wrap it with Reflex event handlers. Note: undefined behavior may result if the element is placed multiple times, removed from the DOM after being placed, or in other situations. Don't use this unless you understand the internals of MonadWidget.
797unsafePlaceElement :: MonadWidget t m => HTMLElement -> m (El t)
798unsafePlaceElement e = do
799 p <- askParent
800 _ <- liftIO $ nodeAppendChild p $ Just e
801 wrapElement e
803deriveGEq ''EventName
804deriveGCompare ''EventName
806--------------------------------------------------------------------------------
807-- Deprecated functions
809{-# DEPRECATED _el_clicked "Use `domEvent Click` instead" #-}
810_el_clicked :: Reflex t => El t -> Event t ()
811_el_clicked = domEvent Click
813{-# DEPRECATED _el_keypress "Use `domEvent Keypress` instead" #-}
814_el_keypress :: Reflex t => El t -> Event t Int
815_el_keypress = domEvent Keypress
817{-# DEPRECATED _el_scrolled "Use `domEvent Scroll` instead" #-}
818_el_scrolled :: Reflex t => El t -> Event t Int
819_el_scrolled = domEvent Scroll