git.iko.soy/reflex-dom
on develop help sign in
Initial port to new ghcjs-dom
commitb2a30b77a3a7ce63445e11e771a306de99a56654 authorHamish Mackenzie <Hamish.K.Mackenzie@googlemail.com> dateSat 15 Oct 2016, 12:07 (10 years ago) parented3b790
14 files changed+433−396
compare with develop
unifiedsplit
reflex-dom.cabal+20−19 src-ghc/Reflex/Dom/Internal/Foreign.hs+126−122 src-ghcjs/Reflex/Dom/Internal/Foreign.hs+6 src/Foreign/JavaScript/TH.hs+72−134 src/Reflex/Dom.hs−3 src/Reflex/Dom/Builder/Immediate.hs+131−63 src/Reflex/Dom/Builder/InputDisabled.hs+1−1 src/Reflex/Dom/Internal.hs+27−20 src/Reflex/Dom/Old.hs+24−13 src/Reflex/Dom/Widget/Basic.hs−1 src/Reflex/Dom/Widget/Input.hs+5−4 src/Reflex/Dom/Widget/Lazy.hs+8−8 src/Reflex/Dom/Widget/Resize.hs+8−5 src/Reflex/Dom/Xhr.hs+5−3
reflex-dom.cabal+20−19
@@ -35,7 +35,7 @@ library
3535 these >= 0.4 && < 0.8,
3636 ref-tf == 0.4.*,
3737 random == 1.1.*,
38− ghcjs-dom >= 0.2.1 && < 0.3,
38+ ghcjs-dom >= 0.4.0.0 && < 0.5,
3939 transformers >= 0.3 && < 0.6,
4040 lens >= 4.7 && < 5,
4141 text == 1.2.*,
@@ -62,13 +62,14 @@ library
6262 else
6363 hs-source-dirs: src-ghc
6464 build-depends:
65− glib == 0.13.*,
66− gtk3 >= 0.13.0 && < 0.15,
67− webkitgtk3 == 0.14.*,
68− webkitgtk3-javascriptcore == 0.13.*,
65+ haskell-gi-base >=0.18 && <0.19,
66+ gi-glib >=2.0.6 && <2.1,
67+ gi-gtk >=3.0.6 && <3.1,
68+ gi-webkit2 >=4.0.6 && <4.1,
69+ jsaddle >=0.5.1.1 && <0.6,
6970 raw-strings-qq
7071 pkgconfig-depends:
71− webkitgtk-3.0 >= 1.8
72+ webkit2gtk-4.0 >= 2.12
7273 if !os(windows)
7374 build-depends: unix == 2.7.*
7475
@@ -83,30 +84,30 @@ library
8384 Reflex.Dom.Class
8485 Reflex.Dom.Internal
8586 Reflex.Dom.Internal.Foreign
86− Reflex.Dom.Location
87+-- Reflex.Dom.Location
8788 Reflex.Dom.Old
8889 Reflex.Dom.Time
89− Reflex.Dom.WebSocket
90+-- Reflex.Dom.WebSocket
9091 Reflex.Dom.Widget
9192 Reflex.Dom.Widget.Basic
9293 Reflex.Dom.Widget.Input
9394 Reflex.Dom.Widget.Lazy
9495 Reflex.Dom.Widget.Resize
95− Reflex.Dom.Xhr
96− other-modules:
97− Reflex.Dom.WebSocket.Foreign
98− Reflex.Dom.Xhr.Foreign
99− Reflex.Dom.Xhr.ResponseType
100− Reflex.Dom.Xhr.Exception
96+-- Reflex.Dom.Xhr
97+-- other-modules:
98+-- Reflex.Dom.WebSocket.Foreign
99+-- Reflex.Dom.Xhr.Foreign
100+-- Reflex.Dom.Xhr.ResponseType
101+-- Reflex.Dom.Xhr.Exception
101102
102103 other-extensions: TemplateHaskell
103104 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans
104105
105−test-suite hlint
106− build-depends: base, hlint == 1.9.*
107− hs-source-dirs: test
108− main-is: hlint.hs
109− type: exitcode-stdio-1.0
106+--test-suite hlint
107+-- build-depends: base, hlint == 1.9.*
108+-- hs-source-dirs: test
109+-- main-is: hlint.hs
110+-- type: exitcode-stdio-1.0
110111
111112source-repository head
112113 type: git
src-ghc/Reflex/Dom/Internal/Foreign.hs+126−122
@@ -1,8 +1,8 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ForeignFunctionInterface #-}
32{-# LANGUAGE LambdaCase #-}
43{-# LANGUAGE OverloadedStrings #-}
54{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE PatternSynonyms #-}
66module Reflex.Dom.Internal.Foreign where
77
88import Control.Concurrent
@@ -19,29 +19,38 @@ import qualified Data.Text as T
1919import Foreign.Marshal hiding (void)
2020import Foreign.Ptr
2121import GHCJS.DOM hiding (runWebGUI)
22+import GHCJS.DOM.Types (runJSM, askJSM, JSContextRef(..))
2223import GHCJS.DOM.Navigator
2324import GHCJS.DOM.Window
24−import Graphics.UI.Gtk hiding (Widget)
25−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
26−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
27−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
28−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
29−import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
30−import Graphics.UI.Gtk.WebKit.Types hiding (Event, Text, Widget)
31−import Graphics.UI.Gtk.WebKit.WebFrame
32−import Graphics.UI.Gtk.WebKit.WebInspector
33−import Graphics.UI.Gtk.WebKit.WebSettings
34−import Graphics.UI.Gtk.WebKit.WebView
3525import System.Directory
36−import System.Glib.FFI hiding (void)
26+import qualified GI.Gtk.Functions as Gtk (init, main)
27+import GI.WebKit2
28+ (webViewLoadUri, webViewLoadHtml, webViewGetInspector,
29+ onWebViewLoadChanged, webViewSetSettings,
30+ settingsSetEnableDeveloperExtras, settingsSetUserAgent,
31+ settingsGetUserAgent, webViewGetSettings, webViewNew, WebView)
3732
3833#ifndef mingw32_HOST_OS
3934import System.Posix.Signals
4035#endif
36+import GI.GLib.Functions (timeoutAdd, idleAdd)
37+import GI.GLib.Constants (pattern PRIORITY_DEFAULT, pattern PRIORITY_HIGH)
38+import GI.Gtk.Objects.Widget
39+ (widgetShowAll, onWidgetDestroy, widgetDestroy, widgetGetToplevel)
40+import GI.Gtk.Objects.Window
41+ (windowSetPosition, windowSetDefaultSize, windowNew)
42+import GI.Gtk.Enums (WindowType(..), WindowPosition(..))
43+import GI.Gtk.Objects.ScrolledWindow (scrolledWindowNew)
44+import GI.Gtk.Objects.Adjustment (noAdjustment)
45+import GI.Gtk.Objects.Container (containerAdd)
46+import GI.Gtk.Functions (mainQuit)
47+import Control.Monad.Trans.Reader (ask)
4148
4249quitWebView :: WebView -> IO ()
43−quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't this be postGUISync?
44− widgetDestroy w
50+quitWebView wv = void . idleAdd PRIORITY_DEFAULT $ do --TODO: Shouldn't this be Sync?
51+ w <- widgetGetToplevel wv
52+ widgetDestroy w
53+ return False
4554
4655installQuitHandler :: WebView -> IO ()
4756#ifdef mingw32_HOST_OS
@@ -50,119 +59,114 @@ installQuitHandler wv = return () -- TODO: Maybe figure something out here for W
5059installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing
5160#endif
5261
53−makeDefaultWebView :: Text -> (WebView -> IO ()) -> IO ()
54−makeDefaultWebView userAgentKey main = do
55− _ <- initGUI
56− window <- windowNew
57− _ <- timeoutAddFull (yield >> return True) priorityHigh 10
62+runWebGUI :: ((WebView, JSContextRef) -> IO ()) -> IO ()
63+runWebGUI main = do
64+ _ <- Gtk.init Nothing
65+ window <- windowNew WindowTypeToplevel
66+ _ <- timeoutAdd PRIORITY_HIGH 10 (yield >> return True)
5867 windowSetDefaultSize window 900 600
59− windowSetPosition window WinPosCenter
60− scrollWin <- scrolledWindowNew Nothing Nothing
68+ windowSetPosition window WindowPositionCenter
69+ scrollWin <- scrolledWindowNew noAdjustment noAdjustment
6170 webView <- webViewNew
62− settings <- webViewGetWebSettings webView
63− userAgent <- settings `get` webSettingsUserAgent
64− settings `set` [ webSettingsUserAgent := userAgent <> " " <> userAgentKey
65− , webSettingsEnableUniversalAccessFromFileUris := True
66− , webSettingsEnableDeveloperExtras := True
67− ]
68− webViewSetWebSettings webView settings
71+ putStrLn "forking server!"
72+ _ <- forkIO $ run 3706 $ do
73+ ctx <- askJSM
74+ liftIO $ forkIO $ forever $ do
75+ threadDelay 1000000
76+ runJSM syncPoint ctx
77+-- liftIO $ threadDelay 20000000
78+-- idleAdd PRIORITY_DEFAULT $ do
79+ liftIO $ main (webView, ctx)
80+ liftIO $ putStrLn "main exited"
81+ -- return False
82+ forever $ do
83+ liftIO $ threadDelay 100000
84+ settings <- webViewGetSettings webView
85+ -- TODO settingsSetEnableUniversalAccessFromFileUris settings True
86+ settingsSetEnableDeveloperExtras settings True
87+ webViewSetSettings webView settings
6988 window `containerAdd` scrollWin
7089 scrollWin `containerAdd` webView
71− _ <- on window objectDestroy . liftIO $ mainQuit
90+ _ <- onWidgetDestroy window mainQuit
7291 widgetShowAll window
73− _ <- webView `on` loadFinished $ \_ -> do
74− main webView --TODO: Should probably only do this once
92+-- _ <- onWebViewLoadChanged webView $ \_ ->
93+-- -- TODO run jsaddle.js when load is finished
94+-- return ()
7595 inspector <- webViewGetInspector webView
76− _ <- inspector `on` inspectWebView $ \_ -> do
77− inspectorWindow <- windowNew
78− windowSetDefaultSize inspectorWindow 900 600
79− inspectorScrollWin <- scrolledWindowNew Nothing Nothing
80− inspectorWebView <- webViewNew
81− inspectorWindow `containerAdd` inspectorScrollWin
82− inspectorScrollWin `containerAdd` inspectorWebView
83− widgetShowAll inspectorWindow
84− return inspectorWebView
85− wf <- webViewGetMainFrame webView
96+-- _ <- inspector `on` inspectWebView $ \_ -> do
97+-- inspectorWindow <- windowNew
98+-- windowSetDefaultSize inspectorWindow 900 600
99+-- inspectorScrollWin <- scrolledWindowNew noAdjustment noAdjustment
100+-- inspectorWebView <- webViewNew
101+-- inspectorWindow `containerAdd` inspectorScrollWin
102+-- inspectorScrollWin `containerAdd` inspectorWebView
103+-- widgetShowAll inspectorWindow
104+-- return inspectorWebView
86105 pwd <- getCurrentDirectory
87− webFrameLoadString wf "" Nothing $ "file://" <> pwd <> "/"
106+-- webViewLoadHtml webView "" . Just $ "file://" <> T.pack pwd <> "/"
107+ webViewLoadUri webView "http://localhost:3706/"
88108 installQuitHandler webView
89− mainGUI
109+ Gtk.main
90110
91−runWebGUI :: (WebView -> IO ()) -> IO ()
92−runWebGUI = runWebGUI' "GHCJS"
93−
94−runWebGUI' :: Text -> (WebView -> IO ()) -> IO ()
95−runWebGUI' userAgentKey main = do
96− -- Are we in a java script inside some kind of browser
97− mbWindow <- currentWindow
98− case mbWindow of
99− Just window -> do
100− -- Check if we are running in javascript inside the the native version
101− Just n <- getNavigator window
102− agent <- getUserAgent n
103− unless ((" " <> userAgentKey) `T.isSuffixOf` agent) $ main (castToWebView window)
104− Nothing -> do
105− makeDefaultWebView userAgentKey main
106−
107−foreign import ccall "wrapper"
108− wrapper :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback
109−
110−toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef
111−toJSObject ctx args = do
112− o <- jsobjectmake ctx nullPtr nullPtr
113− iforM_ args $ \n a -> do
114− prop <- jsstringcreatewithutf8cstring $ show n
115− jsobjectsetproperty ctx o prop a 1 nullPtr
116− return o
117−
118−fromJSStringMaybe :: JSContextRef -> JSValueRef -> IO (Maybe Text)
119−fromJSStringMaybe c t = do
120− isNull <- jsvalueisnull c t
121− if isNull then return Nothing else do
122− j <- jsvaluetostringcopy c t nullPtr
123− l <- jsstringgetmaximumutf8cstringsize j
124− s <- allocaBytes (fromIntegral l) $ \ps -> do
125− _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
126− peekCString ps
127− return $ Just $ T.pack s
128−
129−getLocationHost :: WebView -> IO Text
130−getLocationHost wv = withWebViewContext wv $ \c -> do
131− script <- jsstringcreatewithutf8cstring "location.host"
132− lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr
133− lh' <- fromJSStringMaybe c lh
134− return $ fromMaybe "" lh'
135−
136−getLocationProtocol :: WebView -> IO Text
137−getLocationProtocol wv = withWebViewContext wv $ \c -> do
138− script <- jsstringcreatewithutf8cstring "location.protocol"
139− lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr
140− lp' <- fromJSStringMaybe c lp
141− return $ fromMaybe "" lp'
142−
143−bsToArrayBuffer :: JSContextRef -> ByteString -> IO JSValueRef
144−bsToArrayBuffer c bs = do
145− elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x
146− let numElems = length elems
147− bracket (mallocArray numElems) free $ \elemsArr -> do
148− pokeArray elemsArr elems
149− a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr
150− newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"
151− jsevaluatescript c newUint8Array a nullPtr 1 nullPtr
152−
153−bsFromArrayBuffer :: JSContextRef -> JSValueRef -> IO ByteString
154−bsFromArrayBuffer c a = do
155− let getIntegral = fmap round . (\x -> jsvaluetonumber c x nullPtr)
156− getByteLength <- jsstringcreatewithutf8cstring "this.byteLength"
157− byteLength <- getIntegral =<< jsevaluatescript c getByteLength a nullPtr 1 nullPtr
158− toUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"
159− uint8Array <- jsevaluatescript c toUint8Array a nullPtr 1 nullPtr
160− getIx <- jsstringcreatewithutf8cstring "this[0][this[1]]"
161− let arrayLookup i = do
162− i' <- jsvaluemakenumber c (fromIntegral i)
163− args <- toJSObject c [uint8Array, i']
164− getIntegral =<< jsevaluatescript c getIx args nullPtr 1 nullPtr
165− BS.pack <$> forM [0..byteLength-1] arrayLookup
166−
167−withWebViewContext :: WebView -> (JSContextRef -> IO a) -> IO a
168−withWebViewContext wv f = f =<< webFrameGetGlobalContext =<< webViewGetMainFrame wv
111+--foreign import ccall "wrapper"
112+-- wrapper :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback
113+--
114+--toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef
115+--toJSObject ctx args = do
116+-- o <- jsobjectmake ctx nullPtr nullPtr
117+-- iforM_ args $ \n a -> do
118+-- prop <- jsstringcreatewithutf8cstring $ show n
119+-- jsobjectsetproperty ctx o prop a 1 nullPtr
120+-- return o
121+--
122+--fromJSStringMaybe :: JSContextRef -> JSValueRef -> IO (Maybe Text)
123+--fromJSStringMaybe c t = do
124+-- isNull <- jsvalueisnull c t
125+-- if isNull then return Nothing else do
126+-- j <- jsvaluetostringcopy c t nullPtr
127+-- l <- jsstringgetmaximumutf8cstringsize j
128+-- s <- allocaBytes (fromIntegral l) $ \ps -> do
129+-- _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
130+-- peekCString ps
131+-- return $ Just $ T.pack s
132+--
133+--getLocationHost :: WebView -> IO Text
134+--getLocationHost wv = withWebViewContext wv $ \c -> do
135+-- script <- jsstringcreatewithutf8cstring "location.host"
136+-- lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr
137+-- lh' <- fromJSStringMaybe c lh
138+-- return $ fromMaybe "" lh'
139+--
140+--getLocationProtocol :: WebView -> IO Text
141+--getLocationProtocol wv = withWebViewContext wv $ \c -> do
142+-- script <- jsstringcreatewithutf8cstring "location.protocol"
143+-- lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr
144+-- lp' <- fromJSStringMaybe c lp
145+-- return $ fromMaybe "" lp'
146+--
147+--bsToArrayBuffer :: JSContextRef -> ByteString -> IO JSValueRef
148+--bsToArrayBuffer c bs = do
149+-- elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x
150+-- let numElems = length elems
151+-- bracket (mallocArray numElems) free $ \elemsArr -> do
152+-- pokeArray elemsArr elems
153+-- a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr
154+-- newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"
155+-- jsevaluatescript c newUint8Array a nullPtr 1 nullPtr
156+--
157+--bsFromArrayBuffer :: JSContextRef -> JSValueRef -> IO ByteString
158+--bsFromArrayBuffer c a = do
159+-- let getIntegral = fmap round . (\x -> jsvaluetonumber c x nullPtr)
160+-- getByteLength <- jsstringcreatewithutf8cstring "this.byteLength"
161+-- byteLength <- getIntegral =<< jsevaluatescript c getByteLength a nullPtr 1 nullPtr
162+-- toUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"
163+-- uint8Array <- jsevaluatescript c toUint8Array a nullPtr 1 nullPtr
164+-- getIx <- jsstringcreatewithutf8cstring "this[0][this[1]]"
165+-- let arrayLookup i = do
166+-- i' <- jsvaluemakenumber c (fromIntegral i)
167+-- args <- toJSObject c [uint8Array, i']
168+-- getIntegral =<< jsevaluatescript c getIx args nullPtr 1 nullPtr
169+-- BS.pack <$> forM [0..byteLength-1] arrayLookup
170+--
171+--withWebViewContext :: WebView -> (JSContextRef -> IO a) -> IO a
172+--withWebViewContext wv f = f =<< webFrameGetGlobalContext =<< webViewGetMainFrame wv
src-ghcjs/Reflex/Dom/Internal/Foreign.hs+6
@@ -2,6 +2,7 @@
22{-# LANGUAGE JavaScriptFFI #-}
33module Reflex.Dom.Internal.Foreign ( module Reflex.Dom.Internal.Foreign
44 , runWebGUI
5+ , WebView
56 ) where
67
78import Data.ByteString (ByteString)
@@ -15,6 +16,11 @@ import qualified GHCJS.Marshal.Pure as JS
1516import GHCJS.Types
1617import JavaScript.TypedArray.ArrayBuffer as JS
1718
19+data WebView = WebView
20+
21+runWebGUI :: ((WebView, JSContextRef) -> IO ()) -> IO ()
22+runWebGUI main = run 0 (main (WebView, ()))
23+
1824quitWebView :: WebView -> IO ()
1925quitWebView = error "quitWebView: unimplemented in GHCJS"
2026
src/Foreign/JavaScript/TH.hs+72−134
@@ -20,6 +20,7 @@ module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH
2020 , Safety (..)
2121 ) where
2222
23+import Prelude hiding((!!))
2324import Reflex.Class
2425import Reflex.Deletable.Class
2526import Reflex.DynamicWriter
@@ -30,10 +31,11 @@ import Reflex.Host.Class
3031
3132import Language.Haskell.TH
3233
34+import GHCJS.DOM.Types
35+ (toJSString, liftJSM, askJSM, runJSM, JSContextRef,
36+ Node(..), MonadJSM(..), toJSVal, JSVal)
3337#ifdef __GHCJS__
3438import qualified GHCJS.Buffer as JS
35−import GHCJS.DOM
36−import GHCJS.DOM.Types hiding (Text, fromJSString)
3739import qualified GHCJS.DOM.Types as JS
3840import qualified GHCJS.Foreign as JS
3941import qualified GHCJS.Foreign.Callback as JS
@@ -52,16 +54,17 @@ import Data.Word
5254import Foreign.C.Types
5355import Foreign.Ptr
5456import Text.Encoding.Z
57+
58+import Reflex.Dom.Internal.Foreign (WebView)
5559#else
56−import Foreign.Marshal
57−import Graphics.UI.Gtk.WebKit.DOM.Node
58−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
59−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
60−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
61−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
62−import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
63−import Graphics.UI.Gtk.WebKit.WebView
64−import System.Glib.FFI
60+import Data.Word (Word8)
61+import GI.WebKit2 (WebView)
62+import Control.Lens.Operators ((^.))
63+import Language.Javascript.JSaddle
64+ (eval, valMakeString, valToNumber, function,
65+ valMakeNumber, valBool, valToText, valToBool, valIsUndefined,
66+ valUndefined, valIsNull, Function(..), (!!),
67+ js, js1, jss, array, freeFunction)
6568#endif
6669
6770import Control.Concurrent
@@ -76,7 +79,6 @@ import qualified Control.Monad.State.Strict as Strict
7679import Control.Monad.Trans.Control
7780import Data.ByteString (ByteString)
7881import qualified Data.ByteString as BS
79−import Data.Coerce
8082import Data.Monoid
8183import Data.Text (Text)
8284import qualified Data.Text as T
@@ -174,11 +176,11 @@ instance MonadRef m => MonadRef (WithWebView x m) where
174176instance MonadAtomicRef m => MonadAtomicRef (WithWebView x m) where
175177 atomicModifyRef r = lift . atomicModifyRef r
176178
177−withWebViewSingleton :: WebView -> (forall x. WebViewSingleton x -> r) -> r
179+withWebViewSingleton :: (WebView, JSContextRef) -> (forall x. WebViewSingleton x -> r) -> r
178180withWebViewSingleton wv f = f $ WebViewSingleton wv
179181
180182-- | A singleton type for a given WebView; we use this to statically guarantee that different WebViews (and thus different javscript contexts) don't get mixed up
181−newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: WebView }
183+newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: (WebView, JSContextRef) }
182184
183185#ifdef __GHCJS__
184186type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal
@@ -187,35 +189,36 @@ newtype JSFFI = JSFFI JSFFI_Internal
187189newtype JSFFI = JSFFI String
188190#endif
189191
190−newtype JSFun x = JSFun { unJSFun :: JSRef x }
192+data JSFun x = JSFun { unJSFun :: JSRef x
193+#ifndef __GHCJS__
194+ , unJSFunction :: Function
195+#endif
196+ }
191197
192198instance ToJS x (JSFun x) where
193− withJS (JSFun r) f = f r
194−
195−instance FromJS x (JSFun x) where
196− fromJS = return . JSFun
199+ withJS r f = f (unJSFun r)
197200
198201class IsJSContext x where
199202 data JSRef x
200203
201−class (Monad m, MonadIO (JSM m), MonadFix (JSM m), MonadJS x (JSM m)) => HasJS x m | m -> x where
202− type JSM m :: * -> *
203− liftJS :: JSM m a -> m a
204+class (Monad m, MonadIO (JSX m), MonadFix (JSX m), MonadJS x (JSX m)) => HasJS x m | m -> x where
205+ type JSX m :: * -> *
206+ liftJS :: JSX m a -> m a
204207
205208instance HasJS x m => HasJS x (ReaderT r m) where
206− type JSM (ReaderT r m) = JSM m
209+ type JSX (ReaderT r m) = JSX m
207210 liftJS = lift . liftJS
208211
209212instance (HasJS x m, ReflexHost t) => HasJS x (PostBuildT t m) where
210− type JSM (PostBuildT t m) = JSM m
213+ type JSX (PostBuildT t m) = JSX m
211214 liftJS = lift . liftJS
212215
213216instance (HasJS x (HostFrame t), ReflexHost t) => HasJS x (PerformEventT t m) where
214− type JSM (PerformEventT t m) = JSM (HostFrame t)
217+ type JSX (PerformEventT t m) = JSX (HostFrame t)
215218 liftJS = PerformEventT . lift . liftJS
216219
217220instance HasJS x m => HasJS x (DynamicWriterT t w m) where
218− type JSM (DynamicWriterT t w m) = JSM m
221+ type JSX (DynamicWriterT t w m) = JSX m
219222 liftJS = lift . liftJS
220223
221224-- | A Monad that is capable of executing JavaScript
@@ -247,7 +250,7 @@ class Monad m => MonadJS x m | m -> x where
247250data JSCtx_IO
248251
249252instance MonadIO m => HasJS JSCtx_IO (WithWebView x m) where
250− type JSM (WithWebView x m) = IO
253+ type JSX (WithWebView x m) = IO
251254 liftJS = liftIO
252255
253256instance IsJSContext JSCtx_IO where
@@ -296,25 +299,13 @@ foreign import javascript unsafe "function(){ return $1(arguments); }" funWithAr
296299
297300#else
298301
299−-- | Make a JS string available that is not wrapped up as a JSValueRef
300−withJSStringRaw :: MonadAsyncException m => String -> (JSStringRef -> m r) -> m r
301−withJSStringRaw str a = do
302− bracket (liftIO $ jsstringcreatewithutf8cstring str) (liftIO . jsstringrelease) $ \strRef -> do
303− a strRef
304−
305−fromJSNumberRaw :: (MonadIO m, HasJSContext m) => JSValueRef -> m Double
306−fromJSNumberRaw val = do
307− jsContext <- askJSContext
308− liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
309−
310−
311302data JSCtx_JavaScriptCore x
312303
313304instance IsJSContext (JSCtx_JavaScriptCore x) where
314− newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSValueRef }
305+ newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSVal }
315306
316307instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithWebView x m) where
317− type JSM (WithWebView x m) = WithWebView x IO
308+ type JSX (WithWebView x m) = WithWebView x IO
318309 liftJS a = do
319310 wv <- askWebView
320311 liftIO $ runWithWebView a wv
@@ -324,23 +315,21 @@ newtype WithJSContext x m a = WithJSContext { unWithJSContext :: ReaderT JSConte
324315runWithJSContext :: WithJSContext x m a -> JSContextRef -> m a
325316runWithJSContext = runReaderT . unWithJSContext
326317
327−class Monad m => HasJSContext m where
328− askJSContext :: m JSContextRef
329−
330−instance MonadIO m => HasJSContext (WithWebView x m) where
331− askJSContext = do
318+instance MonadIO m => MonadJSM (WithWebView x m) where
319+ liftJSM' f = do
332320 wv <- askWebView
333− liftIO $ webFrameGetGlobalContext =<< webViewGetMainFrame (unWebViewSingleton wv)
321+ runJSM f . snd $ unWebViewSingleton wv
334322
335−instance Monad m => HasJSContext (WithJSContext x m) where
336− askJSContext = WithJSContext ask
323+instance MonadIO m => MonadJSM (WithJSContext x m) where
324+ liftJSM' f =
325+ runJSM f =<< WithJSContext ask
337326
338−lowerWithJSContext :: (HasJSContext m, MonadIO m) => WithJSContext x IO a -> m a
327+lowerWithJSContext :: MonadJSM m => WithJSContext x IO a -> m a
339328lowerWithJSContext a = do
340− c <- askJSContext
329+ c <- askJSM
341330 liftIO $ runWithJSContext a c
342331
343−liftWithWebViewThroughWithJSContext :: (HasJSContext m, HasWebView m, MonadIO m, MonadTrans t, Monad m1)
332+liftWithWebViewThroughWithJSContext :: (HasWebView m, MonadJSM m, MonadTrans t, Monad m1)
344333 => ((t1 -> t m1 a) -> WithJSContext x IO b)
345334 -> (t1 -> WithWebView (WebViewPhantom m) m1 a)
346335 -> m b
@@ -375,96 +364,45 @@ instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
375364 getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef
376365
377366instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContext x IO) where
378− runJS (JSFFI body) args = do
379− jsContext <- askJSContext
380− withJSArray args $ \(JSRef_JavaScriptCore this) -> liftIO $ do
381− result <- bracket (jsstringcreatewithutf8cstring body) jsstringrelease $ \script -> jsevaluatescript jsContext script this nullPtr 1 nullPtr
382− return $ JSRef_JavaScriptCore result --TODO: Protect and unprotect result
367+ runJS (JSFFI body) args =
368+ withJSArray args $ \(JSRef_JavaScriptCore this) -> do
369+ result <- liftJSM $ eval ("(function(){ return (" <> body <> "); })") ^. js1 "apply" this
370+ return $ JSRef_JavaScriptCore result
383371 forkJS a = do
384− c <- askJSContext
385− liftIO $ forkIO $ runWithJSContext a c
386− mkJSUndefined = do
387− jsContext <- askJSContext
388− fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext
389− isJSNull (JSRef_JavaScriptCore r) = do
390− jsContext <- askJSContext
391− liftIO $ jsvalueisnull jsContext r
392− isJSUndefined (JSRef_JavaScriptCore r) = do
393− jsContext <- askJSContext
394− liftIO $ jsvalueisundefined jsContext r
395− fromJSBool (JSRef_JavaScriptCore r) = do
396− jsContext <- askJSContext
397− liftIO $ jsvaluetoboolean jsContext r
398− fromJSString (JSRef_JavaScriptCore r) = do
399− jsContext <- askJSContext
400− liftIO $ do
401− s <- jsvaluetostringcopy jsContext r nullPtr --TODO: Deal with exceptions
402− l <- jsstringgetmaximumutf8cstringsize s
403− allocaBytes (fromIntegral l) $ \ps -> do
404− _ <- jsstringgetutf8cstring'_ s ps (fromIntegral l)
405− peekCString ps
406− withJSBool b a = do
407− jsContext <- askJSContext
408− valRef <- liftIO $ jsvaluemakeboolean jsContext b
409− a $ JSRef_JavaScriptCore valRef
410− withJSString str a = do
411− jsContext <- askJSContext
412− withJSStringRaw str $ \strRef -> do
413− valRef <- liftIO $ jsvaluemakestring jsContext strRef
414− a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
415− withJSNumber n a = do
416− jsContext <- askJSContext
417− valRef <- liftIO $ jsvaluemakenumber jsContext n
418− a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef
419− withJSArray elems a = do
420− jsContext <- askJSContext
421− let numElems = length elems
422− bracket (liftIO $ mallocArray numElems) (liftIO . free) $ \elemsArr -> do
423− liftIO $ pokeArray elemsArr $ coerce elems
424− bracket (liftIO $ jsobjectmakearray jsContext (fromIntegral numElems) elemsArr nullPtr) (const $ return ()) $ \arrRef -> do --TODO: Do we need to protect/unprotect the array object?
425− a $ JSRef_JavaScriptCore arrRef --TODO: Protect/unprotect valRef
426− --TODO: When supported by webkitgtk3-javascriptcore, go directly from C string to Uint8Array without creating each item individually
372+ c <- askJSM
373+ liftIO . forkIO $ runWithJSContext a c
374+ mkJSUndefined = return $ JSRef_JavaScriptCore valUndefined
375+ isJSNull (JSRef_JavaScriptCore r) = liftJSM $ valIsNull r
376+ isJSUndefined (JSRef_JavaScriptCore r) = liftJSM $ valIsUndefined r
377+ fromJSBool (JSRef_JavaScriptCore r) = liftJSM $ valToBool r
378+ fromJSString (JSRef_JavaScriptCore r) = liftJSM (T.unpack <$> valToText r)
379+ withJSBool b a = a $ JSRef_JavaScriptCore (valBool b)
380+ withJSString str a = a . JSRef_JavaScriptCore =<< liftJSM (valMakeString $ toJSString str)
381+ withJSNumber n a = a . JSRef_JavaScriptCore =<< liftJSM (valMakeNumber n)
382+ withJSArray elems a = a . JSRef_JavaScriptCore =<< liftJSM
383+ (toJSVal =<< array (map (\(JSRef_JavaScriptCore r) -> r) elems))
427384 withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do
428385 payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]
429386 f $ JSUint8Array payloadRef
430− fromJSArray (JSRef_JavaScriptCore a) = do
431− jsContext <- askJSContext
432− lenRef <- withJSStringRaw "length" $ \lengthStr -> do
433− liftIO $ jsobjectgetproperty jsContext a lengthStr nullPtr --TODO: Exceptions
434− lenDouble <- fromJSNumberRaw lenRef
435− let len = round lenDouble
436− liftIO $ forM [0..len-1] $ \i -> do
437− JSRef_JavaScriptCore <$> jsobjectgetpropertyatindex jsContext a i nullPtr --TODO: Exceptions
387+ fromJSArray (JSRef_JavaScriptCore a) = liftJSM $ do
388+ len <- round <$> (valToNumber =<< (a ^. js "length"))
389+ forM [0..len-1] $ \i -> JSRef_JavaScriptCore <$> a !! i
438390 fromJSUint8Array a = do
439391 vals <- fromJSArray a
440392 doubles <- mapM fromJSNumber vals
441393 return $ BS.pack $ map round doubles
442− fromJSNumber (JSRef_JavaScriptCore val) = do
443− jsContext <- askJSContext
444− liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
445− mkJSFun a = do
446− jsContext <- askJSContext
447− cb <- liftIO $ mkJSObjectCallAsFunctionCallback $ \_ _ _ argc argv _ -> do --TODO: Use the exception pointer to handle haskell exceptions
448− args <- forM [0..fromIntegral (argc-1)] $ \n -> do
449− x <- peekElemOff argv n
450− jsvalueprotect jsContext x
451− return $ JSRef_JavaScriptCore x --TODO: Unprotect eventually
452− unJSRef_JavaScriptCore <$> runWithJSContext (a args) jsContext
453− cbRef <- liftIO $ jsobjectmakefunctionwithcallback jsContext nullPtr cb
454− liftIO $ jsvalueprotect jsContext cbRef
455− return $ JSFun $ JSRef_JavaScriptCore cbRef
456− freeJSFun (JSFun (JSRef_JavaScriptCore f)) = do
457− jsContext <- askJSContext
458− liftIO $ jsvalueunprotect jsContext f
459− setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) = do
460− withJSStringRaw propName $ \propNameRaw -> do
461− jsContext <- askJSContext
462− liftIO $ jsobjectsetproperty jsContext objRef propNameRaw valRef 0 nullPtr --TODO: property attribute, exceptions
463− getJSProp propName (JSRef_JavaScriptCore objRef) = do
464− withJSStringRaw propName $ \propNameRaw -> do
465− jsContext <- askJSContext
466− liftIO $ JSRef_JavaScriptCore <$> jsobjectgetproperty jsContext objRef propNameRaw nullPtr --TODO: property attribute, exceptions
467− withJSNode = error "withJSNode is only supported in ghcjs"
394+ fromJSNumber (JSRef_JavaScriptCore val) = liftJSM $ valToNumber val
395+ mkJSFun a = liftJSM $ do
396+ ctx <- askJSM
397+ f <- function $ \_ _ args -> liftIO $ void $ runWithJSContext (a $ map JSRef_JavaScriptCore args) ctx
398+ fRef <- toJSVal f
399+ return $ JSFun (JSRef_JavaScriptCore fRef) f
400+ freeJSFun (JSFun _ f) = liftJSM $ freeFunction f
401+ setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) =
402+ liftJSM $ objRef ^. jss propName valRef
403+ getJSProp propName (JSRef_JavaScriptCore objRef) =
404+ JSRef_JavaScriptCore <$> liftJSM (objRef ^. js propName)
405+ withJSNode n f = f . JSRef_JavaScriptCore =<< liftJSM (toJSVal n)
468406
469407#endif
470408
src/Reflex/Dom.hs−3
@@ -7,9 +7,6 @@ import Reflex.Dom.Builder.InputDisabled as X
77import Reflex.Dom.Builder.Static as X
88import Reflex.Dom.Class as X
99import Reflex.Dom.Internal as X
10−import Reflex.Dom.Location as X
1110import Reflex.Dom.Old as X
1211import Reflex.Dom.Time as X
13−import Reflex.Dom.WebSocket as X
1412import Reflex.Dom.Widget as X
15−import Reflex.Dom.Xhr as X
src/Reflex/Dom/Builder/Immediate.hs+131−63
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE ConstraintKinds #-}
23{-# LANGUAGE DataKinds #-}
34{-# LANGUAGE EmptyDataDecls #-}
@@ -53,9 +54,12 @@ import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea
5354import GHCJS.DOM.MouseEvent
5455import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling, insertBefore,
5556 removeChild, setNodeValue, toNode)
56−import GHCJS.DOM.Types (FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, ToDOMString, TouchEvent,
57− WheelEvent, castToHTMLInputElement, castToHTMLSelectElement,
58− castToHTMLTextAreaElement)
57+import GHCJS.DOM.Types
58+ (liftJSM, askJSM, runJSM, JSM, MonadJSM(..),
59+ FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node,
60+ ToDOMString, TouchEvent, WheelEvent, castToHTMLInputElement,
61+ castToHTMLSelectElement, castToHTMLTextAreaElement,
62+ strictEqual)
5963import qualified GHCJS.DOM.Types as DOM
6064import GHCJS.DOM.UIEvent
6165import qualified GHCJS.DOM.Window as Window
@@ -64,7 +68,7 @@ import Debug.Trace hiding (traceEvent)
6468
6569data TriggerRef t a = TriggerRef { unTriggerRef :: IORef (Maybe (EventTrigger t a)) }
6670
67−data TriggerInvocation a = TriggerInvocation a (IO ())
71+data TriggerInvocation a = TriggerInvocation a (JSM ())
6872
6973data ImmediateDomBuilderEnv t
7074 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document
@@ -74,6 +78,11 @@ data ImmediateDomBuilderEnv t
7478
7579newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
7680
81+#ifndef __GHCJS__
82+instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
83+ liftJSM' = ImmediateDomBuilderT . liftJSM'
84+#endif
85+
7786instance MonadTransControl (ImmediateDomBuilderT t) where
7887 type StT (ImmediateDomBuilderT t) a = StT (ReaderT (ImmediateDomBuilderEnv t)) a
7988 liftWith = defaultLiftWith ImmediateDomBuilderT unImmediateDomBuilderT
@@ -99,23 +108,23 @@ askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (TriggerRef t) Trig
99108askEvents = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_events
100109
101110{-# INLINABLE append #-}
102−append :: (IsNode n, MonadIO m) => n -> ImmediateDomBuilderT t m ()
111+append :: (IsNode n, MonadJSM m) => n -> ImmediateDomBuilderT t m ()
103112append n = do
104113 p <- askParent
105− _ <- liftIO $ appendChild p $ Just n
114+ _ <- liftJSM $ appendChild p $ Just n
106115 return ()
107116
108117{-# INLINABLE textNodeInternal #-}
109−textNodeInternal :: (MonadIO m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Text
118+textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Text
110119textNodeInternal t = do
111120 doc <- askDocument
112− Just n <- liftIO $ createTextNode doc t
121+ Just n <- liftJSM $ createTextNode doc t
113122 append n
114123 return n
115124
116125-- | s and e must both be children of the same node and s must precede e
117126{-# INLINABLE deleteBetweenInclusive #-}
118−deleteBetweenInclusive :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()
127+deleteBetweenInclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
119128deleteBetweenInclusive s e = do
120129 mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
121130 case mCurrentParent of
@@ -124,12 +133,14 @@ deleteBetweenInclusive s e = do
124133 let go = do
125134 Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
126135 _ <- removeChild currentParent $ Just x
127− when (toNode s /= toNode x) go
136+ liftJSM (strictEqual s x) >>= \case
137+ True -> return ()
138+ False -> go
128139 go
129140 _ <- removeChild currentParent $ Just e
130141 return ()
131142
132−type SupportsImmediateDomBuilder t m = (Reflex t, MonadIO m, MonadHold t m, MonadFix m, PerformEvent t m, Performable m ~ m, MonadReflexCreateTrigger t m, Deletable t m, MonadRef m, Ref m ~ Ref IO)
143+type SupportsImmediateDomBuilder t m = (Reflex t, MonadJSM m, MonadHold t m, MonadFix m, PerformEvent t m, Performable m ~ m, MonadReflexCreateTrigger t m, Deletable t m, MonadRef m, Ref m ~ Ref JSM)
133144
134145newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))
135146
@@ -139,35 +150,37 @@ wrap e cfg = do
139150 lift $ performEvent_ $ ffor (cfg ^. modifyAttributes) $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
140151 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
141152 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv
142− eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftIO $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do
143− triggerRef <- newIORef Nothing
153+ eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftJSM $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do
154+ triggerRef <- liftIO $ newIORef Nothing
144155 _ <- elementOnEventName en e $ do
145156 evt <- DOM.event
146− (flags, k) <- liftIO $ f $ GhcjsDomEvent evt
157+ (flags, k) <- liftJSM $ f $ GhcjsDomEvent evt
147158 when (_eventFlags_preventDefault flags) $ withIsEvent en DOM.preventDefault
148159 case _eventFlags_propagation flags of
149160 Propagation_Continue -> return ()
150161 Propagation_Stop -> withIsEvent en DOM.stopPropagation
151162 Propagation_StopImmediate -> withIsEvent en DOM.stopImmediatePropagation
152− mv <- liftIO k --TODO: Only do this when the event is subscribed
163+ mv <- liftJSM k --TODO: Only do this when the event is subscribed
153164 liftIO $ forM_ mv $ \v -> writeChan events [TriggerRef triggerRef :=> TriggerInvocation v (return ())]
154165 return $ en :=> EventFilterTriggerRef triggerRef
155− es <- newFanEventWithTrigger $ \(WrapArg en) t -> do
156− case DMap.lookup en eventTriggerRefs of
157− Just (EventFilterTriggerRef r) -> do
158− writeIORef r $ Just t
159− return $ do
160− writeIORef r Nothing
161− Nothing -> elementOnEventName en e $ do
162− evt <- DOM.event
163− let h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg
164− mv <- liftIO $ h (en, GhcjsDomEvent evt)
165− case mv of
166− Nothing -> return ()
167− Just v -> liftIO $ do
168− --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right
169− ref <- newIORef $ Just t
170− writeChan events [TriggerRef ref :=> TriggerInvocation v (return ())]
166+ es <- do
167+ ctx <- askJSM
168+ newFanEventWithTrigger $ \(WrapArg en) t ->
169+ case DMap.lookup en eventTriggerRefs of
170+ Just (EventFilterTriggerRef r) -> do
171+ writeIORef r $ Just t
172+ return $ do
173+ writeIORef r Nothing
174+ Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
175+ evt <- DOM.event
176+ let h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg
177+ mv <- lift $ h (en, GhcjsDomEvent evt)
178+ case mv of
179+ Nothing -> return ()
180+ Just v -> liftIO $ do
181+ --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right
182+ ref <- newIORef $ Just t
183+ writeChan events [TriggerRef ref :=> TriggerInvocation v (return ())])
171184 return $ Element es e
172185
173186{-# INLINABLE makeElement #-}
@@ -175,12 +188,12 @@ makeElement :: forall er t m a. SupportsImmediateDomBuilder t m => Text -> Eleme
175188makeElement elementTag cfg child = do
176189 doc <- askDocument
177190 events <- askEvents
178− Just e <- ImmediateDomBuilderT $ fmap DOM.castToElement <$> case cfg ^. namespace of
191+ Just e <- liftJSM $ case cfg ^. namespace of
179192 Nothing -> createElement doc (Just elementTag)
180193 Just ens -> createElementNS doc (Just ens) (Just elementTag)
181194 ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
182− Nothing -> setAttribute e n v
183− Just ans -> setAttributeNS e (Just ans) n v
195+ Nothing -> lift $ setAttribute e n v
196+ Just ans -> lift $ setAttributeNS e (Just ans) n v
184197 result <- lift $ runImmediateDomBuilderT child $ ImmediateDomBuilderEnv
185198 { _immediateDomBuilderEnv_parent = toNode e
186199 , _immediateDomBuilderEnv_document = doc
@@ -190,9 +203,9 @@ makeElement elementTag cfg child = do
190203 wrapped <- wrap e $ extractRawElementConfig cfg
191204 return ((wrapped, result), e)
192205
193−newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> IO b }
206+newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> JSM b }
194207
195−newtype GhcjsDomHandler1 a b = GhcjsDomHandler1 { unGhcjsDomHandler1 :: forall (x :: EventTag). a x -> IO (b x) }
208+newtype GhcjsDomHandler1 a b = GhcjsDomHandler1 { unGhcjsDomHandler1 :: forall (x :: EventTag). a x -> JSM (b x) }
196209
197210newtype GhcjsDomEvent en = GhcjsDomEvent { unGhcjsDomEvent :: EventType en }
198211
@@ -220,7 +233,7 @@ instance DomSpace GhcjsDomSpace where
220233 in DMap.alter f' en $ _ghcjsEventSpec_filters es
221234 }
222235
223−newtype GhcjsEventFilter er en = GhcjsEventFilter (GhcjsDomEvent en -> IO (EventFlags, IO (Maybe (er en))))
236+newtype GhcjsEventFilter er en = GhcjsEventFilter (GhcjsDomEvent en -> JSM (EventFlags, JSM (Maybe (er en))))
224237
225238data Pair1 (f :: k -> *) (g :: k -> *) (a :: k) = Pair1 (f a) (g a)
226239
@@ -228,7 +241,7 @@ data Maybe1 f a = Nothing1 | Just1 (f a)
228241
229242data GhcjsEventSpec er = GhcjsEventSpec
230243 { _ghcjsEventSpec_filters :: DMap EventName (GhcjsEventFilter er)
231− , _ghcjsEventSpec_handler :: forall en. (EventName en, GhcjsDomEvent en) -> IO (Maybe (er en))
244+ , _ghcjsEventSpec_handler :: forall en. (EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en))
232245 }
233246
234247instance er ~ EventResult => Default (GhcjsEventSpec er) where
@@ -236,7 +249,8 @@ instance er ~ EventResult => Default (GhcjsEventSpec er) where
236249 { _ghcjsEventSpec_filters = mempty
237250 , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> do
238251 Just t <- withIsEvent en $ Event.getTarget evt --TODO: Rework this; defaultDomEventHandler shouldn't need to take this as an argument
239− runReaderT (defaultDomEventHandler (Element.castToElement t) en) evt
252+ e <- Element.castToElement t
253+ runReaderT (defaultDomEventHandler e en) evt
240254 }
241255
242256instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where
@@ -260,7 +274,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
260274 {-# INLINABLE inputElement #-}
261275 inputElement cfg = do
262276 ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
263− let domInputElement = castToHTMLInputElement domElement
277+ domInputElement <- liftJSM $ castToHTMLInputElement domElement
264278 Input.setValue domInputElement $ Just (cfg ^. inputElementConfig_initialValue)
265279 Just v0 <- Input.getValue domInputElement
266280 let getMyValue = fromMaybe "" <$> Input.getValue domInputElement
@@ -307,7 +321,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
307321 {-# INLINABLE textAreaElement #-}
308322 textAreaElement cfg = do --TODO
309323 ((e, _), domElement) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
310− let domTextAreaElement = castToHTMLTextAreaElement domElement
324+ domTextAreaElement <- liftJSM $ castToHTMLTextAreaElement domElement
311325 TextArea.setValue domTextAreaElement $ Just (cfg ^. textAreaElementConfig_initialValue)
312326 Just v0 <- TextArea.getValue domTextAreaElement
313327 let getMyValue = fromMaybe "" <$> TextArea.getValue domTextAreaElement
@@ -330,7 +344,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
330344 {-# INLINABLE selectElement #-}
331345 selectElement cfg child = do
332346 ((e, result), domElement) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child
333− let domSelectElement = castToHTMLSelectElement domElement
347+ domSelectElement <- liftJSM $ castToHTMLSelectElement domElement
334348 Select.setValue domSelectElement $ Just (cfg ^. selectElementConfig_initialValue)
335349 Just v0 <- Select.getValue domSelectElement
336350 let getMyValue = fromMaybe "" <$> Select.getValue domSelectElement
@@ -363,7 +377,7 @@ mkHasFocus e = do
363377 ]
364378
365379{-# INLINABLE insertImmediateAbove #-}
366−insertImmediateAbove :: (Reflex t, IsNode placeholder, PerformEvent t m, MonadIO (Performable m)) => placeholder -> Event t (ImmediateDomBuilderT t (Performable m) a) -> ImmediateDomBuilderT t m (Event t a)
380+insertImmediateAbove :: (Reflex t, IsNode placeholder, PerformEvent t m, MonadJSM (Performable m)) => placeholder -> Event t (ImmediateDomBuilderT t (Performable m) a) -> ImmediateDomBuilderT t m (Event t a)
367381insertImmediateAbove n toInsertAbove = do
368382 events <- askEvents
369383 lift $ performEvent $ ffor toInsertAbove $ \new -> do
@@ -416,13 +430,13 @@ instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) =>
416430 newTriggerEventWithOnComplete = do
417431 events <- askEvents
418432 (eResult, reResultTrigger) <- lift newEventWithTriggerRef
419− return $ (,) eResult $ \a cb -> writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a cb]
433+ return $ (,) eResult $ \a cb -> writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a (liftIO cb)]
420434 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
421435 newEventWithLazyTriggerWithOnComplete f = do
422436 events <- askEvents
423437 lift $ newEventWithTrigger $ \t -> f $ \a cb -> do
424438 reResultTrigger <- newIORef $ Just t
425− writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a cb]
439+ writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a (liftIO cb)]
426440
427441instance HasWebView m => HasWebView (ImmediateDomBuilderT t m) where
428442 type WebViewPhantom (ImmediateDomBuilderT t m) = WebViewPhantom m
@@ -442,7 +456,7 @@ instance MonadAtomicRef m => MonadAtomicRef (ImmediateDomBuilderT t m) where
442456 atomicModifyRef r = lift . atomicModifyRef r
443457
444458instance (HasJS x m, ReflexHost t) => HasJS x (ImmediateDomBuilderT t m) where
445− type JSM (ImmediateDomBuilderT t m) = JSM m
459+ type JSX (ImmediateDomBuilderT t m) = JSX m
446460 liftJS = lift . liftJS
447461
448462type family EventType en where
@@ -643,9 +657,58 @@ withIsEvent en r = case en of
643657 Mousewheel -> r
644658 Wheel -> r
645659
660+showEventName :: EventName en -> String
661+showEventName en = case en of
662+ Abort -> "Abort"
663+ Blur -> "Blur"
664+ Change -> "Change"
665+ Click -> "Click"
666+ Contextmenu -> "Contextmenu"
667+ Dblclick -> "Dblclick"
668+ Drag -> "Drag"
669+ Dragend -> "Dragend"
670+ Dragenter -> "Dragenter"
671+ Dragleave -> "Dragleave"
672+ Dragover -> "Dragover"
673+ Dragstart -> "Dragstart"
674+ Drop -> "Drop"
675+ Error -> "Error"
676+ Focus -> "Focus"
677+ Input -> "Input"
678+ Invalid -> "Invalid"
679+ Keydown -> "Keydown"
680+ Keypress -> "Keypress"
681+ Keyup -> "Keyup"
682+ Load -> "Load"
683+ Mousedown -> "Mousedown"
684+ Mouseenter -> "Mouseenter"
685+ Mouseleave -> "Mouseleave"
686+ Mousemove -> "Mousemove"
687+ Mouseout -> "Mouseout"
688+ Mouseover -> "Mouseover"
689+ Mouseup -> "Mouseup"
690+ Mousewheel -> "Mousewheel"
691+ Scroll -> "Scroll"
692+ Select -> "Select"
693+ Submit -> "Submit"
694+ Wheel -> "Wheel"
695+ Beforecut -> "Beforecut"
696+ Cut -> "Cut"
697+ Beforecopy -> "Beforecopy"
698+ Copy -> "Copy"
699+ Beforepaste -> "Beforepaste"
700+ Paste -> "Paste"
701+ Reset -> "Reset"
702+ Search -> "Search"
703+ Selectstart -> "Selectstart"
704+ Touchstart -> "Touchstart"
705+ Touchmove -> "Touchmove"
706+ Touchend -> "Touchend"
707+ Touchcancel -> "Touchcancel"
708+
646709{-# INLINABLE elementOnEventName #-}
647−elementOnEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())
648−elementOnEventName en e = case en of
710+elementOnEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> JSM (JSM ())
711+elementOnEventName en e = \x -> liftIO (putStrLn $ "element event handler added " <> showEventName en) >> (case en of
649712 Abort -> on e Element.abort
650713 Blur -> on e Element.blurEvent
651714 Change -> on e Element.change
@@ -691,11 +754,12 @@ elementOnEventName en e = case en of
691754 Touchstart -> on e Element.touchStart
692755 Touchmove -> on e Element.touchMove
693756 Touchend -> on e Element.touchEnd
694− Touchcancel -> on e Element.touchCancel
757+ Touchcancel -> on e Element.touchCancel) (liftIO (putStrLn $ "element event fired " <> showEventName en) >> x)
758+ >>= \y -> return (liftIO (putStrLn $ "element event removed " <> showEventName en) >> y)
695759
696760{-# INLINABLE windowOnEventName #-}
697−windowOnEventName :: EventName en -> DOM.Window -> EventM DOM.Window (EventType en) () -> IO (IO ())
698−windowOnEventName en e = case en of
761+windowOnEventName :: EventName en -> DOM.Window -> EventM DOM.Window (EventType en) () -> JSM (JSM ())
762+windowOnEventName en e = \x -> liftIO (putStrLn $ "window event handler added " <> showEventName en) >> (case en of
699763 Abort -> on e Window.abort
700764 Blur -> on e Window.blurEvent
701765 Change -> on e Window.change
@@ -741,18 +805,19 @@ windowOnEventName en e = case en of
741805 Touchstart -> on e Window.touchStart
742806 Touchmove -> on e Window.touchMove
743807 Touchend -> on e Window.touchEnd
744− Touchcancel -> on e Window.touchCancel
808+ Touchcancel -> on e Window.touchCancel) (liftIO (putStrLn $ "window event fired " <> showEventName en) >> x)
809+ >>= \y -> return (liftIO (putStrLn $ "windo event removed " <> showEventName en) >> y)
745810
746811{-# INLINABLE wrapDomEvent #-}
747−wrapDomEvent :: TriggerEvent t m => e -> (e -> EventM e event () -> IO (IO ())) -> EventM e event a -> m (Event t a)
812+wrapDomEvent :: (TriggerEvent t m, MonadJSM m) => e -> (e -> EventM e event () -> JSM (JSM ())) -> EventM e event a -> m (Event t a)
748813wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $ fmap Just getValue
749814
750815{-# INLINABLE subscribeDomEvent #-}
751−subscribeDomEvent :: (EventM e event () -> IO (IO ()))
816+subscribeDomEvent :: (EventM e event () -> JSM (JSM ()))
752817 -> EventM e event (Maybe a)
753818 -> Chan [DSum (TriggerRef t) TriggerInvocation]
754819 -> EventTrigger t a
755− -> IO (IO ())
820+ -> JSM (JSM ())
756821subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do
757822 mv <- getValue
758823 forM_ mv $ \v -> liftIO $ do
@@ -761,25 +826,28 @@ subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do
761826 writeChan eventChan [TriggerRef etr :=> TriggerInvocation v (return ())]
762827
763828{-# INLINABLE wrapDomEventMaybe #-}
764−wrapDomEventMaybe :: TriggerEvent t m
829+wrapDomEventMaybe :: (TriggerEvent t m, MonadJSM m)
765830 => e
766− -> (e -> EventM e event () -> IO (IO ()))
831+ -> (e -> EventM e event () -> JSM (JSM ()))
767832 -> EventM e event (Maybe a)
768833 -> m (Event t a)
769834wrapDomEventMaybe el elementOnevent getValue = do
770− newEventWithLazyTriggerWithOnComplete $ \trigger -> elementOnevent el $ do
835+ ctx <- askJSM
836+ newEventWithLazyTriggerWithOnComplete $ \trigger -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnevent el $ do
771837 mv <- getValue
772− forM_ mv $ \v -> liftIO $ trigger v $ return ()
838+ forM_ mv $ \v -> liftIO $ trigger v $ return ())
773839
774840{-# INLINABLE wrapDomEventsMaybe #-}
775−wrapDomEventsMaybe :: (MonadIO m, MonadReflexCreateTrigger t m)
841+wrapDomEventsMaybe :: (MonadJSM m, MonadReflexCreateTrigger t m)
776842 => e
777843 -> (forall en. IsEvent (EventType en) => EventName en -> EventM e (EventType en) (Maybe (f en)))
778− -> (forall en. EventName en -> e -> EventM e (EventType en) () -> IO (IO ()))
844+ -> (forall en. EventName en -> e -> EventM e (EventType en) () -> JSM (JSM ()))
779845 -> ImmediateDomBuilderT t m (EventSelector t (WrapArg f EventName))
780846wrapDomEventsMaybe target handlers onEventName = do
847+ ctx <- askJSM
781848 eventChan <- askEvents
782− e <- lift $ newFanEventWithTrigger $ \(WrapArg en) -> withIsEvent en $ subscribeDomEvent (onEventName en target) (handlers en) eventChan
849+ e <- lift $ newFanEventWithTrigger $ \(WrapArg en) -> withIsEvent en
850+ (((`runJSM` ctx) <$>) . (`runJSM` ctx) . subscribeDomEvent (onEventName en target) (handlers en) eventChan)
783851 return $! e
784852
785853{-# INLINABLE getKeyEvent #-}
@@ -820,7 +888,7 @@ data Window t = Window
820888 , _window_raw :: DOM.Window
821889 }
822890
823−wrapWindow :: (MonadIO m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> ImmediateDomBuilderT t m (Window t)
891+wrapWindow :: (MonadJSM m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> ImmediateDomBuilderT t m (Window t)
824892wrapWindow wv _ = do
825893 events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName
826894 return $ Window
src/Reflex/Dom/Builder/InputDisabled.hs+1−1
@@ -86,5 +86,5 @@ instance HasWebView m => HasWebView (InputDisabledT m) where
8686 askWebView = lift askWebView
8787
8888instance HasJS js m => HasJS js (InputDisabledT m) where
89− type JSM (InputDisabledT m) = JSM m
89+ type JSX (InputDisabledT m) = JSX m
9090 liftJS = lift . liftJS
src/Reflex/Dom/Internal.hs+27−20
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE ConstraintKinds #-}
23{-# LANGUAGE FlexibleContexts #-}
34{-# LANGUAGE FlexibleInstances #-}
@@ -11,6 +12,7 @@
1112{-# LANGUAGE TypeFamilies #-}
1213{-# LANGUAGE TypeOperators #-}
1314{-# LANGUAGE UndecidableInstances #-}
15+{-# LANGUAGE PatternSynonyms #-}
1416module Reflex.Dom.Internal where
1517
1618import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)
@@ -36,51 +38,56 @@ import Data.Monoid ((<>))
3638import Data.Text (Text)
3739import qualified Data.Text as T
3840import Data.Text.Encoding
39−import GHCJS.DOM hiding (runWebGUI)
41+import GHCJS.DOM
4042import GHCJS.DOM.Document
4143import GHCJS.DOM.Element
4244import GHCJS.DOM.Node
4345import qualified GHCJS.DOM.Types as DOM
46+import GHCJS.DOM.Types (MonadJSM(..), runJSM, askJSM, JSM)
4447
4548{-# INLINABLE mainWidget #-}
4649mainWidget :: (forall x. Widget x ()) -> IO ()
47−mainWidget w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
48− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
50+mainWidget w = runWebGUI $ \(webView, ctx) -> withWebViewSingleton (webView, ctx) $ \webViewSing -> (`runJSM` ctx) $ do
51+ Just doc <- currentDocument
4952 Just body <- getBody doc
5053 attachWidget body webViewSing w
5154
5255--TODO: The x's should be unified here
5356{-# INLINABLE mainWidgetWithHead #-}
5457mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> IO ()
55−mainWidgetWithHead h b = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
56− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
57− Just headElement <- fmap DOM.castToHTMLElement <$> getHead doc
58+mainWidgetWithHead h b = runWebGUI $ \(webView, ctx) -> withWebViewSingleton (webView, ctx) $ \webViewSing -> (`runJSM` ctx) $ do
59+ Just doc <- currentDocument
60+ Just headElement <- getHead doc
5861 attachWidget headElement webViewSing h
5962 Just body <- getBody doc
6063 attachWidget body webViewSing b
6164
6265{-# INLINABLE mainWidgetWithCss #-}
6366mainWidgetWithCss :: ByteString -> (forall x. Widget x ()) -> IO ()
64−mainWidgetWithCss css w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
65− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
66− Just headElement <- fmap DOM.castToHTMLElement <$> getHead doc
67+mainWidgetWithCss css w = runWebGUI $ \(webView, ctx) -> withWebViewSingleton (webView, ctx) $ \webViewSing -> (`runJSM` ctx) $ do
68+ Just doc <- currentDocument
69+ Just headElement <- getHead doc
6770 setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
6871 Just body <- getBody doc
6972 attachWidget body webViewSing w
7073
7174type Widget x = PostBuildT Spider (ImmediateDomBuilderT Spider (WithWebView x (PerformEventT Spider (SpiderHost Global)))) --TODO: Make this more abstract --TODO: Put the WithWebView underneath PerformEventT - I think this would perform better
7275
76+instance MonadJSM m => MonadJSM (PostBuildT t m) where
77+ liftJSM' = PostBuildT . liftJSM'
78+
7379{-# INLINABLE attachWidget #-}
74−attachWidget :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO a
80+attachWidget :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> JSM a
7581attachWidget rootElement wv w = fst <$> attachWidget' rootElement wv w
7682
7783{-# INLINABLE attachWidget' #-}
78−attachWidget' :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))
84+attachWidget' :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> JSM (a, FireCommand Spider (SpiderHost Global))
7985attachWidget' rootElement wv w = do
86+ ctx <- askJSM
8087 Just doc <- getOwnerDocument rootElement
8188 Just df <- createDocumentFragment doc
82− events <- newChan
83− (result, fc@(FireCommand fire)) <- runSpiderHost $ do
89+ events <- liftIO $ newChan
90+ (result, fc@(FireCommand fire)) <- liftIO $ runSpiderHost $ do
8491 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
8592 let builderEnv = ImmediateDomBuilderEnv
8693 { _immediateDomBuilderEnv_document = doc
@@ -91,14 +98,14 @@ attachWidget' rootElement wv w = do
9198 mPostBuildTrigger <- readRef postBuildTriggerRef
9299 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
93100 return results
94− void $ forkIO $ forever $ do
101+ liftIO $ void $ forkIO $ forever $ do
95102 ers <- readChan events
96− _ <- postGUISync $ runSpiderHost $ do
103+ _ <- runSpiderHost $ do
97104 mes <- liftIO $ forM ers $ \(TriggerRef er :=> TriggerInvocation a _) -> do
98105 me <- readIORef er
99106 return $ fmap (\e -> e :=> Identity a) me
100107 _ <- fire (catMaybes mes) $ return ()
101− liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
108+ liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> (`runJSM` ctx) cb
102109 return ()
103110 setInnerHTML rootElement $ Just (""::String)
104111 _ <- appendChild rootElement $ Just df
@@ -106,8 +113,8 @@ attachWidget' rootElement wv w = do
106113
107114-- | Run a reflex-dom application inside of an existing DOM element with the given ID
108115mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> IO ()
109−mainWidgetInElementById eid w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
110− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
116+mainWidgetInElementById eid w = runWebGUI $ \(webView, ctx) -> withWebViewSingleton (webView, ctx) $ \webViewSing -> (`runJSM` ctx) $ do
117+ Just doc <- currentDocument
111118 Just root <- getElementById doc eid
112119 attachWidget root webViewSing w
113120
@@ -120,8 +127,8 @@ data AppOutput t = AppOutput --TODO: Add quit event
120127 }
121128
122129runApp' :: (t ~ Spider) => (forall x. AppInput t -> Widget x (AppOutput t)) -> IO ()
123−runApp' app = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
124− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
130+runApp' app = runWebGUI $ \(webView, ctx) -> withWebViewSingleton (webView, ctx) $ \webViewSing -> (`runJSM` ctx) $ do
131+ Just doc <- currentDocument
125132 Just body <- getBody doc
126133 Just win <- getDefaultView doc
127134 rec o <- attachWidget body webViewSing $ do
src/Reflex/Dom/Old.hs+24−13
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
12{-# LANGUAGE ConstraintKinds #-}
23{-# LANGUAGE ExplicitForAll #-}
34{-# LANGUAGE FlexibleContexts #-}
@@ -8,6 +9,7 @@
89{-# LANGUAGE TemplateHaskell #-}
910{-# LANGUAGE TypeFamilies #-}
1011{-# LANGUAGE UndecidableInstances #-}
12+{-# LANGUAGE LambdaCase #-}
1113module Reflex.Dom.Old
1214 ( MonadWidget
1315 , El
@@ -61,8 +63,10 @@ import Foreign.JavaScript.TH
6163import qualified GHCJS.DOM.Element as Element
6264import GHCJS.DOM.EventM (EventM)
6365import GHCJS.DOM.NamedNodeMap as NNM
64−import GHCJS.DOM.Node (getFirstChild, getNodeName, getParentNode, getPreviousSibling, removeChild, toNode)
65−import GHCJS.DOM.Types (IsElement, IsNode)
66+import GHCJS.DOM.Node (getFirstChild, getNodeName, getParentNode, getPreviousSibling, removeChild)
67+import GHCJS.DOM.Types
68+ (MonadJSM, askJSM, runJSM, strictEqual, liftJSM, JSM, IsElement,
69+ IsNode)
6670import qualified GHCJS.DOM.Types as DOM
6771import Reflex.Class
6872import Reflex.Dom.Builder.Class
@@ -92,6 +96,10 @@ type MonadWidgetConstraints t m =
9296 , PerformEvent t m
9397 , MonadIO m
9498 , MonadIO (Performable m)
99+#ifndef ghcjs_HOST_OS
100+ , MonadJSM m
101+ , MonadJSM (Performable m)
102+#endif
95103 , TriggerEvent t m
96104 , HasWebView m
97105 , HasWebView (Performable m)
@@ -154,7 +162,7 @@ buildElementCommon :: MonadWidget t m => Text -> m a -> ElementConfig er t m ->
154162buildElementCommon elementTag child cfg = element elementTag cfg child
155163
156164-- | s and e must both be children of the same node and s must precede e
157−deleteBetweenExclusive :: (IsNode start, IsNode end) => start -> end -> IO ()
165+deleteBetweenExclusive :: (IsNode start, IsNode end) => start -> end -> JSM ()
158166deleteBetweenExclusive s e = do
159167 mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
160168 case mCurrentParent of
@@ -162,12 +170,14 @@ deleteBetweenExclusive s e = do
162170 Just currentParent -> do
163171 let go = do
164172 Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
165− when (toNode s /= toNode x) $ do
166− _ <- removeChild currentParent $ Just x
167− go
173+ liftJSM (strictEqual s x) >>= \case
174+ True -> return ()
175+ False -> do
176+ _ <- removeChild currentParent $ Just x
177+ go
168178 go
169179
170−onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())
180+onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> JSM (JSM ())
171181onEventName = elementOnEventName
172182
173183schedulePostBuild :: (PostBuild t m, PerformEvent t m) => WidgetHost m () -> m ()
@@ -219,7 +229,7 @@ _el_scrolled = domEvent Scroll
219229
220230wrapElement :: forall t m. MonadWidget t m => (forall en. DOM.Element -> EventName en -> EventM DOM.Element (EventType en) (Maybe (EventResult en))) -> DOM.Element -> m (El t)
221231wrapElement eh e = do
222− let h :: (EventName en, GhcjsDomEvent en) -> IO (Maybe (EventResult en))
232+ let h :: (EventName en, GhcjsDomEvent en) -> JSM (Maybe (EventResult en))
223233 h (en, GhcjsDomEvent evt) = runReaderT (eh e en) evt
224234 wrapRawElement e $ (def :: RawElementConfig EventResult t m)
225235 { _rawElementConfig_eventSpec = def
@@ -232,7 +242,7 @@ unsafePlaceElement e = do
232242 placeRawElement e
233243 wrapRawElement e def
234244
235−namedNodeMapGetNames :: DOM.NamedNodeMap -> IO (Set Text)
245+namedNodeMapGetNames :: DOM.NamedNodeMap -> JSM (Set Text)
236246namedNodeMapGetNames self = do
237247 l <- NNM.getLength self
238248 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
@@ -240,7 +250,7 @@ namedNodeMapGetNames self = do
240250 Just n <- NNM.item self i
241251 getNodeName n
242252
243−nodeClear :: IsNode self => self -> IO ()
253+nodeClear :: IsNode self => self -> JSM ()
244254nodeClear n = do
245255 mfc <- getFirstChild n
246256 case mfc of
@@ -251,7 +261,7 @@ nodeClear n = do
251261
252262getQuitWidget :: MonadWidget t m => m (WidgetHost m ())
253263getQuitWidget = return $ do
254− WebViewSingleton wv <- askWebView
264+ WebViewSingleton (wv, _) <- askWebView
255265 liftIO $ quitWebView wv
256266
257267elStopPropagationNS :: forall t m en a. (MonadWidget t m) => Maybe Text -> Text -> EventName en -> m a -> m a
@@ -263,12 +273,13 @@ elStopPropagationNS ns elementTag en child = do
263273 & elementConfig_eventSpec . ghcjsEventSpec_filters %~ DMap.insert en f
264274 snd <$> element elementTag cfg child
265275
266−elDynHtmlAttr' :: MonadWidget t m => Text -> Map Text Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)
276+elDynHtmlAttr' :: (DOM.MonadJSM m, MonadWidget t m) => Text -> Map Text Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)
267277elDynHtmlAttr' elementTag attrs html = do
268278 let cfg = def & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs
269279 (e, _) <- element elementTag cfg $ return ()
270280 postBuild <- getPostBuild
271− performEvent_ $ Element.setInnerHTML (_element_raw e) . Just <$> leftmost [updated html, tag (current html) postBuild]
281+ ctx <- askJSM
282+ performEvent_ $ (`runJSM` ctx) . Element.setInnerHTML (_element_raw e) . Just <$> leftmost [updated html, tag (current html) postBuild]
272283 return e
273284
274285elDynHtml' :: MonadWidget t m => Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)
src/Reflex/Dom/Widget/Basic.hs−1
@@ -82,7 +82,6 @@ module Reflex.Dom.Widget.Basic
8282import Reflex.Class as Reflex
8383import Reflex.Dom.Builder.Class
8484import Reflex.Dom.Class
85−import Reflex.Dom.Internal.Foreign ()
8685import Reflex.Dynamic
8786import Reflex.PostBuild.Class
8887
src/Reflex/Dom/Widget/Input.hs+5−4
@@ -36,7 +36,7 @@ import GHCJS.DOM.EventM (on)
3636import qualified GHCJS.DOM.FileList as FileList
3737import GHCJS.DOM.HTMLInputElement (HTMLInputElement)
3838import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement)
39−import GHCJS.DOM.Types (File)
39+import GHCJS.DOM.Types (MonadJSM, File)
4040import Reflex.Class
4141import Reflex.Dynamic
4242import Reflex.Dom.Builder.Class
@@ -285,7 +285,7 @@ checkboxView dAttrs dValue = do
285285 let filters :: DMap EventName (GhcjsEventFilter CheckboxViewEventResult)
286286 filters = DMap.singleton Click $ GhcjsEventFilter $ \(GhcjsDomEvent evt) -> do
287287 Just t <- Event.getTarget evt
288− b <- Input.getChecked $ Input.castToHTMLInputElement t
288+ b <- Input.getChecked =<< Input.castToHTMLInputElement t
289289 return $ (,) preventDefault $ return $ Just $ CheckboxViewEventResult b
290290 elementConfig :: ElementConfig CheckboxViewEventResult t m
291291 elementConfig = (def :: ElementConfig EventResult t m)
@@ -297,7 +297,8 @@ checkboxView dAttrs dValue = do
297297 Click -> error "impossible"
298298 _ -> do
299299 Just e <- withIsEvent en $ Event.getTarget evt
300− mr <- runReaderT (defaultDomEventHandler (castToElement e) en) evt
300+ element <- castToElement e
301+ mr <- runReaderT (defaultDomEventHandler element en) evt
301302 return $ ffor mr $ \(EventResult r) -> CheckboxViewEventResult $ regularToCheckboxViewEventType en r
302303 }
303304 }
@@ -321,7 +322,7 @@ instance Reflex t => Default (FileInputConfig t) where
321322 def = FileInputConfig { _fileInputConfig_attributes = constDyn mempty
322323 }
323324
324−fileInput :: forall t m. (MonadIO m, MonadFix m, MonadHold t m, TriggerEvent t m, DomBuilder t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace)
325+fileInput :: forall t m. (MonadIO m, MonadJSM m, MonadFix m, MonadHold t m, TriggerEvent t m, DomBuilder t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace)
325326 => FileInputConfig t -> m (FileInput (DomBuilderSpace m) t)
326327fileInput config = do
327328 let insertType = Map.insert "type" "file"
src/Reflex/Dom/Widget/Lazy.hs+8−8
@@ -16,7 +16,6 @@ import Reflex.PerformEvent.Class
1616import Reflex.PostBuild.Class
1717
1818import Control.Monad.Fix
19−import Control.Monad.IO.Class
2019import Data.Fixed
2120import Data.Map (Map)
2221import qualified Data.Map as Map
@@ -24,9 +23,10 @@ import Data.Monoid
2423import Data.Text (Text)
2524import qualified Data.Text as T
2625import GHCJS.DOM.Element
26+import GHCJS.DOM.Types (MonadJSM)
2727
2828-- |A list view for long lists. Creates a scrollable element and only renders child row elements near the current scroll position.
29−virtualListWithSelection :: forall t m k v. (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadIO (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)
29+virtualListWithSelection :: forall t m k v. (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)
3030 => Dynamic t Int -- ^ The height of the visible region in pixels
3131 -> Int -- ^ The height of each row in pixels
3232 -> Dynamic t Int -- ^ The total number of items
@@ -58,8 +58,8 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa
5858 let window = zipDynWith (findWindow rowPx) heightPx scrollPosition
5959 itemsInWindow = zipDynWith (\(_,(idx,num)) is -> Map.fromList $ map (\i -> let ix = indexToKey i in (ix, Map.lookup ix is)) [idx .. idx + num]) window items
6060 postBuild <- getPostBuild
61− performEvent_ $ ffor (leftmost [setI, i0 <$ postBuild]) $ \i -> do
62− liftIO $ setScrollTop (_element_raw container) (i * rowPx)
61+ performEvent_ $ ffor (leftmost [setI, i0 <$ postBuild]) $ \i ->
62+ setScrollTop (_element_raw container) (i * rowPx)
6363 let indexAndLength = fmap snd window
6464 return (indexAndLength, sel)
6565 where
@@ -80,7 +80,7 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa
8080 preItems = min startingIndex numItems
8181 in (topPx - preItems * sizeIncrement, (startingIndex - preItems, preItems + numItems * 2))
8282
83−virtualList :: forall t m k v a. (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadIO (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)
83+virtualList :: forall t m k v a. (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)
8484 => Dynamic t Int -- ^ A 'Dynamic' of the visible region's height in pixels
8585 -> Int -- ^ The fixed height of each row in pixels
8686 -> Dynamic t Int -- ^ A 'Dynamic' of the total number of items
@@ -102,8 +102,8 @@ virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBu
102102 , fmap (const (i0 * rowPx)) pb
103103 ]
104104 let window = zipDynWith (findWindow rowPx) heightPx scrollPosition
105− performEvent_ $ ffor (leftmost [setI, i0 <$ pb]) $ \i -> do
106− liftIO $ setScrollTop (_element_raw viewport) (i * rowPx)
105+ performEvent_ $ ffor (leftmost [setI, i0 <$ pb]) $ \i ->
106+ setScrollTop (_element_raw viewport) (i * rowPx)
107107 return (uniqDyn window, result)
108108 where
109109 toStyleAttr m = "style" =: Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m
@@ -124,7 +124,7 @@ virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBu
124124 in (startingIndex, numItems)
125125
126126virtualListBuffered
127− :: (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadIO (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)
127+ :: (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)
128128 => Int
129129 -> Dynamic t Int
130130 -> Int
src/Reflex/Dom/Widget/Resize.hs+8−5
@@ -1,3 +1,4 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE FlexibleContexts #-}
23{-# LANGUAGE MultiParamTypeClasses #-}
34{-# LANGUAGE OverloadedStrings #-}
@@ -23,19 +24,20 @@ import Data.Text (Text)
2324import qualified Data.Text as T
2425import GHCJS.DOM.Element hiding (reset)
2526import GHCJS.DOM.EventM (on)
27+import GHCJS.DOM.Types (runJSM, askJSM, MonadJSM)
2628
2729-- | A widget that wraps the given widget in a div and fires an event when resized.
2830-- Adapted from github.com/marcj/css-element-queries
29−resizeDetector :: (DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadIO (Performable m), MonadFix m) => m a -> m (Event t (), a)
31+resizeDetector :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m) => m a -> m (Event t (), a)
3032resizeDetector = resizeDetectorWithStyle ""
3133
32−resizeDetectorWithStyle :: (DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadIO (Performable m), MonadFix m)
34+resizeDetectorWithStyle :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m)
3335 => Text -- ^ A css style string. Warning: It should not contain the "position" style attribute.
3436 -> m a -- ^ The embedded widget
3537 -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
3638resizeDetectorWithStyle styleString = resizeDetectorWithAttrs ("style" =: styleString)
3739
38−resizeDetectorWithAttrs :: (DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadIO (Performable m), MonadFix m)
40+resizeDetectorWithAttrs :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m)
3941 => Map Text Text -- ^ A map of attributes. Warning: It should not modify the "position" style attribute.
4042 -> m a -- ^ The embedded widget
4143 -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
@@ -74,9 +76,10 @@ resizeDetectorWithAttrs attrs w = do
7476 then return Nothing
7577 else fmap Just reset
7678 pb <- getPostBuild
79+ ctx <- askJSM
7780 expandScroll <- wrapDomEvent (_element_raw expand) (`on` scroll) $ return ()
7881 shrinkScroll <- wrapDomEvent (_element_raw shrink) (`on` scroll) $ return ()
79− size0 <- performEvent $ fmap (const $ liftIO reset) pb
80− rec resize <- performEventAsync $ fmap (\d cb -> liftIO $ cb =<< resetIfChanged d) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
82+ size0 <- performEvent $ fmap (const $ runJSM reset ctx) pb
83+ rec resize <- performEventAsync $ fmap (\d cb -> liftIO $ cb =<< runJSM (resetIfChanged d) ctx) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
8184 dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]
8285 return (fmapMaybe void resize, w')
src/Reflex/Dom/Xhr.hs+5−3
@@ -62,9 +62,6 @@ where
6262import Reflex.Class
6363import Reflex.Dom.Class
6464import Reflex.PerformEvent.Class
65−import Reflex.Dom.Xhr.Exception
66−import Reflex.Dom.Xhr.Foreign
67−import Reflex.Dom.Xhr.ResponseType
6865
6966import Control.Concurrent
7067import Control.Exception (handle)
@@ -91,6 +88,11 @@ import qualified Data.Text.Lazy as LT
9188import qualified Data.Text.Lazy.Builder as B
9289import Data.Traversable
9390import Data.Typeable
91+import Reflex.Dom.Xhr.ResponseType
92+ (XhrResponseBody, XhrResponseType)
93+import Foreign.JavaScript.TH (HasWebView)
94+import Reflex.Dom.Xhr.Foreign (IsXhrPayload)
95+import Reflex.Dom.Xhr.Exception (XhrException)
9496
9597data XhrRequest a
9698 = XhrRequest { _xhrRequest_method :: Text