diff --git a/reflex-dom.cabal b/reflex-dom.cabal --- a/reflex-dom.cabal +++ b/reflex-dom.cabal @@ -1,15 +1,16 @@ Name: reflex-dom -Version: 0.1.1 -Synopsis: Glitch-free Functional Reactive Web Apps +Version: 0.2 +Synopsis: Functional Reactive Web Apps with Reflex Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine License: BSD3 License-file: LICENSE Author: Ryan Trinkle Maintainer: ryan.trinkle@gmail.com Stability: Experimental -Category: FRP +Category: FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces, User-interface Build-type: Simple Cabal-version: >=1.9.2 +-- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367 extra-source-files: src-ghc/Reflex/Dom/Internal/Foreign.hs src-ghc/Reflex/Dom/Xhr/Foreign.hs src-ghcjs/Reflex/Dom/Internal/Foreign.hs @@ -19,7 +20,7 @@ hs-source-dirs: src build-depends: base >= 4.7 && < 4.9, - reflex == 0.2.*, + reflex == 0.3.*, dependent-sum == 0.2.*, dependent-map == 0.1.*, semigroups == 0.16.*, @@ -35,7 +36,11 @@ bytestring == 0.10.*, data-default == 0.5.*, aeson == 0.8.*, - time == 1.5.* + time == 1.5.*, + exception-transformers == 0.4.*, + directory == 1.2.*, + dependent-sum-template >= 0.0.0.4 && < 0.1, + bifunctors == 4.2.* if impl(ghcjs) hs-source-dirs: src-ghcjs @@ -49,7 +54,6 @@ gtk3 == 0.13.*, webkitgtk3 == 0.13.*, webkitgtk3-javascriptcore == 0.13.* - -- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367 exposed-modules: Reflex.Dom @@ -66,5 +70,8 @@ Reflex.Dom.Xhr.Foreign other-extensions: TemplateHaskell - ghc-prof-options: -fprof-auto ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 + +source-repository head + type: git + location: https://github.com/ryantrinkle/reflex diff --git a/src-ghc/Reflex/Dom/Internal/Foreign.hs b/src-ghc/Reflex/Dom/Internal/Foreign.hs --- a/src-ghc/Reflex/Dom/Internal/Foreign.hs +++ b/src-ghc/Reflex/Dom/Internal/Foreign.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ForeignFunctionInterface #-} module Reflex.Dom.Internal.Foreign where import GHCJS.DOM hiding (runWebGUI) @@ -10,7 +11,10 @@ import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget, unWidget) import Graphics.UI.Gtk.WebKit.WebSettings import Graphics.UI.Gtk.WebKit.WebFrame +import Graphics.UI.Gtk.WebKit.WebInspector import Data.List +import Data.String +import System.Directory makeDefaultWebView :: String -> (WebView -> IO ()) -> IO () makeDefaultWebView userAgentKey main = do @@ -25,6 +29,7 @@ userAgent <- settings `get` webSettingsUserAgent settings `set` [ webSettingsUserAgent := userAgent ++ " " ++ userAgentKey , webSettingsEnableUniversalAccessFromFileUris := True + , webSettingsEnableDeveloperExtras := True ] webViewSetWebSettings webView settings window `containerAdd` scrollWin @@ -32,10 +37,20 @@ _ <- on window objectDestroy . liftIO $ mainQuit widgetShowAll window _ <- webView `on` loadFinished $ \_ -> do - main webView + main webView --TODO: Should probably only do this once + inspector <- webViewGetInspector webView + _ <- inspector `on` inspectWebView $ \wv -> do + inspectorWindow <- windowNew + windowSetDefaultSize inspectorWindow 900 600 + inspectorScrollWin <- scrolledWindowNew Nothing Nothing + inspectorWebView <- webViewNew + inspectorWindow `containerAdd` inspectorScrollWin + inspectorScrollWin `containerAdd` inspectorWebView + widgetShowAll inspectorWindow + return inspectorWebView wf <- webViewGetMainFrame webView - webFrameLoadString wf "" Nothing "file:///" - main webView + pwd <- getCurrentDirectory + webFrameLoadString wf "" Nothing $ "file://" ++ pwd ++ "/" mainGUI runWebGUI :: (WebView -> IO ()) -> IO () @@ -53,4 +68,3 @@ unless ((" " ++ userAgentKey) `isSuffixOf` agent) $ main (castToWebView window) Nothing -> do makeDefaultWebView userAgentKey main - diff --git a/src-ghc/Reflex/Dom/Xhr/Foreign.hs b/src-ghc/Reflex/Dom/Xhr/Foreign.hs --- a/src-ghc/Reflex/Dom/Xhr/Foreign.hs +++ b/src-ghc/Reflex/Dom/Xhr/Foreign.hs @@ -12,13 +12,11 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame -data XMLHttpRequest = XMLHttpRequest JSValueRef JSContextRef deriving (Eq, Ord) - -xhrContext :: XMLHttpRequest -> JSContextRef -xhrContext (XMLHttpRequest _ c) = c - -xhrValue :: XMLHttpRequest -> JSValueRef -xhrValue (XMLHttpRequest v _) = v +data XMLHttpRequest + = XMLHttpRequest { xhrValue :: JSValueRef + , xhrContext :: JSContextRef + } + deriving (Eq, Ord) toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef toJSObject ctx args = do @@ -28,18 +26,17 @@ jsobjectsetproperty ctx o prop a 1 nullPtr return o -toResponseType :: a -> a -toResponseType = id - responseTextToText :: Maybe String -> Maybe Text responseTextToText = fmap T.pack stringToJSValue :: JSContextRef -> String -> IO JSValueRef stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s +toResponseType :: a -> a +toResponseType = id + xmlHttpRequestNew :: WebView -> IO XMLHttpRequest xmlHttpRequestNew wv = do - --wv <- readIORef globalWebViewRef wf <- webViewGetMainFrame wv jsContext <- webFrameGetGlobalContext wf xhrScript <- jsstringcreatewithutf8cstring "new XMLHttpRequest()" diff --git a/src/Reflex/Dom/Class.hs b/src/Reflex/Dom/Class.hs --- a/src/Reflex/Dom/Class.hs +++ b/src/Reflex/Dom/Class.hs @@ -16,6 +16,7 @@ import Data.Dependent.Sum (DSum (..)) import GHCJS.DOM.Types hiding (Event) import GHCJS.DOM (WebView) +import Control.Monad.Exception -- | Alias for Data.Map.singleton (=:) :: k -> a -> Map k a @@ -27,9 +28,9 @@ keycodeEscape :: Int keycodeEscape = 27 -class ( Reflex t, MonadHold t m, MonadIO m, Functor m, MonadReflexCreateTrigger t m +class ( Reflex t, MonadHold t m, MonadIO m, MonadAsyncException m, Functor m, MonadReflexCreateTrigger t m , HasDocument m, HasWebView m, HasWebView (WidgetHost m), HasWebView (GuiAction m) - , MonadIO (WidgetHost m), MonadIO (GuiAction m), Functor (WidgetHost m), MonadSample t (WidgetHost m) + , MonadIO (WidgetHost m), MonadAsyncException (WidgetHost m), MonadIO (GuiAction m), MonadAsyncException (GuiAction m), Functor (WidgetHost m), MonadSample t (WidgetHost m) , HasPostGui t (GuiAction m) (WidgetHost m), HasPostGui t (GuiAction m) m, HasPostGui t (GuiAction m) (GuiAction m) , MonadRef m, MonadRef (WidgetHost m) , Ref m ~ Ref IO, Ref (WidgetHost m) ~ Ref IO --TODO: Eliminate this reliance on IO diff --git a/src/Reflex/Dom/Internal.hs b/src/Reflex/Dom/Internal.hs --- a/src/Reflex/Dom/Internal.hs +++ b/src/Reflex/Dom/Internal.hs @@ -19,6 +19,7 @@ import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_) import Control.Monad.Ref import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_, get) +import Control.Monad.Exception import Control.Concurrent import Control.Applicative import Data.ByteString (ByteString) @@ -37,7 +38,7 @@ } --TODO: Poorly named -newtype Gui t h m a = Gui { unGui :: ReaderT (GuiEnv t h) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix) +newtype Gui t h m a = Gui { unGui :: ReaderT (GuiEnv t h) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) runGui :: Gui t h m a -> GuiEnv t h -> m a runGui (Gui g) env = runReaderT g env @@ -61,7 +62,8 @@ hold a0 e = lift $ hold a0 e instance (Reflex t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (Gui t h m) where - newEventWithTrigger initializer = lift $ newEventWithTrigger initializer + newEventWithTrigger = lift . newEventWithTrigger + newFanEventWithTrigger f = lift $ newFanEventWithTrigger f data WidgetEnv = WidgetEnv { _widgetEnvParent :: !Node @@ -108,7 +110,7 @@ instance MonadTrans (Widget t) where lift = Widget . lift . lift -newtype Widget t m a = Widget { unWidget :: WidgetInternal t m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO) +newtype Widget t m a = Widget { unWidget :: WidgetInternal t m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException) instance MonadSample t m => MonadSample t (Widget t m) where sample b = lift $ sample b @@ -131,9 +133,10 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Widget t m) where newEventWithTrigger = lift . newEventWithTrigger + newFanEventWithTrigger f = lift $ newFanEventWithTrigger f instance ( MonadRef m, Ref m ~ Ref IO, MonadRef h, Ref h ~ Ref IO --TODO: Shouldn't need to be IO - , MonadIO m, MonadIO h, Functor m + , MonadIO m, MonadAsyncException m, MonadIO h, MonadAsyncException h, Functor m , ReflexHost t, MonadReflexCreateTrigger t m, MonadSample t m, MonadHold t m , MonadFix m, HasWebView h, HasPostGui t h h ) => MonadWidget t (Widget t (Gui t h m)) where @@ -195,7 +198,7 @@ Just body <- documentGetBody doc attachWidget body webView w -newtype WithWebView m a = WithWebView { unWithWebView :: ReaderT WebView m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix) +newtype WithWebView m a = WithWebView { unWithWebView :: ReaderT WebView m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) instance (Monad m) => HasWebView (WithWebView m) where askWebView = WithWebView ask @@ -225,11 +228,16 @@ instance MonadAtomicRef m => MonadAtomicRef (WithWebView m) where atomicModifyRef r = lift . atomicModifyRef r -deriving instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView m) +instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView m) where + newEventWithTrigger = lift . newEventWithTrigger + newFanEventWithTrigger f = lift $ newFanEventWithTrigger f + +instance MonadSubscribeEvent t m => MonadSubscribeEvent t (WithWebView m) where + subscribeEvent = lift . subscribeEvent + instance MonadReflexHost t m => MonadReflexHost t (WithWebView m) where + type ReadPhase (WithWebView m) = ReadPhase m fireEventsAndRead dm a = lift $ fireEventsAndRead dm a - subscribeEvent = lift . subscribeEvent - runFrame = lift . runFrame runHostFrame = lift . runHostFrame runWithWebView :: WithWebView m a -> WebView -> m a diff --git a/src/Reflex/Dom/Time.hs b/src/Reflex/Dom/Time.hs --- a/src/Reflex/Dom/Time.hs +++ b/src/Reflex/Dom/Time.hs @@ -8,6 +8,7 @@ import Control.Monad.IO.Class import Data.Fixed import Data.Time.Clock +import Data.Typeable data TickInfo = TickInfo { _tickInfo_lastUTC :: UTCTime @@ -17,7 +18,7 @@ , _tickInfo_alreadyElapsed :: NominalDiffTime -- ^ Amount of time already elapsed in the current tick period. } - deriving (Eq) + deriving (Eq, Ord, Typeable) -- | Special case of tickLossyFrom that uses the post-build event to start the -- tick thread. diff --git a/src/Reflex/Dom/Widget/Basic.hs b/src/Reflex/Dom/Widget/Basic.hs --- a/src/Reflex/Dom/Widget/Basic.hs +++ b/src/Reflex/Dom/Widget/Basic.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo, GADTs, DataKinds, RankNTypes, TemplateHaskell #-} module Reflex.Dom.Widget.Basic where @@ -30,16 +30,16 @@ import Control.Lens hiding (element, children) import Data.These import Data.Align - import Data.Maybe +import Data.GADT.Compare.TH +import Data.Bitraversable +import GHCJS.DOM.MouseEvent type AttributeMap = Map String String data El t = El { _el_element :: HTMLElement - , _el_clicked :: Event t () - , _el_keypress :: Event t Int - , _el_scrolled :: Event t Int + , _el_events :: EventSelector t (WrapArg EventResult EventName) } class Attributes m a where @@ -382,6 +382,226 @@ {-# SCC "e" #-} unsubscribe return $! {-# SCC "f" #-} e +data EventTag + = AbortTag + | BlurTag + | ChangeTag + | ClickTag + | ContextmenuTag + | DblclickTag + | DragTag + | DragendTag + | DragenterTag + | DragleaveTag + | DragoverTag + | DragstartTag + | DropTag + | ErrorTag + | FocusTag + | InputTag + | InvalidTag + | KeydownTag + | KeypressTag + | KeyupTag + | LoadTag + | MousedownTag + | MouseenterTag + | MouseleaveTag + | MousemoveTag + | MouseoutTag + | MouseoverTag + | MouseupTag +-- | 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 + | ScrollTag + | SelectTag + | SubmitTag +-- | WheelTag -- See MousewheelTag + | BeforecutTag + | CutTag + | BeforecopyTag + | CopyTag + | BeforepasteTag + | PasteTag + | ResetTag + | SearchTag + | SelectstartTag + | TouchstartTag + | TouchmoveTag + | TouchendTag + | TouchcancelTag + +data EventName :: EventTag -> * where + Abort :: EventName 'AbortTag + Blur :: EventName 'BlurTag + Change :: EventName 'ChangeTag + Click :: EventName 'ClickTag + Contextmenu :: EventName 'ContextmenuTag + Dblclick :: EventName 'DblclickTag + Drag :: EventName 'DragTag + Dragend :: EventName 'DragendTag + Dragenter :: EventName 'DragenterTag + Dragleave :: EventName 'DragleaveTag + Dragover :: EventName 'DragoverTag + Dragstart :: EventName 'DragstartTag + Drop :: EventName 'DropTag + Error :: EventName 'ErrorTag + Focus :: EventName 'FocusTag + Input :: EventName 'InputTag + Invalid :: EventName 'InvalidTag + Keydown :: EventName 'KeydownTag + Keypress :: EventName 'KeypressTag + Keyup :: EventName 'KeyupTag + Load :: EventName 'LoadTag + Mousedown :: EventName 'MousedownTag + Mouseenter :: EventName 'MouseenterTag + Mouseleave :: EventName 'MouseleaveTag + Mousemove :: EventName 'MousemoveTag + Mouseout :: EventName 'MouseoutTag + Mouseover :: EventName 'MouseoverTag + Mouseup :: EventName 'MouseupTag + --Mousewheel :: EventName 'MousewheelTag + Scroll :: EventName 'ScrollTag + Select :: EventName 'SelectTag + Submit :: EventName 'SubmitTag + --Wheel :: EventName 'WheelTag + Beforecut :: EventName 'BeforecutTag + Cut :: EventName 'CutTag + Beforecopy :: EventName 'BeforecopyTag + Copy :: EventName 'CopyTag + Beforepaste :: EventName 'BeforepasteTag + Paste :: EventName 'PasteTag + Reset :: EventName 'ResetTag + Search :: EventName 'SearchTag + Selectstart :: EventName 'SelectstartTag + Touchstart :: EventName 'TouchstartTag + Touchmove :: EventName 'TouchmoveTag + Touchend :: EventName 'TouchendTag + Touchcancel :: EventName 'TouchcancelTag + +type family EventType en where + EventType 'AbortTag = UIEvent + EventType 'BlurTag = UIEvent + EventType 'ChangeTag = UIEvent + EventType 'ClickTag = MouseEvent + EventType 'ContextmenuTag = MouseEvent + EventType 'DblclickTag = MouseEvent + EventType 'DragTag = MouseEvent + EventType 'DragendTag = MouseEvent + EventType 'DragenterTag = MouseEvent + EventType 'DragleaveTag = MouseEvent + EventType 'DragoverTag = MouseEvent + EventType 'DragstartTag = MouseEvent + EventType 'DropTag = MouseEvent + EventType 'ErrorTag = UIEvent + EventType 'FocusTag = UIEvent + EventType 'InputTag = UIEvent + EventType 'InvalidTag = UIEvent + EventType 'KeydownTag = UIEvent + EventType 'KeypressTag = UIEvent + EventType 'KeyupTag = UIEvent + EventType 'LoadTag = UIEvent + EventType 'MousedownTag = MouseEvent + EventType 'MouseenterTag = UIEvent + EventType 'MouseleaveTag = UIEvent + EventType 'MousemoveTag = MouseEvent + EventType 'MouseoutTag = MouseEvent + EventType 'MouseoverTag = MouseEvent + EventType 'MouseupTag = MouseEvent + --EventType 'MousewheelTag = MouseEvent + EventType 'ScrollTag = UIEvent + EventType 'SelectTag = UIEvent + EventType 'SubmitTag = UIEvent + --EventType 'WheelTag = UIEvent + EventType 'BeforecutTag = UIEvent + EventType 'CutTag = UIEvent + EventType 'BeforecopyTag = UIEvent + EventType 'CopyTag = UIEvent + EventType 'BeforepasteTag = UIEvent + EventType 'PasteTag = UIEvent + EventType 'ResetTag = UIEvent + EventType 'SearchTag = UIEvent + EventType 'SelectstartTag = UIEvent + EventType 'TouchstartTag = UIEvent + EventType 'TouchmoveTag = UIEvent + EventType 'TouchendTag = UIEvent + EventType 'TouchcancelTag = UIEvent + +onEventName :: IsElement e => EventName en -> e -> EventM (EventType en) e () -> IO (IO ()) +onEventName en = case en of + Abort -> elementOnabort + Blur -> elementOnblur + Change -> elementOnchange + Click -> elementOnclick + Contextmenu -> elementOncontextmenu + Dblclick -> elementOndblclick + Drag -> elementOndrag + Dragend -> elementOndragend + Dragenter -> elementOndragenter + Dragleave -> elementOndragleave + Dragover -> elementOndragover + Dragstart -> elementOndragstart + Drop -> elementOndrop + Error -> elementOnerror + Focus -> elementOnfocus + Input -> elementOninput + Invalid -> elementOninvalid + Keydown -> elementOnkeydown + Keypress -> elementOnkeypress + Keyup -> elementOnkeyup + Load -> elementOnload + Mousedown -> elementOnmousedown + Mouseenter -> elementOnmouseenter + Mouseleave -> elementOnmouseleave + Mousemove -> elementOnmousemove + Mouseout -> elementOnmouseout + Mouseover -> elementOnmouseover + Mouseup -> elementOnmouseup + --Mousewheel -> elementOnmousewheel + Scroll -> elementOnscroll + Select -> elementOnselect + Submit -> elementOnsubmit + --Wheel -> elementOnwheel + Beforecut -> elementOnbeforecut + Cut -> elementOncut + Beforecopy -> elementOnbeforecopy + Copy -> elementOncopy + Beforepaste -> elementOnbeforepaste + Paste -> elementOnpaste + Reset -> elementOnreset + Search -> elementOnsearch + Selectstart -> elementOnselectstart + Touchstart -> elementOntouchstart + Touchmove -> elementOntouchmove + Touchend -> elementOntouchend + Touchcancel -> elementOntouchcancel + +newtype EventResult en = EventResult { unEventResult :: EventResultType en } + +type family EventResultType (en :: EventTag) :: * where + EventResultType 'ClickTag = () + EventResultType 'DblclickTag = () + EventResultType 'KeypressTag = Int + EventResultType 'ScrollTag = Int + EventResultType 'MousemoveTag = (Int, Int) + EventResultType 'MousedownTag = (Int, Int) + EventResultType 'MouseupTag = (Int, Int) + EventResultType 'MouseenterTag = () + EventResultType 'MouseleaveTag = () + EventResultType 'FocusTag = () + EventResultType 'BlurTag = () + +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)) +wrapDomEventsMaybe element handlers = do + postGui <- askPostGui + runWithActions <- askRunWithActions + e <- newFanEventWithTrigger $ \(WrapArg en) et -> do + unsubscribe <- liftIO $ (onEventName en) element $ do + mv <- handlers en + forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> v] + return $ liftIO $ do + unsubscribe + return $! e + getKeyEvent :: EventM UIEvent e Int getKeyEvent = do e <- event @@ -392,12 +612,29 @@ if charCode /= 0 then return charCode else uiEventGetKeyCode e -wrapElement :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => HTMLElement -> m (El t) +getMouseEventCoords :: EventM MouseEvent e (Int, Int) +getMouseEventCoords = do + e <- event + liftIO $ bisequence (mouseEventGetX e, mouseEventGetY e) + +defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM (EventType en) e (Maybe (EventResult en)) +defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of + Click -> return () + Dblclick -> return () + Keypress -> getKeyEvent + Scroll -> liftIO $ elementGetScrollTop e + Mousemove -> getMouseEventCoords + Mouseup -> getMouseEventCoords + Mousedown -> getMouseEventCoords + Mouseenter -> return () + Mouseleave -> return () + Focus -> return () + Blur -> return () + +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) wrapElement e = do - clicked <- wrapDomEvent e elementOnclick (return ()) - keypress <- wrapDomEvent e elementOnkeypress getKeyEvent - scrolled <- wrapDomEvent e elementOnscroll $ liftIO $ elementGetScrollTop e - return $ El e clicked keypress scrolled + es <- wrapDomEventsMaybe e $ defaultDomEventHandler e + return $ El e es elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a) elDynAttr' elementTag attrs child = do @@ -479,10 +716,16 @@ = Link { _link_clicked :: Event t () } +class HasDomEvent t a where + domEvent :: EventName en -> a -> Event t (EventResultType en) + +instance Reflex t => HasDomEvent t (El t) where + domEvent en el = fmap unEventResult $ select (_el_events el) (WrapArg en) + linkClass :: MonadWidget t m => String -> String -> m (Link t) linkClass s c = do (l,_) <- elAttr' "a" ("class" =: c) $ text s - return $ Link $ _el_clicked l + return $ Link $ domEvent Click l link :: MonadWidget t m => String -> m (Link t) link s = linkClass s "" @@ -490,7 +733,7 @@ button :: MonadWidget t m => String -> m (Event t ()) button s = do (e, _) <- el' "button" $ text s - return $ _el_clicked e + return $ domEvent Click e newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) } @@ -556,3 +799,21 @@ p <- askParent _ <- liftIO $ nodeAppendChild p $ Just e wrapElement e + +deriveGEq ''EventName +deriveGCompare ''EventName + +-------------------------------------------------------------------------------- +-- Deprecated functions + +{-# DEPRECATED _el_clicked "Use `domEvent Click` instead" #-} +_el_clicked :: Reflex t => El t -> Event t () +_el_clicked = domEvent Click + +{-# DEPRECATED _el_keypress "Use `domEvent Keypress` instead" #-} +_el_keypress :: Reflex t => El t -> Event t Int +_el_keypress = domEvent Keypress + +{-# DEPRECATED _el_scrolled "Use `domEvent Scroll` instead" #-} +_el_scrolled :: Reflex t => El t -> Event t Int +_el_scrolled = domEvent Scroll diff --git a/src/Reflex/Dom/Widget/Input.hs b/src/Reflex/Dom/Widget/Input.hs --- a/src/Reflex/Dom/Widget/Input.hs +++ b/src/Reflex/Dom/Widget/Input.hs @@ -26,6 +26,7 @@ data TextInput t = TextInput { _textInput_value :: Dynamic t String + , _textInput_input :: Event t String , _textInput_keypress :: Event t Int , _textInput_keydown :: Event t Int , _textInput_keyup :: Event t Int @@ -66,7 +67,7 @@ eKeydown <- wrapDomEvent e elementOnkeydown getKeyEvent eKeyup <- wrapDomEvent e elementOnkeyup getKeyEvent dValue <- holdDyn initial $ leftmost [eSetValue, eChange] - return $ TextInput dValue eKeypress eKeydown eKeyup dFocus e + return $ TextInput dValue eChange eKeypress eKeydown eKeyup dFocus e textInputGetEnter :: Reflex t => TextInput t -> Event t () textInputGetEnter i = fmapMaybe (\n -> if n == keycodeEnter then Just () else Nothing) $ _textInput_keypress i @@ -85,6 +86,7 @@ data TextArea t = TextArea { _textArea_value :: Dynamic t String + , _textArea_input :: Event t String , _textArea_element :: HTMLTextAreaElement , _textArea_hasFocus :: Dynamic t Bool , _textArea_keypress :: Event t Int @@ -107,7 +109,7 @@ ev <- wrapDomEvent e elementOninput $ liftIO $ htmlTextAreaElementGetValue e v <- holdDyn initial $ leftmost [eSet, ev] eKeypress <- wrapDomEvent e elementOnkeypress getKeyEvent - return $ TextArea v e f eKeypress + return $ TextArea v ev e f eKeypress data CheckboxConfig t = CheckboxConfig { _checkboxConfig_setValue :: Event t Bool @@ -121,6 +123,7 @@ data Checkbox t = Checkbox { _checkbox_value :: Dynamic t Bool + , _checkbox_change :: Event t Bool } --TODO: Make attributes possibly dynamic @@ -133,7 +136,7 @@ eClick <- wrapDomEvent e elementOnclick $ liftIO $ htmlInputElementGetChecked e performEvent_ $ fmap (\v -> liftIO $ htmlInputElementSetChecked e $! v) $ _checkboxConfig_setValue config dValue <- holdDyn checked $ leftmost [_checkboxConfig_setValue config, eClick] - return $ Checkbox dValue + return $ Checkbox dValue eClick checkboxView :: MonadWidget t m => Dynamic t (Map String String) -> Dynamic t Bool -> m (Event t Bool) checkboxView dAttrs dValue = do @@ -149,6 +152,7 @@ data Dropdown t k = Dropdown { _dropdown_value :: Dynamic t k + , _dropdown_change :: Event t k } data DropdownConfig t k @@ -181,7 +185,7 @@ guard $ Map.member k opts return k dValue <- combineDyn readKey options =<< holdDyn (Just k0) (leftmost [eChange, fmap Just setK]) - return $ Dropdown dValue + return $ Dropdown dValue (attachDynWith readKey options eChange) liftM concat $ mapM makeLenses [ ''TextAreaConfig diff --git a/src/Reflex/Dom/Widget/Lazy.hs b/src/Reflex/Dom/Widget/Lazy.hs --- a/src/Reflex/Dom/Widget/Lazy.hs +++ b/src/Reflex/Dom/Widget/Lazy.hs @@ -33,9 +33,9 @@ currentTop <- mapDyn (listWrapperStyle . fst) window (_, lis) <- elDynAttr "div" totalHeightStyle $ tagWrapper listTag listAttrs currentTop $ listWithKey itemsInWindow $ \k v -> do (li,_) <- tagWrapper rowTag rowAttrs (constDyn $ toHeightStyle rowPx) $ itemBuilder k v - return $ fmap (const k) (_el_clicked li) + return $ fmap (const k) (domEvent Click li) return lis - scrollPosition <- holdDyn 0 $ _el_scrolled container + scrollPosition <- holdDyn 0 $ domEvent Scroll container window <- mapDyn (findWindow heightPx rowPx) scrollPosition itemsInWindow <- combineDyn (\(_,(idx,num)) is -> Map.fromList $ take num $ drop idx $ Map.toList is) window items postBuild <- getPostBuild diff --git a/src/Reflex/Dom/Xhr.hs b/src/Reflex/Dom/Xhr.hs --- a/src/Reflex/Dom/Xhr.hs +++ b/src/Reflex/Dom/Xhr.hs @@ -31,12 +31,14 @@ import Reflex import Reflex.Dom.Class import Reflex.Dom.Xhr.Foreign +import Data.Typeable data XhrRequest = XhrRequest { _xhrRequest_method :: String , _xhrRequest_url :: String , _xhrRequest_config :: XhrRequestConfig } + deriving (Show, Read, Eq, Ord, Typeable) data XhrRequestConfig = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String @@ -45,10 +47,12 @@ , _xhrRequestConfig_responseType :: Maybe String , _xhrRequestConfig_sendData :: Maybe String } + deriving (Show, Read, Eq, Ord, Typeable) data XhrResponse = XhrResponse { _xhrResponse_body :: Maybe Text } + deriving (Show, Read, Eq, Ord, Typeable) instance Default XhrRequestConfig where def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty