@@ -32,14 +32,14 @@ import Data.These
3232import Data.Align
3333import Data.Maybe
3434import Data.GADT.Compare.TH
35+import Data.Bitraversable
36+import GHCJS.DOM.MouseEvent
3537
3638type AttributeMap = Map String String
3739
3840data El t
3941 = El { _el_element :: HTMLElement
40− , _el_clicked :: Event t ()
41− , _el_keypress :: Event t Int
42− , _el_scrolled :: Event t Int
42+ , _el_events :: EventSelector t (WrapArg EventResult EventName)
4343 }
4444
4545class Attributes m a where
@@ -382,38 +382,214 @@ wrapDomEventMaybe element elementOnevent getValue = do
382382 {-# SCC "e" #-} unsubscribe
383383 return $! {-# SCC "f" #-} e
384384
385−data EventName
386− = Click
387− | Keypress
388− | Scroll
389−
390−data EventNameProxy :: EventName -> * where
391− ClickProxy :: EventNameProxy 'Click
392− KeypressProxy :: EventNameProxy 'Keypress
393− ScrollProxy :: EventNameProxy 'Scroll
394−
395−deriveGEq ''EventNameProxy
396−deriveGCompare ''EventNameProxy
385+data 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
432+
433+data 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
397480
398481type family EventType en where
399− EventType 'Click = MouseEvent
400− EventType 'Keypress = UIEvent
401− EventType 'Scroll = UIEvent
402−
403−onEventName :: IsElement e => EventNameProxy en -> e -> EventM (EventType en) e () -> IO (IO ())
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
528+
529+onEventName :: IsElement e => EventName en -> e -> EventM (EventType en) e () -> IO (IO ())
404530onEventName en = case en of
405− ClickProxy -> elementOnclick
406− KeypressProxy -> elementOnkeypress
407− ScrollProxy -> elementOnscroll
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
408577
409578newtype EventResult en = EventResult { unEventResult :: EventResultType en }
410579
411−type family EventResultType (en :: EventName) :: * where
412− EventResultType 'Click = ()
413− EventResultType 'Keypress = Int
414− EventResultType 'Scroll = Int
415−
416−wrapDomEventsMaybe :: (Functor (Event t), IsElement e, MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (forall en. EventNameProxy en -> EventM (EventType en) e (Maybe (f en))) -> m (EventSelector t (WrapArg f EventNameProxy))
580+type family EventResultType (en :: EventTag) :: * where
581+ EventResultType 'ClickTag = ()
582+ EventResultType 'KeypressTag = Int
583+ EventResultType 'ScrollTag = Int
584+ EventResultType 'MousemoveTag = (Int, Int)
585+ EventResultType 'MousedownTag = (Int, Int)
586+ EventResultType 'MouseupTag = (Int, Int)
587+ EventResultType 'MouseenterTag = ()
588+ EventResultType 'MouseleaveTag = ()
589+ EventResultType 'FocusTag = ()
590+ EventResultType 'BlurTag = ()
591+
592+wrapDomEventsMaybe :: (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))
417593wrapDomEventsMaybe element handlers = do
418594 postGui <- askPostGui
419595 runWithActions <- askRunWithActions
@@ -435,15 +611,28 @@ getKeyEvent = do
435611 if charCode /= 0 then return charCode else
436612 uiEventGetKeyCode e
437613
614+getMouseEventCoords :: EventM MouseEvent e (Int, Int)
615+getMouseEventCoords = do
616+ e <- event
617+ liftIO $ bisequence (mouseEventGetX e, mouseEventGetY e)
618+
619+defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM (EventType en) e (Maybe (EventResult en))
620+defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
621+ Click -> return ()
622+ Keypress -> getKeyEvent
623+ Scroll -> liftIO $ elementGetScrollTop e
624+ Mousemove -> getMouseEventCoords
625+ Mouseup -> getMouseEventCoords
626+ Mousedown -> getMouseEventCoords
627+ Mouseenter -> return ()
628+ Mouseleave -> return ()
629+ Focus -> return ()
630+ Blur -> return ()
631+
438632wrapElement :: 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)
439633wrapElement e = do
440− es <- wrapDomEventsMaybe e $ \evt -> case evt of
441− ClickProxy -> return $ Just $ EventResult ()
442− KeypressProxy -> liftM (Just . EventResult) getKeyEvent
443− ScrollProxy -> liftM (Just . EventResult) $ liftIO $ elementGetScrollTop e
444− let selectEvent :: EventNameProxy en -> Event t (EventResultType en)
445− selectEvent = fmap unEventResult . select es . WrapArg
446− return $ El e (selectEvent ClickProxy) (selectEvent KeypressProxy) (selectEvent ScrollProxy)
634+ es <- wrapDomEventsMaybe e $ defaultDomEventHandler e
635+ return $ El e es
447636
448637elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)
449638elDynAttr' elementTag attrs child = do
@@ -525,10 +714,16 @@ data Link t
525714 = Link { _link_clicked :: Event t ()
526715 }
527716
717+class HasDomEvent t a where
718+ domEvent :: EventName en -> a -> Event t (EventResultType en)
719+
720+instance Reflex t => HasDomEvent t (El t) where
721+ domEvent en el = fmap unEventResult $ select (_el_events el) (WrapArg en)
722+
528723linkClass :: MonadWidget t m => String -> String -> m (Link t)
529724linkClass s c = do
530725 (l,_) <- elAttr' "a" ("class" =: c) $ text s
531− return $ Link $ _el_clicked l
726+ return $ Link $ domEvent Click l
532727
533728link :: MonadWidget t m => String -> m (Link t)
534729link s = linkClass s ""
@@ -536,7 +731,7 @@ link s = linkClass s ""
536731button :: MonadWidget t m => String -> m (Event t ())
537732button s = do
538733 (e, _) <- el' "button" $ text s
539− return $ _el_clicked e
734+ return $ domEvent Click e
540735
541736newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
542737
@@ -602,3 +797,21 @@ unsafePlaceElement e = do
602797 p <- askParent
603798 _ <- liftIO $ nodeAppendChild p $ Just e
604799 wrapElement e
800+
801+deriveGEq ''EventName
802+deriveGCompare ''EventName
803+
804+--------------------------------------------------------------------------------
805+-- Deprecated functions
806+
807+{-# DEPRECATED _el_clicked "Use `domEvent Click` instead" #-}
808+_el_clicked :: Reflex t => El t -> Event t ()
809+_el_clicked = domEvent Click
810+
811+{-# DEPRECATED _el_keypress "Use `domEvent Keypress` instead" #-}
812+_el_keypress :: Reflex t => El t -> Event t Int
813+_el_keypress = domEvent Keypress
814+
815+{-# DEPRECATED _el_scrolled "Use `domEvent Scroll` instead" #-}
816+_el_scrolled :: Reflex t => El t -> Event t Int
817+_el_scrolled = domEvent Scroll