@@ -1,4 +1,4 @@
1−{-# LANGUAGE ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo #-}
1+{-# LANGUAGE ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo, GADTs, DataKinds, RankNTypes, TemplateHaskell #-}
22
33module Reflex.Dom.Widget.Basic where
44
@@ -30,16 +30,16 @@ import GHCJS.DOM.NamedNodeMap
3030import Control.Lens hiding (element, children)
3131import Data.These
3232import Data.Align
33−
3433import Data.Maybe
34+import 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,6 +382,226 @@ wrapDomEventMaybe element elementOnevent getValue = do
382382 {-# SCC "e" #-} unsubscribe
383383 return $! {-# SCC "f" #-} e
384384
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
480+
481+type 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
528+
529+onEventName :: IsElement e => EventName en -> e -> EventM (EventType en) e () -> IO (IO ())
530+onEventName 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
577+
578+newtype EventResult en = EventResult { unEventResult :: EventResultType en }
579+
580+type 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 = ()
592+
593+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))
594+wrapDomEventsMaybe 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
604+
385605getKeyEvent :: EventM UIEvent e Int
386606getKeyEvent = do
387607 e <- event
@@ -392,12 +612,29 @@ getKeyEvent = do
392612 if charCode /= 0 then return charCode else
393613 uiEventGetKeyCode e
394614
395−wrapElement :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => HTMLElement -> m (El t)
615+getMouseEventCoords :: EventM MouseEvent e (Int, Int)
616+getMouseEventCoords = do
617+ e <- event
618+ liftIO $ bisequence (mouseEventGetX e, mouseEventGetY e)
619+
620+defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM (EventType en) e (Maybe (EventResult en))
621+defaultDomEventHandler 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 ()
633+
634+wrapElement :: 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)
396635wrapElement e = do
397− clicked <- wrapDomEvent e elementOnclick (return ())
398− keypress <- wrapDomEvent e elementOnkeypress getKeyEvent
399− scrolled <- wrapDomEvent e elementOnscroll $ liftIO $ elementGetScrollTop e
400− return $ El e clicked keypress scrolled
636+ es <- wrapDomEventsMaybe e $ defaultDomEventHandler e
637+ return $ El e es
401638
402639elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)
403640elDynAttr' elementTag attrs child = do
@@ -479,10 +716,16 @@ data Link t
479716 = Link { _link_clicked :: Event t ()
480717 }
481718
719+class HasDomEvent t a where
720+ domEvent :: EventName en -> a -> Event t (EventResultType en)
721+
722+instance Reflex t => HasDomEvent t (El t) where
723+ domEvent en el = fmap unEventResult $ select (_el_events el) (WrapArg en)
724+
482725linkClass :: MonadWidget t m => String -> String -> m (Link t)
483726linkClass s c = do
484727 (l,_) <- elAttr' "a" ("class" =: c) $ text s
485− return $ Link $ _el_clicked l
728+ return $ Link $ domEvent Click l
486729
487730link :: MonadWidget t m => String -> m (Link t)
488731link s = linkClass s ""
@@ -490,7 +733,7 @@ link s = linkClass s ""
490733button :: MonadWidget t m => String -> m (Event t ())
491734button s = do
492735 (e, _) <- el' "button" $ text s
493− return $ _el_clicked e
736+ return $ domEvent Click e
494737
495738newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) }
496739
@@ -556,3 +799,21 @@ unsafePlaceElement e = do
556799 p <- askParent
557800 _ <- liftIO $ nodeAppendChild p $ Just e
558801 wrapElement e
802+
803+deriveGEq ''EventName
804+deriveGCompare ''EventName
805+
806+--------------------------------------------------------------------------------
807+-- Deprecated functions
808+
809+{-# DEPRECATED _el_clicked "Use `domEvent Click` instead" #-}
810+_el_clicked :: Reflex t => El t -> Event t ()
811+_el_clicked = domEvent Click
812+
813+{-# DEPRECATED _el_keypress "Use `domEvent Keypress` instead" #-}
814+_el_keypress :: Reflex t => El t -> Event t Int
815+_el_keypress = domEvent Keypress
816+
817+{-# DEPRECATED _el_scrolled "Use `domEvent Scroll` instead" #-}
818+_el_scrolled :: Reflex t => El t -> Event t Int
819+_el_scrolled = domEvent Scroll