git.iko.soy/reflex-dom
on develop help sign in
Initial port to new ghcjs-dom
b2a30b7Hamish Mackenzie
reflex-dom.cabal+20−19
compare with develop
unifiedsplit
@@ -35,7 +35,7 @@ library
35 these >= 0.4 && < 0.8,
35 these >= 0.4 && < 0.8,
36 ref-tf == 0.4.*,
36 ref-tf == 0.4.*,
37 random == 1.1.*,
37 random == 1.1.*,
38− ghcjs-dom >= 0.2.1 && < 0.3,
38+ ghcjs-dom >= 0.4.0.0 && < 0.5,
39 transformers >= 0.3 && < 0.6,
39 transformers >= 0.3 && < 0.6,
40 lens >= 4.7 && < 5,
40 lens >= 4.7 && < 5,
41 text == 1.2.*,
41 text == 1.2.*,
@@ -62,13 +62,14 @@ library
62 else
62 else
63 hs-source-dirs: src-ghc
63 hs-source-dirs: src-ghc
64 build-depends:
64 build-depends:
65+ haskell-gi-base >=0.18 && <0.19,
65− glib == 0.13.*,
66+ gi-glib >=2.0.6 && <2.1,
66− gtk3 >= 0.13.0 && < 0.15,
67+ gi-gtk >=3.0.6 && <3.1,
67− webkitgtk3 == 0.14.*,
68+ gi-webkit2 >=4.0.6 && <4.1,
68− webkitgtk3-javascriptcore == 0.13.*,
69+ jsaddle >=0.5.1.1 && <0.6,
69 raw-strings-qq
70 raw-strings-qq
70 pkgconfig-depends:
71 pkgconfig-depends:
71− webkitgtk-3.0 >= 1.8
72+ webkit2gtk-4.0 >= 2.12
72 if !os(windows)
73 if !os(windows)
73 build-depends: unix == 2.7.*
74 build-depends: unix == 2.7.*
74
75
@@ -83,30 +84,30 @@ library
83 Reflex.Dom.Class
84 Reflex.Dom.Class
84 Reflex.Dom.Internal
85 Reflex.Dom.Internal
85 Reflex.Dom.Internal.Foreign
86 Reflex.Dom.Internal.Foreign
86− Reflex.Dom.Location
87+-- Reflex.Dom.Location
87 Reflex.Dom.Old
88 Reflex.Dom.Old
88 Reflex.Dom.Time
89 Reflex.Dom.Time
89− Reflex.Dom.WebSocket
90+-- Reflex.Dom.WebSocket
90 Reflex.Dom.Widget
91 Reflex.Dom.Widget
91 Reflex.Dom.Widget.Basic
92 Reflex.Dom.Widget.Basic
92 Reflex.Dom.Widget.Input
93 Reflex.Dom.Widget.Input
93 Reflex.Dom.Widget.Lazy
94 Reflex.Dom.Widget.Lazy
94 Reflex.Dom.Widget.Resize
95 Reflex.Dom.Widget.Resize
95− Reflex.Dom.Xhr
96+-- Reflex.Dom.Xhr
96− other-modules:
97+-- other-modules:
97− Reflex.Dom.WebSocket.Foreign
98+-- Reflex.Dom.WebSocket.Foreign
98− Reflex.Dom.Xhr.Foreign
99+-- Reflex.Dom.Xhr.Foreign
99− Reflex.Dom.Xhr.ResponseType
100+-- Reflex.Dom.Xhr.ResponseType
100− Reflex.Dom.Xhr.Exception
101+-- Reflex.Dom.Xhr.Exception
101
102
102 other-extensions: TemplateHaskell
103 other-extensions: TemplateHaskell
103 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans
104 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans
104
105
105−test-suite hlint
106+--test-suite hlint
106− build-depends: base, hlint == 1.9.*
107+-- build-depends: base, hlint == 1.9.*
107− hs-source-dirs: test
108+-- hs-source-dirs: test
108− main-is: hlint.hs
109+-- main-is: hlint.hs
109− type: exitcode-stdio-1.0
110+-- type: exitcode-stdio-1.0
110
111
111source-repository head
112source-repository head
112 type: git
113 type: git
src-ghc/Reflex/Dom/Internal/Foreign.hs+126−122
@@ -1,8 +1,8 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE ForeignFunctionInterface #-}
3{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE PatternSynonyms #-}
6module Reflex.Dom.Internal.Foreign where
6module Reflex.Dom.Internal.Foreign where
7
7
8import Control.Concurrent
8import Control.Concurrent
@@ -19,29 +19,38 @@ import qualified Data.Text as T
19import Foreign.Marshal hiding (void)
19import Foreign.Marshal hiding (void)
20import Foreign.Ptr
20import Foreign.Ptr
21import GHCJS.DOM hiding (runWebGUI)
21import GHCJS.DOM hiding (runWebGUI)
22+import GHCJS.DOM.Types (runJSM, askJSM, JSContextRef(..))
22import GHCJS.DOM.Navigator
23import GHCJS.DOM.Navigator
23import GHCJS.DOM.Window
24import 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
35import System.Directory
25import 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)
37
32
38#ifndef mingw32_HOST_OS
33#ifndef mingw32_HOST_OS
39import System.Posix.Signals
34import System.Posix.Signals
40#endif
35#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)
41
48
42quitWebView :: WebView -> IO ()
49quitWebView :: WebView -> IO ()
43−quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't this be postGUISync?
50+quitWebView wv = void . idleAdd PRIORITY_DEFAULT $ do --TODO: Shouldn't this be Sync?
51+ w <- widgetGetToplevel wv
44− widgetDestroy w
52+ widgetDestroy w
53+ return False
45
54
46installQuitHandler :: WebView -> IO ()
55installQuitHandler :: WebView -> IO ()
47#ifdef mingw32_HOST_OS
56#ifdef mingw32_HOST_OS
@@ -50,119 +59,114 @@ installQuitHandler wv = return () -- TODO: Maybe figure something out here for W
50installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing
59installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing
51#endif
60#endif
52
61
53−makeDefaultWebView :: Text -> (WebView -> IO ()) -> IO ()
62+runWebGUI :: ((WebView, JSContextRef) -> IO ()) -> IO ()
54−makeDefaultWebView userAgentKey main = do
63+runWebGUI main = do
55− _ <- initGUI
64+ _ <- Gtk.init Nothing
56− window <- windowNew
65+ window <- windowNew WindowTypeToplevel
57− _ <- timeoutAddFull (yield >> return True) priorityHigh 10
66+ _ <- timeoutAdd PRIORITY_HIGH 10 (yield >> return True)
58 windowSetDefaultSize window 900 600
67 windowSetDefaultSize window 900 600
59− windowSetPosition window WinPosCenter
68+ windowSetPosition window WindowPositionCenter
60− scrollWin <- scrolledWindowNew Nothing Nothing
69+ scrollWin <- scrolledWindowNew noAdjustment noAdjustment
61 webView <- webViewNew
70 webView <- webViewNew
62− settings <- webViewGetWebSettings webView
71+ putStrLn "forking server!"
63− userAgent <- settings `get` webSettingsUserAgent
72+ _ <- forkIO $ run 3706 $ do
64− settings `set` [ webSettingsUserAgent := userAgent <> " " <> userAgentKey
73+ ctx <- askJSM
65− , webSettingsEnableUniversalAccessFromFileUris := True
74+ liftIO $ forkIO $ forever $ do
66− , webSettingsEnableDeveloperExtras := True
75+ threadDelay 1000000
67− ]
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
68− webViewSetWebSettings webView settings
87+ webViewSetSettings webView settings
69 window `containerAdd` scrollWin
88 window `containerAdd` scrollWin
70 scrollWin `containerAdd` webView
89 scrollWin `containerAdd` webView
71− _ <- on window objectDestroy . liftIO $ mainQuit
90+ _ <- onWidgetDestroy window mainQuit
72 widgetShowAll window
91 widgetShowAll window
73− _ <- webView `on` loadFinished $ \_ -> do
92+-- _ <- onWebViewLoadChanged webView $ \_ ->
74− main webView --TODO: Should probably only do this once
93+-- -- TODO run jsaddle.js when load is finished
94+-- return ()
75 inspector <- webViewGetInspector webView
95 inspector <- webViewGetInspector webView
76− _ <- inspector `on` inspectWebView $ \_ -> do
96+-- _ <- inspector `on` inspectWebView $ \_ -> do
77− inspectorWindow <- windowNew
97+-- inspectorWindow <- windowNew
78− windowSetDefaultSize inspectorWindow 900 600
98+-- windowSetDefaultSize inspectorWindow 900 600
79− inspectorScrollWin <- scrolledWindowNew Nothing Nothing
99+-- inspectorScrollWin <- scrolledWindowNew noAdjustment noAdjustment
80− inspectorWebView <- webViewNew
100+-- inspectorWebView <- webViewNew
81− inspectorWindow `containerAdd` inspectorScrollWin
101+-- inspectorWindow `containerAdd` inspectorScrollWin
82− inspectorScrollWin `containerAdd` inspectorWebView
102+-- inspectorScrollWin `containerAdd` inspectorWebView
83− widgetShowAll inspectorWindow
103+-- widgetShowAll inspectorWindow
84− return inspectorWebView
104+-- return inspectorWebView
85− wf <- webViewGetMainFrame webView
86 pwd <- getCurrentDirectory
105 pwd <- getCurrentDirectory
87− webFrameLoadString wf "" Nothing $ "file://" <> pwd <> "/"
106+-- webViewLoadHtml webView "" . Just $ "file://" <> T.pack pwd <> "/"
107+ webViewLoadUri webView "http://localhost:3706/"
88 installQuitHandler webView
108 installQuitHandler webView
89− mainGUI
109+ Gtk.main
90
110
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"
111+--foreign import ccall "wrapper"
108− wrapper :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback
112+-- wrapper :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback
109−
113+--
110−toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef
114+--toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef
111−toJSObject ctx args = do
115+--toJSObject ctx args = do
112− o <- jsobjectmake ctx nullPtr nullPtr
116+-- o <- jsobjectmake ctx nullPtr nullPtr
113− iforM_ args $ \n a -> do
117+-- iforM_ args $ \n a -> do
114− prop <- jsstringcreatewithutf8cstring $ show n
118+-- prop <- jsstringcreatewithutf8cstring $ show n
115− jsobjectsetproperty ctx o prop a 1 nullPtr
119+-- jsobjectsetproperty ctx o prop a 1 nullPtr
116− return o
120+-- return o
117−
121+--
118−fromJSStringMaybe :: JSContextRef -> JSValueRef -> IO (Maybe Text)
122+--fromJSStringMaybe :: JSContextRef -> JSValueRef -> IO (Maybe Text)
119−fromJSStringMaybe c t = do
123+--fromJSStringMaybe c t = do
120− isNull <- jsvalueisnull c t
124+-- isNull <- jsvalueisnull c t
121− if isNull then return Nothing else do
125+-- if isNull then return Nothing else do
122− j <- jsvaluetostringcopy c t nullPtr
126+-- j <- jsvaluetostringcopy c t nullPtr
123− l <- jsstringgetmaximumutf8cstringsize j
127+-- l <- jsstringgetmaximumutf8cstringsize j
124− s <- allocaBytes (fromIntegral l) $ \ps -> do
128+-- s <- allocaBytes (fromIntegral l) $ \ps -> do
125− _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
129+-- _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)
126− peekCString ps
130+-- peekCString ps
127− return $ Just $ T.pack s
131+-- return $ Just $ T.pack s
128−
132+--
129−getLocationHost :: WebView -> IO Text
133+--getLocationHost :: WebView -> IO Text
130−getLocationHost wv = withWebViewContext wv $ \c -> do
134+--getLocationHost wv = withWebViewContext wv $ \c -> do
131− script <- jsstringcreatewithutf8cstring "location.host"
135+-- script <- jsstringcreatewithutf8cstring "location.host"
132− lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr
136+-- lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr
133− lh' <- fromJSStringMaybe c lh
137+-- lh' <- fromJSStringMaybe c lh
134− return $ fromMaybe "" lh'
138+-- return $ fromMaybe "" lh'
135−
139+--
136−getLocationProtocol :: WebView -> IO Text
140+--getLocationProtocol :: WebView -> IO Text
137−getLocationProtocol wv = withWebViewContext wv $ \c -> do
141+--getLocationProtocol wv = withWebViewContext wv $ \c -> do
138− script <- jsstringcreatewithutf8cstring "location.protocol"
142+-- script <- jsstringcreatewithutf8cstring "location.protocol"
139− lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr
143+-- lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr
140− lp' <- fromJSStringMaybe c lp
144+-- lp' <- fromJSStringMaybe c lp
141− return $ fromMaybe "" lp'
145+-- return $ fromMaybe "" lp'
142−
146+--
143−bsToArrayBuffer :: JSContextRef -> ByteString -> IO JSValueRef
147+--bsToArrayBuffer :: JSContextRef -> ByteString -> IO JSValueRef
144−bsToArrayBuffer c bs = do
148+--bsToArrayBuffer c bs = do
145− elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x
149+-- elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x
146− let numElems = length elems
150+-- let numElems = length elems
147− bracket (mallocArray numElems) free $ \elemsArr -> do
151+-- bracket (mallocArray numElems) free $ \elemsArr -> do
148− pokeArray elemsArr elems
152+-- pokeArray elemsArr elems
149− a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr
153+-- a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr
150− newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"
154+-- newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"
151− jsevaluatescript c newUint8Array a nullPtr 1 nullPtr
155+-- jsevaluatescript c newUint8Array a nullPtr 1 nullPtr
152−
156+--
153−bsFromArrayBuffer :: JSContextRef -> JSValueRef -> IO ByteString
157+--bsFromArrayBuffer :: JSContextRef -> JSValueRef -> IO ByteString
154−bsFromArrayBuffer c a = do
158+--bsFromArrayBuffer c a = do
155− let getIntegral = fmap round . (\x -> jsvaluetonumber c x nullPtr)
159+-- let getIntegral = fmap round . (\x -> jsvaluetonumber c x nullPtr)
156− getByteLength <- jsstringcreatewithutf8cstring "this.byteLength"
160+-- getByteLength <- jsstringcreatewithutf8cstring "this.byteLength"
157− byteLength <- getIntegral =<< jsevaluatescript c getByteLength a nullPtr 1 nullPtr
161+-- byteLength <- getIntegral =<< jsevaluatescript c getByteLength a nullPtr 1 nullPtr
158− toUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"
162+-- toUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"
159− uint8Array <- jsevaluatescript c toUint8Array a nullPtr 1 nullPtr
163+-- uint8Array <- jsevaluatescript c toUint8Array a nullPtr 1 nullPtr
160− getIx <- jsstringcreatewithutf8cstring "this[0][this[1]]"
164+-- getIx <- jsstringcreatewithutf8cstring "this[0][this[1]]"
161− let arrayLookup i = do
165+-- let arrayLookup i = do
162− i' <- jsvaluemakenumber c (fromIntegral i)
166+-- i' <- jsvaluemakenumber c (fromIntegral i)
163− args <- toJSObject c [uint8Array, i']
167+-- args <- toJSObject c [uint8Array, i']
164− getIntegral =<< jsevaluatescript c getIx args nullPtr 1 nullPtr
168+-- getIntegral =<< jsevaluatescript c getIx args nullPtr 1 nullPtr
165− BS.pack <$> forM [0..byteLength-1] arrayLookup
169+-- BS.pack <$> forM [0..byteLength-1] arrayLookup
166−
170+--
167−withWebViewContext :: WebView -> (JSContextRef -> IO a) -> IO a
171+--withWebViewContext :: WebView -> (JSContextRef -> IO a) -> IO a
168−withWebViewContext wv f = f =<< webFrameGetGlobalContext =<< webViewGetMainFrame wv
172+--withWebViewContext wv f = f =<< webFrameGetGlobalContext =<< webViewGetMainFrame wv
src-ghcjs/Reflex/Dom/Internal/Foreign.hs+6
@@ -2,6 +2,7 @@
2{-# LANGUAGE JavaScriptFFI #-}
2{-# LANGUAGE JavaScriptFFI #-}
3module Reflex.Dom.Internal.Foreign ( module Reflex.Dom.Internal.Foreign
3module Reflex.Dom.Internal.Foreign ( module Reflex.Dom.Internal.Foreign
4 , runWebGUI
4 , runWebGUI
5+ , WebView
5 ) where
6 ) where
6
7
7import Data.ByteString (ByteString)
8import Data.ByteString (ByteString)
@@ -15,6 +16,11 @@ import qualified GHCJS.Marshal.Pure as JS
15import GHCJS.Types
16import GHCJS.Types
16import JavaScript.TypedArray.ArrayBuffer as JS
17import JavaScript.TypedArray.ArrayBuffer as JS
17
18
19+data WebView = WebView
20+
21+runWebGUI :: ((WebView, JSContextRef) -> IO ()) -> IO ()
22+runWebGUI main = run 0 (main (WebView, ()))
23+
18quitWebView :: WebView -> IO ()
24quitWebView :: WebView -> IO ()
19quitWebView = error "quitWebView: unimplemented in GHCJS"
25quitWebView = error "quitWebView: unimplemented in GHCJS"
20
26
src/Foreign/JavaScript/TH.hs+72−134
@@ -20,6 +20,7 @@ module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH
20 , Safety (..)
20 , Safety (..)
21 ) where
21 ) where
22
22
23+import Prelude hiding((!!))
23import Reflex.Class
24import Reflex.Class
24import Reflex.Deletable.Class
25import Reflex.Deletable.Class
25import Reflex.DynamicWriter
26import Reflex.DynamicWriter
@@ -30,10 +31,11 @@ import Reflex.Host.Class
30
31
31import Language.Haskell.TH
32import Language.Haskell.TH
32
33
34+import GHCJS.DOM.Types
35+ (toJSString, liftJSM, askJSM, runJSM, JSContextRef,
36+ Node(..), MonadJSM(..), toJSVal, JSVal)
33#ifdef __GHCJS__
37#ifdef __GHCJS__
34import qualified GHCJS.Buffer as JS
38import qualified GHCJS.Buffer as JS
35−import GHCJS.DOM
36−import GHCJS.DOM.Types hiding (Text, fromJSString)
37import qualified GHCJS.DOM.Types as JS
39import qualified GHCJS.DOM.Types as JS
38import qualified GHCJS.Foreign as JS
40import qualified GHCJS.Foreign as JS
39import qualified GHCJS.Foreign.Callback as JS
41import qualified GHCJS.Foreign.Callback as JS
@@ -52,16 +54,17 @@ import Data.Word
52import Foreign.C.Types
54import Foreign.C.Types
53import Foreign.Ptr
55import Foreign.Ptr
54import Text.Encoding.Z
56import Text.Encoding.Z
57+
58+import Reflex.Dom.Internal.Foreign (WebView)
55#else
59#else
56−import Foreign.Marshal
60+import Data.Word (Word8)
57−import Graphics.UI.Gtk.WebKit.DOM.Node
61+import GI.WebKit2 (WebView)
58−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
62+import Control.Lens.Operators ((^.))
59−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
63+import Language.Javascript.JSaddle
60−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
64+ (eval, valMakeString, valToNumber, function,
61−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
65+ valMakeNumber, valBool, valToText, valToBool, valIsUndefined,
62−import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
66+ valUndefined, valIsNull, Function(..), (!!),
63−import Graphics.UI.Gtk.WebKit.WebView
67+ js, js1, jss, array, freeFunction)
64−import System.Glib.FFI
65#endif
68#endif
66
69
67import Control.Concurrent
70import Control.Concurrent
@@ -76,7 +79,6 @@ import qualified Control.Monad.State.Strict as Strict
76import Control.Monad.Trans.Control
79import Control.Monad.Trans.Control
77import Data.ByteString (ByteString)
80import Data.ByteString (ByteString)
78import qualified Data.ByteString as BS
81import qualified Data.ByteString as BS
79−import Data.Coerce
80import Data.Monoid
82import Data.Monoid
81import Data.Text (Text)
83import Data.Text (Text)
82import qualified Data.Text as T
84import qualified Data.Text as T
@@ -174,11 +176,11 @@ instance MonadRef m => MonadRef (WithWebView x m) where
174instance MonadAtomicRef m => MonadAtomicRef (WithWebView x m) where
176instance MonadAtomicRef m => MonadAtomicRef (WithWebView x m) where
175 atomicModifyRef r = lift . atomicModifyRef r
177 atomicModifyRef r = lift . atomicModifyRef r
176
178
177−withWebViewSingleton :: WebView -> (forall x. WebViewSingleton x -> r) -> r
179+withWebViewSingleton :: (WebView, JSContextRef) -> (forall x. WebViewSingleton x -> r) -> r
178withWebViewSingleton wv f = f $ WebViewSingleton wv
180withWebViewSingleton wv f = f $ WebViewSingleton wv
179
181
180-- | 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
182-- | 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) }
182
184
183#ifdef __GHCJS__
185#ifdef __GHCJS__
184type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal
186type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal
@@ -187,35 +189,36 @@ newtype JSFFI = JSFFI JSFFI_Internal
187newtype JSFFI = JSFFI String
189newtype JSFFI = JSFFI String
188#endif
190#endif
189
191
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+ }
191
197
192instance ToJS x (JSFun x) where
198instance ToJS x (JSFun x) where
193− withJS (JSFun r) f = f r
199+ withJS r f = f (unJSFun r)
194−
195−instance FromJS x (JSFun x) where
196− fromJS = return . JSFun
197
200
198class IsJSContext x where
201class IsJSContext x where
199 data JSRef x
202 data JSRef x
200
203
201−class (Monad m, MonadIO (JSM m), MonadFix (JSM m), MonadJS x (JSM m)) => HasJS x m | m -> x where
204+class (Monad m, MonadIO (JSX m), MonadFix (JSX m), MonadJS x (JSX m)) => HasJS x m | m -> x where
202− type JSM m :: * -> *
205+ type JSX m :: * -> *
203− liftJS :: JSM m a -> m a
206+ liftJS :: JSX m a -> m a
204
207
205instance HasJS x m => HasJS x (ReaderT r m) where
208instance 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
207 liftJS = lift . liftJS
210 liftJS = lift . liftJS
208
211
209instance (HasJS x m, ReflexHost t) => HasJS x (PostBuildT t m) where
212instance (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
211 liftJS = lift . liftJS
214 liftJS = lift . liftJS
212
215
213instance (HasJS x (HostFrame t), ReflexHost t) => HasJS x (PerformEventT t m) where
216instance (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)
215 liftJS = PerformEventT . lift . liftJS
218 liftJS = PerformEventT . lift . liftJS
216
219
217instance HasJS x m => HasJS x (DynamicWriterT t w m) where
220instance 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
219 liftJS = lift . liftJS
222 liftJS = lift . liftJS
220
223
221-- | A Monad that is capable of executing JavaScript
224-- | A Monad that is capable of executing JavaScript
@@ -247,7 +250,7 @@ class Monad m => MonadJS x m | m -> x where
247data JSCtx_IO
250data JSCtx_IO
248
251
249instance MonadIO m => HasJS JSCtx_IO (WithWebView x m) where
252instance MonadIO m => HasJS JSCtx_IO (WithWebView x m) where
250− type JSM (WithWebView x m) = IO
253+ type JSX (WithWebView x m) = IO
251 liftJS = liftIO
254 liftJS = liftIO
252
255
253instance IsJSContext JSCtx_IO where
256instance IsJSContext JSCtx_IO where
@@ -296,25 +299,13 @@ foreign import javascript unsafe "function(){ return $1(arguments); }" funWithAr
296
299
297#else
300#else
298
301
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−
311data JSCtx_JavaScriptCore x
302data JSCtx_JavaScriptCore x
312
303
313instance IsJSContext (JSCtx_JavaScriptCore x) where
304instance 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 }
315
306
316instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithWebView x m) where
307instance 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
318 liftJS a = do
309 liftJS a = do
319 wv <- askWebView
310 wv <- askWebView
320 liftIO $ runWithWebView a wv
311 liftIO $ runWithWebView a wv
@@ -324,23 +315,21 @@ newtype WithJSContext x m a = WithJSContext { unWithJSContext :: ReaderT JSConte
324runWithJSContext :: WithJSContext x m a -> JSContextRef -> m a
315runWithJSContext :: WithJSContext x m a -> JSContextRef -> m a
325runWithJSContext = runReaderT . unWithJSContext
316runWithJSContext = runReaderT . unWithJSContext
326
317
327−class Monad m => HasJSContext m where
328− askJSContext :: m JSContextRef
329−
330−instance MonadIO m => HasJSContext (WithWebView x m) where
318+instance MonadIO m => MonadJSM (WithWebView x m) where
331− askJSContext = do
319+ liftJSM' f = do
332 wv <- askWebView
320 wv <- askWebView
333− liftIO $ webFrameGetGlobalContext =<< webViewGetMainFrame (unWebViewSingleton wv)
321+ runJSM f . snd $ unWebViewSingleton wv
334
322
335−instance Monad m => HasJSContext (WithJSContext x m) where
323+instance MonadIO m => MonadJSM (WithJSContext x m) where
324+ liftJSM' f =
336− askJSContext = WithJSContext ask
325+ runJSM f =<< WithJSContext ask
337
326
338−lowerWithJSContext :: (HasJSContext m, MonadIO m) => WithJSContext x IO a -> m a
327+lowerWithJSContext :: MonadJSM m => WithJSContext x IO a -> m a
339lowerWithJSContext a = do
328lowerWithJSContext a = do
340− c <- askJSContext
329+ c <- askJSM
341 liftIO $ runWithJSContext a c
330 liftIO $ runWithJSContext a c
342
331
343−liftWithWebViewThroughWithJSContext :: (HasJSContext m, HasWebView m, MonadIO m, MonadTrans t, Monad m1)
332+liftWithWebViewThroughWithJSContext :: (HasWebView m, MonadJSM m, MonadTrans t, Monad m1)
344 => ((t1 -> t m1 a) -> WithJSContext x IO b)
333 => ((t1 -> t m1 a) -> WithJSContext x IO b)
345 -> (t1 -> WithWebView (WebViewPhantom m) m1 a)
334 -> (t1 -> WithWebView (WebViewPhantom m) m1 a)
346 -> m b
335 -> m b
@@ -375,96 +364,45 @@ instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
375 getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef
364 getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef
376
365
377instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContext x IO) where
366instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContext x IO) where
378− runJS (JSFFI body) args = do
367+ runJS (JSFFI body) args =
379− jsContext <- askJSContext
380− withJSArray args $ \(JSRef_JavaScriptCore this) -> liftIO $ do
368+ withJSArray args $ \(JSRef_JavaScriptCore this) -> do
381− result <- bracket (jsstringcreatewithutf8cstring body) jsstringrelease $ \script -> jsevaluatescript jsContext script this nullPtr 1 nullPtr
369+ result <- liftJSM $ eval ("(function(){ return (" <> body <> "); })") ^. js1 "apply" this
382− return $ JSRef_JavaScriptCore result --TODO: Protect and unprotect result
370+ return $ JSRef_JavaScriptCore result
383 forkJS a = do
371 forkJS a = do
384− c <- askJSContext
372+ c <- askJSM
385− liftIO $ forkIO $ runWithJSContext a c
373+ liftIO . forkIO $ runWithJSContext a c
386− mkJSUndefined = do
374+ mkJSUndefined = return $ JSRef_JavaScriptCore valUndefined
387− jsContext <- askJSContext
388− fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext
389− isJSNull (JSRef_JavaScriptCore r) = do
375+ isJSNull (JSRef_JavaScriptCore r) = liftJSM $ valIsNull r
390− jsContext <- askJSContext
391− liftIO $ jsvalueisnull jsContext r
392− isJSUndefined (JSRef_JavaScriptCore r) = do
376+ isJSUndefined (JSRef_JavaScriptCore r) = liftJSM $ valIsUndefined r
393− jsContext <- askJSContext
394− liftIO $ jsvalueisundefined jsContext r
395− fromJSBool (JSRef_JavaScriptCore r) = do
377+ fromJSBool (JSRef_JavaScriptCore r) = liftJSM $ valToBool r
396− jsContext <- askJSContext
397− liftIO $ jsvaluetoboolean jsContext r
398− fromJSString (JSRef_JavaScriptCore r) = do
378+ fromJSString (JSRef_JavaScriptCore r) = liftJSM (T.unpack <$> valToText r)
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
379+ withJSBool b a = a $ JSRef_JavaScriptCore (valBool b)
410− withJSString str a = do
380+ withJSString str a = a . JSRef_JavaScriptCore =<< liftJSM (valMakeString $ toJSString str)
411− jsContext <- askJSContext
381+ withJSNumber n a = a . JSRef_JavaScriptCore =<< liftJSM (valMakeNumber n)
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
382+ withJSArray elems a = a . JSRef_JavaScriptCore =<< liftJSM
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
383+ (toJSVal =<< array (map (\(JSRef_JavaScriptCore r) -> r) elems))
426− --TODO: When supported by webkitgtk3-javascriptcore, go directly from C string to Uint8Array without creating each item individually
427 withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do
384 withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do
428 payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]
385 payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]
429 f $ JSUint8Array payloadRef
386 f $ JSUint8Array payloadRef
430− fromJSArray (JSRef_JavaScriptCore a) = do
387+ fromJSArray (JSRef_JavaScriptCore a) = liftJSM $ do
431− jsContext <- askJSContext
388+ len <- round <$> (valToNumber =<< (a ^. js "length"))
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
389+ forM [0..len-1] $ \i -> JSRef_JavaScriptCore <$> a !! i
437− JSRef_JavaScriptCore <$> jsobjectgetpropertyatindex jsContext a i nullPtr --TODO: Exceptions
438 fromJSUint8Array a = do
390 fromJSUint8Array a = do
439 vals <- fromJSArray a
391 vals <- fromJSArray a
440 doubles <- mapM fromJSNumber vals
392 doubles <- mapM fromJSNumber vals
441 return $ BS.pack $ map round doubles
393 return $ BS.pack $ map round doubles
442− fromJSNumber (JSRef_JavaScriptCore val) = do
394+ fromJSNumber (JSRef_JavaScriptCore val) = liftJSM $ valToNumber val
443− jsContext <- askJSContext
444− liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
445− mkJSFun a = do
395+ mkJSFun a = liftJSM $ do
446− jsContext <- askJSContext
396+ ctx <- askJSM
447− cb <- liftIO $ mkJSObjectCallAsFunctionCallback $ \_ _ _ argc argv _ -> do --TODO: Use the exception pointer to handle haskell exceptions
397+ f <- function $ \_ _ args -> liftIO $ void $ runWithJSContext (a $ map JSRef_JavaScriptCore args) ctx
448− args <- forM [0..fromIntegral (argc-1)] $ \n -> do
398+ fRef <- toJSVal f
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
399+ return $ JSFun (JSRef_JavaScriptCore fRef) f
456− freeJSFun (JSFun (JSRef_JavaScriptCore f)) = do
400+ freeJSFun (JSFun _ f) = liftJSM $ freeFunction f
457− jsContext <- askJSContext
458− liftIO $ jsvalueunprotect jsContext f
459− setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) = do
401+ setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) =
460− withJSStringRaw propName $ \propNameRaw -> do
402+ liftJSM $ objRef ^. jss propName valRef
461− jsContext <- askJSContext
462− liftIO $ jsobjectsetproperty jsContext objRef propNameRaw valRef 0 nullPtr --TODO: property attribute, exceptions
463− getJSProp propName (JSRef_JavaScriptCore objRef) = do
403+ getJSProp propName (JSRef_JavaScriptCore objRef) =
464− withJSStringRaw propName $ \propNameRaw -> do
404+ JSRef_JavaScriptCore <$> liftJSM (objRef ^. js propName)
465− jsContext <- askJSContext
405+ withJSNode n f = f . JSRef_JavaScriptCore =<< liftJSM (toJSVal n)
466− liftIO $ JSRef_JavaScriptCore <$> jsobjectgetproperty jsContext objRef propNameRaw nullPtr --TODO: property attribute, exceptions
467− withJSNode = error "withJSNode is only supported in ghcjs"
468
406
469#endif
407#endif
470
408
src/Reflex/Dom.hs−3
@@ -7,9 +7,6 @@ import Reflex.Dom.Builder.InputDisabled as X
7import Reflex.Dom.Builder.Static as X
7import Reflex.Dom.Builder.Static as X
8import Reflex.Dom.Class as X
8import Reflex.Dom.Class as X
9import Reflex.Dom.Internal as X
9import Reflex.Dom.Internal as X
10−import Reflex.Dom.Location as X
11import Reflex.Dom.Old as X
10import Reflex.Dom.Old as X
12import Reflex.Dom.Time as X
11import Reflex.Dom.Time as X
13−import Reflex.Dom.WebSocket as X
14import Reflex.Dom.Widget as X
12import 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 #-}
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE EmptyDataDecls #-}
4{-# LANGUAGE EmptyDataDecls #-}
@@ -53,9 +54,12 @@ import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea
53import GHCJS.DOM.MouseEvent
54import GHCJS.DOM.MouseEvent
54import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling, insertBefore,
55import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling, insertBefore,
55 removeChild, setNodeValue, toNode)
56 removeChild, setNodeValue, toNode)
57+import GHCJS.DOM.Types
58+ (liftJSM, askJSM, runJSM, JSM, MonadJSM(..),
56−import GHCJS.DOM.Types (FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, ToDOMString, TouchEvent,
59+ FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node,
57− WheelEvent, castToHTMLInputElement, castToHTMLSelectElement,
60+ ToDOMString, TouchEvent, WheelEvent, castToHTMLInputElement,
58− castToHTMLTextAreaElement)
61+ castToHTMLSelectElement, castToHTMLTextAreaElement,
62+ strictEqual)
59import qualified GHCJS.DOM.Types as DOM
63import qualified GHCJS.DOM.Types as DOM
60import GHCJS.DOM.UIEvent
64import GHCJS.DOM.UIEvent
61import qualified GHCJS.DOM.Window as Window
65import qualified GHCJS.DOM.Window as Window
@@ -64,7 +68,7 @@ import Debug.Trace hiding (traceEvent)
64
68
65data TriggerRef t a = TriggerRef { unTriggerRef :: IORef (Maybe (EventTrigger t a)) }
69data TriggerRef t a = TriggerRef { unTriggerRef :: IORef (Maybe (EventTrigger t a)) }
66
70
67−data TriggerInvocation a = TriggerInvocation a (IO ())
71+data TriggerInvocation a = TriggerInvocation a (JSM ())
68
72
69data ImmediateDomBuilderEnv t
73data ImmediateDomBuilderEnv t
70 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document
74 = ImmediateDomBuilderEnv { _immediateDomBuilderEnv_document :: Document
@@ -74,6 +78,11 @@ data ImmediateDomBuilderEnv t
74
78
75newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
79newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
76
80
81+#ifndef __GHCJS__
82+instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
83+ liftJSM' = ImmediateDomBuilderT . liftJSM'
84+#endif
85+
77instance MonadTransControl (ImmediateDomBuilderT t) where
86instance MonadTransControl (ImmediateDomBuilderT t) where
78 type StT (ImmediateDomBuilderT t) a = StT (ReaderT (ImmediateDomBuilderEnv t)) a
87 type StT (ImmediateDomBuilderT t) a = StT (ReaderT (ImmediateDomBuilderEnv t)) a
79 liftWith = defaultLiftWith ImmediateDomBuilderT unImmediateDomBuilderT
88 liftWith = defaultLiftWith ImmediateDomBuilderT unImmediateDomBuilderT
@@ -99,23 +108,23 @@ askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (TriggerRef t) Trig
99askEvents = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_events
108askEvents = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_events
100
109
101{-# INLINABLE append #-}
110{-# INLINABLE append #-}
102−append :: (IsNode n, MonadIO m) => n -> ImmediateDomBuilderT t m ()
111+append :: (IsNode n, MonadJSM m) => n -> ImmediateDomBuilderT t m ()
103append n = do
112append n = do
104 p <- askParent
113 p <- askParent
105− _ <- liftIO $ appendChild p $ Just n
114+ _ <- liftJSM $ appendChild p $ Just n
106 return ()
115 return ()
107
116
108{-# INLINABLE textNodeInternal #-}
117{-# 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
110textNodeInternal t = do
119textNodeInternal t = do
111 doc <- askDocument
120 doc <- askDocument
112− Just n <- liftIO $ createTextNode doc t
121+ Just n <- liftJSM $ createTextNode doc t
113 append n
122 append n
114 return n
123 return n
115
124
116-- | s and e must both be children of the same node and s must precede e
125-- | s and e must both be children of the same node and s must precede e
117{-# INLINABLE deleteBetweenInclusive #-}
126{-# INLINABLE deleteBetweenInclusive #-}
118−deleteBetweenInclusive :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()
127+deleteBetweenInclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
119deleteBetweenInclusive s e = do
128deleteBetweenInclusive s e = do
120 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
129 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
121 case mCurrentParent of
130 case mCurrentParent of
@@ -124,12 +133,14 @@ deleteBetweenInclusive s e = do
124 let go = do
133 let go = do
125 Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
134 Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
126 _ <- removeChild currentParent $ Just x
135 _ <- removeChild currentParent $ Just x
127− when (toNode s /= toNode x) go
136+ liftJSM (strictEqual s x) >>= \case
137+ True -> return ()
138+ False -> go
128 go
139 go
129 _ <- removeChild currentParent $ Just e
140 _ <- removeChild currentParent $ Just e
130 return ()
141 return ()
131
142
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)
133
144
134newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))
145newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))
135
146
@@ -139,35 +150,37 @@ wrap e cfg = do
139 lift $ performEvent_ $ ffor (cfg ^. modifyAttributes) $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
150 lift $ performEvent_ $ ffor (cfg ^. modifyAttributes) $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
140 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
151 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
141 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv
152 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
153+ eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftJSM $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do
143− triggerRef <- newIORef Nothing
154+ triggerRef <- liftIO $ newIORef Nothing
144 _ <- elementOnEventName en e $ do
155 _ <- elementOnEventName en e $ do
145 evt <- DOM.event
156 evt <- DOM.event
146− (flags, k) <- liftIO $ f $ GhcjsDomEvent evt
157+ (flags, k) <- liftJSM $ f $ GhcjsDomEvent evt
147 when (_eventFlags_preventDefault flags) $ withIsEvent en DOM.preventDefault
158 when (_eventFlags_preventDefault flags) $ withIsEvent en DOM.preventDefault
148 case _eventFlags_propagation flags of
159 case _eventFlags_propagation flags of
149 Propagation_Continue -> return ()
160 Propagation_Continue -> return ()
150 Propagation_Stop -> withIsEvent en DOM.stopPropagation
161 Propagation_Stop -> withIsEvent en DOM.stopPropagation
151 Propagation_StopImmediate -> withIsEvent en DOM.stopImmediatePropagation
162 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
153 liftIO $ forM_ mv $ \v -> writeChan events [TriggerRef triggerRef :=> TriggerInvocation v (return ())]
164 liftIO $ forM_ mv $ \v -> writeChan events [TriggerRef triggerRef :=> TriggerInvocation v (return ())]
154 return $ en :=> EventFilterTriggerRef triggerRef
165 return $ en :=> EventFilterTriggerRef triggerRef
166+ es <- do
167+ ctx <- askJSM
155− es <- newFanEventWithTrigger $ \(WrapArg en) t -> do
168+ newFanEventWithTrigger $ \(WrapArg en) t ->
156− case DMap.lookup en eventTriggerRefs of
169+ case DMap.lookup en eventTriggerRefs of
157− Just (EventFilterTriggerRef r) -> do
170+ Just (EventFilterTriggerRef r) -> do
158− writeIORef r $ Just t
171+ writeIORef r $ Just t
159− return $ do
172+ return $ do
160− writeIORef r Nothing
173+ writeIORef r Nothing
161− Nothing -> elementOnEventName en e $ do
174+ Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
162− evt <- DOM.event
175+ evt <- DOM.event
163− let h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg
176+ let h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg
164− mv <- liftIO $ h (en, GhcjsDomEvent evt)
177+ mv <- lift $ h (en, GhcjsDomEvent evt)
165− case mv of
178+ case mv of
166− Nothing -> return ()
179+ Nothing -> return ()
167− Just v -> liftIO $ do
180+ 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
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
169− ref <- newIORef $ Just t
182+ ref <- newIORef $ Just t
170− writeChan events [TriggerRef ref :=> TriggerInvocation v (return ())]
183+ writeChan events [TriggerRef ref :=> TriggerInvocation v (return ())])
171 return $ Element es e
184 return $ Element es e
172
185
173{-# INLINABLE makeElement #-}
186{-# INLINABLE makeElement #-}
@@ -175,12 +188,12 @@ makeElement :: forall er t m a. SupportsImmediateDomBuilder t m => Text -> Eleme
175makeElement elementTag cfg child = do
188makeElement elementTag cfg child = do
176 doc <- askDocument
189 doc <- askDocument
177 events <- askEvents
190 events <- askEvents
178− Just e <- ImmediateDomBuilderT $ fmap DOM.castToElement <$> case cfg ^. namespace of
191+ Just e <- liftJSM $ case cfg ^. namespace of
179 Nothing -> createElement doc (Just elementTag)
192 Nothing -> createElement doc (Just elementTag)
180 Just ens -> createElementNS doc (Just ens) (Just elementTag)
193 Just ens -> createElementNS doc (Just ens) (Just elementTag)
181 ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
194 ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
182− Nothing -> setAttribute e n v
195+ Nothing -> lift $ setAttribute e n v
183− Just ans -> setAttributeNS e (Just ans) n v
196+ Just ans -> lift $ setAttributeNS e (Just ans) n v
184 result <- lift $ runImmediateDomBuilderT child $ ImmediateDomBuilderEnv
197 result <- lift $ runImmediateDomBuilderT child $ ImmediateDomBuilderEnv
185 { _immediateDomBuilderEnv_parent = toNode e
198 { _immediateDomBuilderEnv_parent = toNode e
186 , _immediateDomBuilderEnv_document = doc
199 , _immediateDomBuilderEnv_document = doc
@@ -190,9 +203,9 @@ makeElement elementTag cfg child = do
190 wrapped <- wrap e $ extractRawElementConfig cfg
203 wrapped <- wrap e $ extractRawElementConfig cfg
191 return ((wrapped, result), e)
204 return ((wrapped, result), e)
192
205
193−newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> IO b }
206+newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> JSM b }
194
207
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) }
196
209
197newtype GhcjsDomEvent en = GhcjsDomEvent { unGhcjsDomEvent :: EventType en }
210newtype GhcjsDomEvent en = GhcjsDomEvent { unGhcjsDomEvent :: EventType en }
198
211
@@ -220,7 +233,7 @@ instance DomSpace GhcjsDomSpace where
220 in DMap.alter f' en $ _ghcjsEventSpec_filters es
233 in DMap.alter f' en $ _ghcjsEventSpec_filters es
221 }
234 }
222
235
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))))
224
237
225data Pair1 (f :: k -> *) (g :: k -> *) (a :: k) = Pair1 (f a) (g a)
238data Pair1 (f :: k -> *) (g :: k -> *) (a :: k) = Pair1 (f a) (g a)
226
239
@@ -228,7 +241,7 @@ data Maybe1 f a = Nothing1 | Just1 (f a)
228
241
229data GhcjsEventSpec er = GhcjsEventSpec
242data GhcjsEventSpec er = GhcjsEventSpec
230 { _ghcjsEventSpec_filters :: DMap EventName (GhcjsEventFilter er)
243 { _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))
232 }
245 }
233
246
234instance er ~ EventResult => Default (GhcjsEventSpec er) where
247instance er ~ EventResult => Default (GhcjsEventSpec er) where
@@ -236,7 +249,8 @@ instance er ~ EventResult => Default (GhcjsEventSpec er) where
236 { _ghcjsEventSpec_filters = mempty
249 { _ghcjsEventSpec_filters = mempty
237 , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> do
250 , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> do
238 Just t <- withIsEvent en $ Event.getTarget evt --TODO: Rework this; defaultDomEventHandler shouldn't need to take this as an argument
251 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
240 }
254 }
241
255
242instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where
256instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where
@@ -260,7 +274,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
260 {-# INLINABLE inputElement #-}
274 {-# INLINABLE inputElement #-}
261 inputElement cfg = do
275 inputElement cfg = do
262 ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
276 ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
263− let domInputElement = castToHTMLInputElement domElement
277+ domInputElement <- liftJSM $ castToHTMLInputElement domElement
264 Input.setValue domInputElement $ Just (cfg ^. inputElementConfig_initialValue)
278 Input.setValue domInputElement $ Just (cfg ^. inputElementConfig_initialValue)
265 Just v0 <- Input.getValue domInputElement
279 Just v0 <- Input.getValue domInputElement
266 let getMyValue = fromMaybe "" <$> Input.getValue domInputElement
280 let getMyValue = fromMaybe "" <$> Input.getValue domInputElement
@@ -307,7 +321,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
307 {-# INLINABLE textAreaElement #-}
321 {-# INLINABLE textAreaElement #-}
308 textAreaElement cfg = do --TODO
322 textAreaElement cfg = do --TODO
309 ((e, _), domElement) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
323 ((e, _), domElement) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
310− let domTextAreaElement = castToHTMLTextAreaElement domElement
324+ domTextAreaElement <- liftJSM $ castToHTMLTextAreaElement domElement
311 TextArea.setValue domTextAreaElement $ Just (cfg ^. textAreaElementConfig_initialValue)
325 TextArea.setValue domTextAreaElement $ Just (cfg ^. textAreaElementConfig_initialValue)
312 Just v0 <- TextArea.getValue domTextAreaElement
326 Just v0 <- TextArea.getValue domTextAreaElement
313 let getMyValue = fromMaybe "" <$> TextArea.getValue domTextAreaElement
327 let getMyValue = fromMaybe "" <$> TextArea.getValue domTextAreaElement
@@ -330,7 +344,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
330 {-# INLINABLE selectElement #-}
344 {-# INLINABLE selectElement #-}
331 selectElement cfg child = do
345 selectElement cfg child = do
332 ((e, result), domElement) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child
346 ((e, result), domElement) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child
333− let domSelectElement = castToHTMLSelectElement domElement
347+ domSelectElement <- liftJSM $ castToHTMLSelectElement domElement
334 Select.setValue domSelectElement $ Just (cfg ^. selectElementConfig_initialValue)
348 Select.setValue domSelectElement $ Just (cfg ^. selectElementConfig_initialValue)
335 Just v0 <- Select.getValue domSelectElement
349 Just v0 <- Select.getValue domSelectElement
336 let getMyValue = fromMaybe "" <$> Select.getValue domSelectElement
350 let getMyValue = fromMaybe "" <$> Select.getValue domSelectElement
@@ -363,7 +377,7 @@ mkHasFocus e = do
363 ]
377 ]
364
378
365{-# INLINABLE insertImmediateAbove #-}
379{-# 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)
367insertImmediateAbove n toInsertAbove = do
381insertImmediateAbove n toInsertAbove = do
368 events <- askEvents
382 events <- askEvents
369 lift $ performEvent $ ffor toInsertAbove $ \new -> do
383 lift $ performEvent $ ffor toInsertAbove $ \new -> do
@@ -416,13 +430,13 @@ instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) =>
416 newTriggerEventWithOnComplete = do
430 newTriggerEventWithOnComplete = do
417 events <- askEvents
431 events <- askEvents
418 (eResult, reResultTrigger) <- lift newEventWithTriggerRef
432 (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)]
420 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
434 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
421 newEventWithLazyTriggerWithOnComplete f = do
435 newEventWithLazyTriggerWithOnComplete f = do
422 events <- askEvents
436 events <- askEvents
423 lift $ newEventWithTrigger $ \t -> f $ \a cb -> do
437 lift $ newEventWithTrigger $ \t -> f $ \a cb -> do
424 reResultTrigger <- newIORef $ Just t
438 reResultTrigger <- newIORef $ Just t
425− writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a cb]
439+ writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a (liftIO cb)]
426
440
427instance HasWebView m => HasWebView (ImmediateDomBuilderT t m) where
441instance HasWebView m => HasWebView (ImmediateDomBuilderT t m) where
428 type WebViewPhantom (ImmediateDomBuilderT t m) = WebViewPhantom m
442 type WebViewPhantom (ImmediateDomBuilderT t m) = WebViewPhantom m
@@ -442,7 +456,7 @@ instance MonadAtomicRef m => MonadAtomicRef (ImmediateDomBuilderT t m) where
442 atomicModifyRef r = lift . atomicModifyRef r
456 atomicModifyRef r = lift . atomicModifyRef r
443
457
444instance (HasJS x m, ReflexHost t) => HasJS x (ImmediateDomBuilderT t m) where
458instance (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
446 liftJS = lift . liftJS
460 liftJS = lift . liftJS
447
461
448type family EventType en where
462type family EventType en where
@@ -643,9 +657,58 @@ withIsEvent en r = case en of
643 Mousewheel -> r
657 Mousewheel -> r
644 Wheel -> r
658 Wheel -> r
645
659
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+
646{-# INLINABLE elementOnEventName #-}
709{-# INLINABLE elementOnEventName #-}
647−elementOnEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())
710+elementOnEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> JSM (JSM ())
648−elementOnEventName en e = case en of
711+elementOnEventName en e = \x -> liftIO (putStrLn $ "element event handler added " <> showEventName en) >> (case en of
649 Abort -> on e Element.abort
712 Abort -> on e Element.abort
650 Blur -> on e Element.blurEvent
713 Blur -> on e Element.blurEvent
651 Change -> on e Element.change
714 Change -> on e Element.change
@@ -691,11 +754,12 @@ elementOnEventName en e = case en of
691 Touchstart -> on e Element.touchStart
754 Touchstart -> on e Element.touchStart
692 Touchmove -> on e Element.touchMove
755 Touchmove -> on e Element.touchMove
693 Touchend -> on e Element.touchEnd
756 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)
695
759
696{-# INLINABLE windowOnEventName #-}
760{-# INLINABLE windowOnEventName #-}
697−windowOnEventName :: EventName en -> DOM.Window -> EventM DOM.Window (EventType en) () -> IO (IO ())
761+windowOnEventName :: EventName en -> DOM.Window -> EventM DOM.Window (EventType en) () -> JSM (JSM ())
698−windowOnEventName en e = case en of
762+windowOnEventName en e = \x -> liftIO (putStrLn $ "window event handler added " <> showEventName en) >> (case en of
699 Abort -> on e Window.abort
763 Abort -> on e Window.abort
700 Blur -> on e Window.blurEvent
764 Blur -> on e Window.blurEvent
701 Change -> on e Window.change
765 Change -> on e Window.change
@@ -741,18 +805,19 @@ windowOnEventName en e = case en of
741 Touchstart -> on e Window.touchStart
805 Touchstart -> on e Window.touchStart
742 Touchmove -> on e Window.touchMove
806 Touchmove -> on e Window.touchMove
743 Touchend -> on e Window.touchEnd
807 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)
745
810
746{-# INLINABLE wrapDomEvent #-}
811{-# 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)
748wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $ fmap Just getValue
813wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $ fmap Just getValue
749
814
750{-# INLINABLE subscribeDomEvent #-}
815{-# INLINABLE subscribeDomEvent #-}
751−subscribeDomEvent :: (EventM e event () -> IO (IO ()))
816+subscribeDomEvent :: (EventM e event () -> JSM (JSM ()))
752 -> EventM e event (Maybe a)
817 -> EventM e event (Maybe a)
753 -> Chan [DSum (TriggerRef t) TriggerInvocation]
818 -> Chan [DSum (TriggerRef t) TriggerInvocation]
754 -> EventTrigger t a
819 -> EventTrigger t a
755− -> IO (IO ())
820+ -> JSM (JSM ())
756subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do
821subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do
757 mv <- getValue
822 mv <- getValue
758 forM_ mv $ \v -> liftIO $ do
823 forM_ mv $ \v -> liftIO $ do
@@ -761,25 +826,28 @@ subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do
761 writeChan eventChan [TriggerRef etr :=> TriggerInvocation v (return ())]
826 writeChan eventChan [TriggerRef etr :=> TriggerInvocation v (return ())]
762
827
763{-# INLINABLE wrapDomEventMaybe #-}
828{-# INLINABLE wrapDomEventMaybe #-}
764−wrapDomEventMaybe :: TriggerEvent t m
829+wrapDomEventMaybe :: (TriggerEvent t m, MonadJSM m)
765 => e
830 => e
766− -> (e -> EventM e event () -> IO (IO ()))
831+ -> (e -> EventM e event () -> JSM (JSM ()))
767 -> EventM e event (Maybe a)
832 -> EventM e event (Maybe a)
768 -> m (Event t a)
833 -> m (Event t a)
769wrapDomEventMaybe el elementOnevent getValue = do
834wrapDomEventMaybe el elementOnevent getValue = do
835+ ctx <- askJSM
770− newEventWithLazyTriggerWithOnComplete $ \trigger -> elementOnevent el $ do
836+ newEventWithLazyTriggerWithOnComplete $ \trigger -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnevent el $ do
771 mv <- getValue
837 mv <- getValue
772− forM_ mv $ \v -> liftIO $ trigger v $ return ()
838+ forM_ mv $ \v -> liftIO $ trigger v $ return ())
773
839
774{-# INLINABLE wrapDomEventsMaybe #-}
840{-# INLINABLE wrapDomEventsMaybe #-}
775−wrapDomEventsMaybe :: (MonadIO m, MonadReflexCreateTrigger t m)
841+wrapDomEventsMaybe :: (MonadJSM m, MonadReflexCreateTrigger t m)
776 => e
842 => e
777 -> (forall en. IsEvent (EventType en) => EventName en -> EventM e (EventType en) (Maybe (f en)))
843 -> (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 ()))
779 -> ImmediateDomBuilderT t m (EventSelector t (WrapArg f EventName))
845 -> ImmediateDomBuilderT t m (EventSelector t (WrapArg f EventName))
780wrapDomEventsMaybe target handlers onEventName = do
846wrapDomEventsMaybe target handlers onEventName = do
847+ ctx <- askJSM
781 eventChan <- askEvents
848 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)
783 return $! e
851 return $! e
784
852
785{-# INLINABLE getKeyEvent #-}
853{-# INLINABLE getKeyEvent #-}
@@ -820,7 +888,7 @@ data Window t = Window
820 , _window_raw :: DOM.Window
888 , _window_raw :: DOM.Window
821 }
889 }
822
890
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)
824wrapWindow wv _ = do
892wrapWindow wv _ = do
825 events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName
893 events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName
826 return $ Window
894 return $ Window
src/Reflex/Dom/Builder/InputDisabled.hs+1−1
@@ -86,5 +86,5 @@ instance HasWebView m => HasWebView (InputDisabledT m) where
86 askWebView = lift askWebView
86 askWebView = lift askWebView
87
87
88instance HasJS js m => HasJS js (InputDisabledT m) where
88instance HasJS js m => HasJS js (InputDisabledT m) where
89− type JSM (InputDisabledT m) = JSM m
89+ type JSX (InputDisabledT m) = JSX m
90 liftJS = lift . liftJS
90 liftJS = lift . liftJS
src/Reflex/Dom/Internal.hs+27−20
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
@@ -11,6 +12,7 @@
11{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE UndecidableInstances #-}
14{-# LANGUAGE UndecidableInstances #-}
15+{-# LANGUAGE PatternSynonyms #-}
14module Reflex.Dom.Internal where
16module Reflex.Dom.Internal where
15
17
16import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)
18import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)
@@ -36,51 +38,56 @@ import Data.Monoid ((<>))
36import Data.Text (Text)
38import Data.Text (Text)
37import qualified Data.Text as T
39import qualified Data.Text as T
38import Data.Text.Encoding
40import Data.Text.Encoding
39−import GHCJS.DOM hiding (runWebGUI)
41+import GHCJS.DOM
40import GHCJS.DOM.Document
42import GHCJS.DOM.Document
41import GHCJS.DOM.Element
43import GHCJS.DOM.Element
42import GHCJS.DOM.Node
44import GHCJS.DOM.Node
43import qualified GHCJS.DOM.Types as DOM
45import qualified GHCJS.DOM.Types as DOM
46+import GHCJS.DOM.Types (MonadJSM(..), runJSM, askJSM, JSM)
44
47
45{-# INLINABLE mainWidget #-}
48{-# INLINABLE mainWidget #-}
46mainWidget :: (forall x. Widget x ()) -> IO ()
49mainWidget :: (forall x. Widget x ()) -> IO ()
47−mainWidget w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
50+mainWidget w = runWebGUI $ \(webView, ctx) -> withWebViewSingleton (webView, ctx) $ \webViewSing -> (`runJSM` ctx) $ do
48− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
51+ Just doc <- currentDocument
49 Just body <- getBody doc
52 Just body <- getBody doc
50 attachWidget body webViewSing w
53 attachWidget body webViewSing w
51
54
52--TODO: The x's should be unified here
55--TODO: The x's should be unified here
53{-# INLINABLE mainWidgetWithHead #-}
56{-# INLINABLE mainWidgetWithHead #-}
54mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> IO ()
57mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> IO ()
55−mainWidgetWithHead h b = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
58+mainWidgetWithHead h b = runWebGUI $ \(webView, ctx) -> withWebViewSingleton (webView, ctx) $ \webViewSing -> (`runJSM` ctx) $ do
56− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
59+ Just doc <- currentDocument
57− Just headElement <- fmap DOM.castToHTMLElement <$> getHead doc
60+ Just headElement <- getHead doc
58 attachWidget headElement webViewSing h
61 attachWidget headElement webViewSing h
59 Just body <- getBody doc
62 Just body <- getBody doc
60 attachWidget body webViewSing b
63 attachWidget body webViewSing b
61
64
62{-# INLINABLE mainWidgetWithCss #-}
65{-# INLINABLE mainWidgetWithCss #-}
63mainWidgetWithCss :: ByteString -> (forall x. Widget x ()) -> IO ()
66mainWidgetWithCss :: ByteString -> (forall x. Widget x ()) -> IO ()
64−mainWidgetWithCss css w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
67+mainWidgetWithCss css w = runWebGUI $ \(webView, ctx) -> withWebViewSingleton (webView, ctx) $ \webViewSing -> (`runJSM` ctx) $ do
65− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
68+ Just doc <- currentDocument
66− Just headElement <- fmap DOM.castToHTMLElement <$> getHead doc
69+ Just headElement <- getHead doc
67 setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
70 setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
68 Just body <- getBody doc
71 Just body <- getBody doc
69 attachWidget body webViewSing w
72 attachWidget body webViewSing w
70
73
71type 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
74type 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
72
75
76+instance MonadJSM m => MonadJSM (PostBuildT t m) where
77+ liftJSM' = PostBuildT . liftJSM'
78+
73{-# INLINABLE attachWidget #-}
79{-# 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
75attachWidget rootElement wv w = fst <$> attachWidget' rootElement wv w
81attachWidget rootElement wv w = fst <$> attachWidget' rootElement wv w
76
82
77{-# INLINABLE attachWidget' #-}
83{-# 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))
79attachWidget' rootElement wv w = do
85attachWidget' rootElement wv w = do
86+ ctx <- askJSM
80 Just doc <- getOwnerDocument rootElement
87 Just doc <- getOwnerDocument rootElement
81 Just df <- createDocumentFragment doc
88 Just df <- createDocumentFragment doc
82− events <- newChan
89+ events <- liftIO $ newChan
83− (result, fc@(FireCommand fire)) <- runSpiderHost $ do
90+ (result, fc@(FireCommand fire)) <- liftIO $ runSpiderHost $ do
84 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
91 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
85 let builderEnv = ImmediateDomBuilderEnv
92 let builderEnv = ImmediateDomBuilderEnv
86 { _immediateDomBuilderEnv_document = doc
93 { _immediateDomBuilderEnv_document = doc
@@ -91,14 +98,14 @@ attachWidget' rootElement wv w = do
91 mPostBuildTrigger <- readRef postBuildTriggerRef
98 mPostBuildTrigger <- readRef postBuildTriggerRef
92 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
99 forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
93 return results
100 return results
94− void $ forkIO $ forever $ do
101+ liftIO $ void $ forkIO $ forever $ do
95 ers <- readChan events
102 ers <- readChan events
96− _ <- postGUISync $ runSpiderHost $ do
103+ _ <- runSpiderHost $ do
97 mes <- liftIO $ forM ers $ \(TriggerRef er :=> TriggerInvocation a _) -> do
104 mes <- liftIO $ forM ers $ \(TriggerRef er :=> TriggerInvocation a _) -> do
98 me <- readIORef er
105 me <- readIORef er
99 return $ fmap (\e -> e :=> Identity a) me
106 return $ fmap (\e -> e :=> Identity a) me
100 _ <- fire (catMaybes mes) $ return ()
107 _ <- fire (catMaybes mes) $ return ()
101− liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> cb
108+ liftIO $ forM_ ers $ \(_ :=> TriggerInvocation _ cb) -> (`runJSM` ctx) cb
102 return ()
109 return ()
103 setInnerHTML rootElement $ Just (""::String)
110 setInnerHTML rootElement $ Just (""::String)
104 _ <- appendChild rootElement $ Just df
111 _ <- appendChild rootElement $ Just df
@@ -106,8 +113,8 @@ attachWidget' rootElement wv w = do
106
113
107-- | Run a reflex-dom application inside of an existing DOM element with the given ID
114-- | Run a reflex-dom application inside of an existing DOM element with the given ID
108mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> IO ()
115mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> IO ()
109−mainWidgetInElementById eid w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
116+mainWidgetInElementById eid w = runWebGUI $ \(webView, ctx) -> withWebViewSingleton (webView, ctx) $ \webViewSing -> (`runJSM` ctx) $ do
110− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
117+ Just doc <- currentDocument
111 Just root <- getElementById doc eid
118 Just root <- getElementById doc eid
112 attachWidget root webViewSing w
119 attachWidget root webViewSing w
113
120
@@ -120,8 +127,8 @@ data AppOutput t = AppOutput --TODO: Add quit event
120 }
127 }
121
128
122runApp' :: (t ~ Spider) => (forall x. AppInput t -> Widget x (AppOutput t)) -> IO ()
129runApp' :: (t ~ Spider) => (forall x. AppInput t -> Widget x (AppOutput t)) -> IO ()
123−runApp' app = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
130+runApp' app = runWebGUI $ \(webView, ctx) -> withWebViewSingleton (webView, ctx) $ \webViewSing -> (`runJSM` ctx) $ do
124− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
131+ Just doc <- currentDocument
125 Just body <- getBody doc
132 Just body <- getBody doc
126 Just win <- getDefaultView doc
133 Just win <- getDefaultView doc
127 rec o <- attachWidget body webViewSing $ do
134 rec o <- attachWidget body webViewSing $ do
src/Reflex/Dom/Old.hs+24−13
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ExplicitForAll #-}
3{-# LANGUAGE ExplicitForAll #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
@@ -8,6 +9,7 @@
8{-# LANGUAGE TemplateHaskell #-}
9{-# LANGUAGE TemplateHaskell #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE UndecidableInstances #-}
11{-# LANGUAGE UndecidableInstances #-}
12+{-# LANGUAGE LambdaCase #-}
11module Reflex.Dom.Old
13module Reflex.Dom.Old
12 ( MonadWidget
14 ( MonadWidget
13 , El
15 , El
@@ -61,8 +63,10 @@ import Foreign.JavaScript.TH
61import qualified GHCJS.DOM.Element as Element
63import qualified GHCJS.DOM.Element as Element
62import GHCJS.DOM.EventM (EventM)
64import GHCJS.DOM.EventM (EventM)
63import GHCJS.DOM.NamedNodeMap as NNM
65import GHCJS.DOM.NamedNodeMap as NNM
64−import GHCJS.DOM.Node (getFirstChild, getNodeName, getParentNode, getPreviousSibling, removeChild, toNode)
66+import GHCJS.DOM.Node (getFirstChild, getNodeName, getParentNode, getPreviousSibling, removeChild)
65−import GHCJS.DOM.Types (IsElement, IsNode)
67+import GHCJS.DOM.Types
68+ (MonadJSM, askJSM, runJSM, strictEqual, liftJSM, JSM, IsElement,
69+ IsNode)
66import qualified GHCJS.DOM.Types as DOM
70import qualified GHCJS.DOM.Types as DOM
67import Reflex.Class
71import Reflex.Class
68import Reflex.Dom.Builder.Class
72import Reflex.Dom.Builder.Class
@@ -92,6 +96,10 @@ type MonadWidgetConstraints t m =
92 , PerformEvent t m
96 , PerformEvent t m
93 , MonadIO m
97 , MonadIO m
94 , MonadIO (Performable m)
98 , MonadIO (Performable m)
99+#ifndef ghcjs_HOST_OS
100+ , MonadJSM m
101+ , MonadJSM (Performable m)
102+#endif
95 , TriggerEvent t m
103 , TriggerEvent t m
96 , HasWebView m
104 , HasWebView m
97 , HasWebView (Performable m)
105 , HasWebView (Performable m)
@@ -154,7 +162,7 @@ buildElementCommon :: MonadWidget t m => Text -> m a -> ElementConfig er t m ->
154buildElementCommon elementTag child cfg = element elementTag cfg child
162buildElementCommon elementTag child cfg = element elementTag cfg child
155
163
156-- | s and e must both be children of the same node and s must precede e
164-- | 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 ()
158deleteBetweenExclusive s e = do
166deleteBetweenExclusive s e = do
159 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
167 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
160 case mCurrentParent of
168 case mCurrentParent of
@@ -162,12 +170,14 @@ deleteBetweenExclusive s e = do
162 Just currentParent -> do
170 Just currentParent -> do
163 let go = do
171 let go = do
164 Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
172 Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
165− when (toNode s /= toNode x) $ do
173+ liftJSM (strictEqual s x) >>= \case
174+ True -> return ()
175+ False -> do
166− _ <- removeChild currentParent $ Just x
176+ _ <- removeChild currentParent $ Just x
167− go
177+ go
168 go
178 go
169
179
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 ())
171onEventName = elementOnEventName
181onEventName = elementOnEventName
172
182
173schedulePostBuild :: (PostBuild t m, PerformEvent t m) => WidgetHost m () -> m ()
183schedulePostBuild :: (PostBuild t m, PerformEvent t m) => WidgetHost m () -> m ()
@@ -219,7 +229,7 @@ _el_scrolled = domEvent Scroll
219
229
220wrapElement :: 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)
230wrapElement :: 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)
221wrapElement eh e = do
231wrapElement 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))
223 h (en, GhcjsDomEvent evt) = runReaderT (eh e en) evt
233 h (en, GhcjsDomEvent evt) = runReaderT (eh e en) evt
224 wrapRawElement e $ (def :: RawElementConfig EventResult t m)
234 wrapRawElement e $ (def :: RawElementConfig EventResult t m)
225 { _rawElementConfig_eventSpec = def
235 { _rawElementConfig_eventSpec = def
@@ -232,7 +242,7 @@ unsafePlaceElement e = do
232 placeRawElement e
242 placeRawElement e
233 wrapRawElement e def
243 wrapRawElement e def
234
244
235−namedNodeMapGetNames :: DOM.NamedNodeMap -> IO (Set Text)
245+namedNodeMapGetNames :: DOM.NamedNodeMap -> JSM (Set Text)
236namedNodeMapGetNames self = do
246namedNodeMapGetNames self = do
237 l <- NNM.getLength self
247 l <- NNM.getLength self
238 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
248 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
240 Just n <- NNM.item self i
250 Just n <- NNM.item self i
241 getNodeName n
251 getNodeName n
242
252
243−nodeClear :: IsNode self => self -> IO ()
253+nodeClear :: IsNode self => self -> JSM ()
244nodeClear n = do
254nodeClear n = do
245 mfc <- getFirstChild n
255 mfc <- getFirstChild n
246 case mfc of
256 case mfc of
@@ -251,7 +261,7 @@ nodeClear n = do
251
261
252getQuitWidget :: MonadWidget t m => m (WidgetHost m ())
262getQuitWidget :: MonadWidget t m => m (WidgetHost m ())
253getQuitWidget = return $ do
263getQuitWidget = return $ do
254− WebViewSingleton wv <- askWebView
264+ WebViewSingleton (wv, _) <- askWebView
255 liftIO $ quitWebView wv
265 liftIO $ quitWebView wv
256
266
257elStopPropagationNS :: forall t m en a. (MonadWidget t m) => Maybe Text -> Text -> EventName en -> m a -> m a
267elStopPropagationNS :: 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
263 & elementConfig_eventSpec . ghcjsEventSpec_filters %~ DMap.insert en f
273 & elementConfig_eventSpec . ghcjsEventSpec_filters %~ DMap.insert en f
264 snd <$> element elementTag cfg child
274 snd <$> element elementTag cfg child
265
275
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)
267elDynHtmlAttr' elementTag attrs html = do
277elDynHtmlAttr' elementTag attrs html = do
268 let cfg = def & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs
278 let cfg = def & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs
269 (e, _) <- element elementTag cfg $ return ()
279 (e, _) <- element elementTag cfg $ return ()
270 postBuild <- getPostBuild
280 postBuild <- getPostBuild
281+ ctx <- askJSM
271− performEvent_ $ Element.setInnerHTML (_element_raw e) . Just <$> leftmost [updated html, tag (current html) postBuild]
282+ performEvent_ $ (`runJSM` ctx) . Element.setInnerHTML (_element_raw e) . Just <$> leftmost [updated html, tag (current html) postBuild]
272 return e
283 return e
273
284
274elDynHtml' :: MonadWidget t m => Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)
285elDynHtml' :: 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
82import Reflex.Class as Reflex
82import Reflex.Class as Reflex
83import Reflex.Dom.Builder.Class
83import Reflex.Dom.Builder.Class
84import Reflex.Dom.Class
84import Reflex.Dom.Class
85−import Reflex.Dom.Internal.Foreign ()
86import Reflex.Dynamic
85import Reflex.Dynamic
87import Reflex.PostBuild.Class
86import Reflex.PostBuild.Class
88
87
src/Reflex/Dom/Widget/Input.hs+5−4
@@ -36,7 +36,7 @@ import GHCJS.DOM.EventM (on)
36import qualified GHCJS.DOM.FileList as FileList
36import qualified GHCJS.DOM.FileList as FileList
37import GHCJS.DOM.HTMLInputElement (HTMLInputElement)
37import GHCJS.DOM.HTMLInputElement (HTMLInputElement)
38import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement)
38import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement)
39−import GHCJS.DOM.Types (File)
39+import GHCJS.DOM.Types (MonadJSM, File)
40import Reflex.Class
40import Reflex.Class
41import Reflex.Dynamic
41import Reflex.Dynamic
42import Reflex.Dom.Builder.Class
42import Reflex.Dom.Builder.Class
@@ -285,7 +285,7 @@ checkboxView dAttrs dValue = do
285 let filters :: DMap EventName (GhcjsEventFilter CheckboxViewEventResult)
285 let filters :: DMap EventName (GhcjsEventFilter CheckboxViewEventResult)
286 filters = DMap.singleton Click $ GhcjsEventFilter $ \(GhcjsDomEvent evt) -> do
286 filters = DMap.singleton Click $ GhcjsEventFilter $ \(GhcjsDomEvent evt) -> do
287 Just t <- Event.getTarget evt
287 Just t <- Event.getTarget evt
288− b <- Input.getChecked $ Input.castToHTMLInputElement t
288+ b <- Input.getChecked =<< Input.castToHTMLInputElement t
289 return $ (,) preventDefault $ return $ Just $ CheckboxViewEventResult b
289 return $ (,) preventDefault $ return $ Just $ CheckboxViewEventResult b
290 elementConfig :: ElementConfig CheckboxViewEventResult t m
290 elementConfig :: ElementConfig CheckboxViewEventResult t m
291 elementConfig = (def :: ElementConfig EventResult t m)
291 elementConfig = (def :: ElementConfig EventResult t m)
@@ -297,7 +297,8 @@ checkboxView dAttrs dValue = do
297 Click -> error "impossible"
297 Click -> error "impossible"
298 _ -> do
298 _ -> do
299 Just e <- withIsEvent en $ Event.getTarget evt
299 Just e <- withIsEvent en $ Event.getTarget evt
300+ element <- castToElement e
300− mr <- runReaderT (defaultDomEventHandler (castToElement e) en) evt
301+ mr <- runReaderT (defaultDomEventHandler element en) evt
301 return $ ffor mr $ \(EventResult r) -> CheckboxViewEventResult $ regularToCheckboxViewEventType en r
302 return $ ffor mr $ \(EventResult r) -> CheckboxViewEventResult $ regularToCheckboxViewEventType en r
302 }
303 }
303 }
304 }
@@ -321,7 +322,7 @@ instance Reflex t => Default (FileInputConfig t) where
321 def = FileInputConfig { _fileInputConfig_attributes = constDyn mempty
322 def = FileInputConfig { _fileInputConfig_attributes = constDyn mempty
322 }
323 }
323
324
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)
325 => FileInputConfig t -> m (FileInput (DomBuilderSpace m) t)
326 => FileInputConfig t -> m (FileInput (DomBuilderSpace m) t)
326fileInput config = do
327fileInput config = do
327 let insertType = Map.insert "type" "file"
328 let insertType = Map.insert "type" "file"
src/Reflex/Dom/Widget/Lazy.hs+8−8
@@ -16,7 +16,6 @@ import Reflex.PerformEvent.Class
16import Reflex.PostBuild.Class
16import Reflex.PostBuild.Class
17
17
18import Control.Monad.Fix
18import Control.Monad.Fix
19−import Control.Monad.IO.Class
20import Data.Fixed
19import Data.Fixed
21import Data.Map (Map)
20import Data.Map (Map)
22import qualified Data.Map as Map
21import qualified Data.Map as Map
@@ -24,9 +23,10 @@ import Data.Monoid
24import Data.Text (Text)
23import Data.Text (Text)
25import qualified Data.Text as T
24import qualified Data.Text as T
26import GHCJS.DOM.Element
25import GHCJS.DOM.Element
26+import GHCJS.DOM.Types (MonadJSM)
27
27
28-- |A list view for long lists. Creates a scrollable element and only renders child row elements near the current scroll position.
28-- |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)
30 => Dynamic t Int -- ^ The height of the visible region in pixels
30 => Dynamic t Int -- ^ The height of the visible region in pixels
31 -> Int -- ^ The height of each row in pixels
31 -> Int -- ^ The height of each row in pixels
32 -> Dynamic t Int -- ^ The total number of items
32 -> Dynamic t Int -- ^ The total number of items
@@ -58,8 +58,8 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa
58 let window = zipDynWith (findWindow rowPx) heightPx scrollPosition
58 let window = zipDynWith (findWindow rowPx) heightPx scrollPosition
59 itemsInWindow = zipDynWith (\(_,(idx,num)) is -> Map.fromList $ map (\i -> let ix = indexToKey i in (ix, Map.lookup ix is)) [idx .. idx + num]) window items
59 itemsInWindow = zipDynWith (\(_,(idx,num)) is -> Map.fromList $ map (\i -> let ix = indexToKey i in (ix, Map.lookup ix is)) [idx .. idx + num]) window items
60 postBuild <- getPostBuild
60 postBuild <- getPostBuild
61− performEvent_ $ ffor (leftmost [setI, i0 <$ postBuild]) $ \i -> do
61+ performEvent_ $ ffor (leftmost [setI, i0 <$ postBuild]) $ \i ->
62− liftIO $ setScrollTop (_element_raw container) (i * rowPx)
62+ setScrollTop (_element_raw container) (i * rowPx)
63 let indexAndLength = fmap snd window
63 let indexAndLength = fmap snd window
64 return (indexAndLength, sel)
64 return (indexAndLength, sel)
65 where
65 where
@@ -80,7 +80,7 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa
80 preItems = min startingIndex numItems
80 preItems = min startingIndex numItems
81 in (topPx - preItems * sizeIncrement, (startingIndex - preItems, preItems + numItems * 2))
81 in (topPx - preItems * sizeIncrement, (startingIndex - preItems, preItems + numItems * 2))
82
82
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)
84 => Dynamic t Int -- ^ A 'Dynamic' of the visible region's height in pixels
84 => Dynamic t Int -- ^ A 'Dynamic' of the visible region's height in pixels
85 -> Int -- ^ The fixed height of each row in pixels
85 -> Int -- ^ The fixed height of each row in pixels
86 -> Dynamic t Int -- ^ A 'Dynamic' of the total number of items
86 -> 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
102 , fmap (const (i0 * rowPx)) pb
102 , fmap (const (i0 * rowPx)) pb
103 ]
103 ]
104 let window = zipDynWith (findWindow rowPx) heightPx scrollPosition
104 let window = zipDynWith (findWindow rowPx) heightPx scrollPosition
105− performEvent_ $ ffor (leftmost [setI, i0 <$ pb]) $ \i -> do
105+ performEvent_ $ ffor (leftmost [setI, i0 <$ pb]) $ \i ->
106− liftIO $ setScrollTop (_element_raw viewport) (i * rowPx)
106+ setScrollTop (_element_raw viewport) (i * rowPx)
107 return (uniqDyn window, result)
107 return (uniqDyn window, result)
108 where
108 where
109 toStyleAttr m = "style" =: Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m
109 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
124 in (startingIndex, numItems)
124 in (startingIndex, numItems)
125
125
126virtualListBuffered
126virtualListBuffered
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)
128 => Int
128 => Int
129 -> Dynamic t Int
129 -> Dynamic t Int
130 -> Int
130 -> Int
src/Reflex/Dom/Widget/Resize.hs+8−5
@@ -1,3 +1,4 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
@@ -23,19 +24,20 @@ import Data.Text (Text)
23import qualified Data.Text as T
24import qualified Data.Text as T
24import GHCJS.DOM.Element hiding (reset)
25import GHCJS.DOM.Element hiding (reset)
25import GHCJS.DOM.EventM (on)
26import GHCJS.DOM.EventM (on)
27+import GHCJS.DOM.Types (runJSM, askJSM, MonadJSM)
26
28
27-- | A widget that wraps the given widget in a div and fires an event when resized.
29-- | A widget that wraps the given widget in a div and fires an event when resized.
28-- Adapted from github.com/marcj/css-element-queries
30-- 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)
30resizeDetector = resizeDetectorWithStyle ""
32resizeDetector = resizeDetectorWithStyle ""
31
33
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)
33 => Text -- ^ A css style string. Warning: It should not contain the "position" style attribute.
35 => Text -- ^ A css style string. Warning: It should not contain the "position" style attribute.
34 -> m a -- ^ The embedded widget
36 -> m a -- ^ The embedded widget
35 -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
37 -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
36resizeDetectorWithStyle styleString = resizeDetectorWithAttrs ("style" =: styleString)
38resizeDetectorWithStyle styleString = resizeDetectorWithAttrs ("style" =: styleString)
37
39
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)
39 => Map Text Text -- ^ A map of attributes. Warning: It should not modify the "position" style attribute.
41 => Map Text Text -- ^ A map of attributes. Warning: It should not modify the "position" style attribute.
40 -> m a -- ^ The embedded widget
42 -> m a -- ^ The embedded widget
41 -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
43 -> 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
74 then return Nothing
76 then return Nothing
75 else fmap Just reset
77 else fmap Just reset
76 pb <- getPostBuild
78 pb <- getPostBuild
79+ ctx <- askJSM
77 expandScroll <- wrapDomEvent (_element_raw expand) (`on` scroll) $ return ()
80 expandScroll <- wrapDomEvent (_element_raw expand) (`on` scroll) $ return ()
78 shrinkScroll <- wrapDomEvent (_element_raw shrink) (`on` scroll) $ return ()
81 shrinkScroll <- wrapDomEvent (_element_raw shrink) (`on` scroll) $ return ()
79− size0 <- performEvent $ fmap (const $ liftIO reset) pb
82+ size0 <- performEvent $ fmap (const $ runJSM reset ctx) pb
80− rec resize <- performEventAsync $ fmap (\d cb -> liftIO $ cb =<< resetIfChanged d) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
83+ rec resize <- performEventAsync $ fmap (\d cb -> liftIO $ cb =<< runJSM (resetIfChanged d) ctx) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
81 dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]
84 dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]
82 return (fmapMaybe void resize, w')
85 return (fmapMaybe void resize, w')
src/Reflex/Dom/Xhr.hs+5−3
@@ -62,9 +62,6 @@ where
62import Reflex.Class
62import Reflex.Class
63import Reflex.Dom.Class
63import Reflex.Dom.Class
64import Reflex.PerformEvent.Class
64import Reflex.PerformEvent.Class
65−import Reflex.Dom.Xhr.Exception
66−import Reflex.Dom.Xhr.Foreign
67−import Reflex.Dom.Xhr.ResponseType
68
65
69import Control.Concurrent
66import Control.Concurrent
70import Control.Exception (handle)
67import Control.Exception (handle)
@@ -91,6 +88,11 @@ import qualified Data.Text.Lazy as LT
91import qualified Data.Text.Lazy.Builder as B
88import qualified Data.Text.Lazy.Builder as B
92import Data.Traversable
89import Data.Traversable
93import Data.Typeable
90import 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)
94
96
95data XhrRequest a
97data XhrRequest a
96 = XhrRequest { _xhrRequest_method :: Text
98 = XhrRequest { _xhrRequest_method :: Text