git.iko.soy/jsaddle
on master help sign in
WebKitGTK run packages. Lazy return values.
e10bb6eHamish Mackenzie
cabal.project+2
compare with master
unifiedsplit
@@ -4,6 +4,8 @@ packages:
4 jsaddle/
4 jsaddle/
5 jsaddle-warp/
5 jsaddle-warp/
6 jsaddle-wkwebview/
6 jsaddle-wkwebview/
7+-- jsaddle-webkitgtk/
8+ jsaddle-webkit2gtk/
7
9
8package gi-atk
10package gi-atk
9 flags: -overloaded-methods -overloaded-signals -overloaded-properties
11 flags: -overloaded-methods -overloaded-signals -overloaded-properties
jsaddle-warp/jsaddle-warp.cabal+1−1
@@ -1,5 +1,5 @@
1name: jsaddle-warp
1name: jsaddle-warp
2−version: 0.7.0.0
2+version: 0.7.1.0
3cabal-version: >=1.10
3cabal-version: >=1.10
4build-type: Simple
4build-type: Simple
5license: MIT
5license: MIT
jsaddle-webkit2gtk/LICENSEnew file+21
@@ -0,0 +1,21 @@
1+Copyright (c) 2010-2012 Hamish Mackenzie, Victor Nazarov, Luite Stegeman
2+
3+Permission is hereby granted, free of charge, to any person obtaining
4+a copy of this software and associated documentation files (the
5+"Software"), to deal in the Software without restriction, including
6+without limitation the rights to use, copy, modify, merge, publish,
7+distribute, sublicense, and/or sell copies of the Software, and to
8+permit persons to whom the Software is furnished to do so, subject to
9+the following conditions:
10+
11+The above copyright notice and this permission notice shall be
12+included in all copies or substantial portions of the Software.
13+
14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
17+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
18+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
19+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
20+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21+
jsaddle-webkit2gtk/Setup.lhsnew file+6
@@ -0,0 +1,6 @@
1+#!/usr/bin/runhaskell
2+> module Main where
3+> import Distribution.Simple
4+> main :: IO ()
5+> main = defaultMain
6+
jsaddle-webkit2gtk/jsaddle-webkit2gtk.cabalnew file+42
@@ -0,0 +1,42 @@
1+name: jsaddle-webkit2gtk
2+version: 0.7.1.0
3+cabal-version: >=1.10
4+build-type: Simple
5+license: MIT
6+license-file: LICENSE
7+maintainer: Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
8+synopsis: Interface for JavaScript that works with GHCJS and GHC
9+description:
10+ This package provides an EDSL for calling JavaScript that
11+ can be used both from GHCJS and GHC. When using GHC
12+ the application is run using Warp and WebSockets to
13+ drive a small JavaScipt helper.
14+category: Web, Javascript
15+author: Hamish Mackenzie
16+
17+source-repository head
18+ type: git
19+ location: https://github.com/ghcjs/jsaddle
20+
21+library
22+ exposed-modules:
23+ Language.Javascript.JSaddle.WebKit2GTK
24+ build-depends:
25+ aeson >=0.8.0.2 && <1.1,
26+ base <5,
27+ bytestring >=0.10.6.0 && <0.11,
28+ directory >=1.0.0.2 && <1.3,
29+ gi-glib >=2.0.6 && <2.1,
30+ gi-gio >=2.0.6 && <2.1,
31+ gi-gtk >=3.0.6 && <3.1,
32+ gi-webkit2 >=4.0.6 && <4.1,
33+ gi-javascriptcore >=4.0.6 && <4.1,
34+ haskell-gi-base >=0.20 && <0.21,
35+ jsaddle >=0.7.0.0 && <0.8,
36+ text >=1.2.1.3 && <1.3,
37+ unix >=2.3.1.0 && <2.8,
38+ webkit2gtk3-javascriptcore >=0.14.0.0 && <0.15
39+ default-language: Haskell2010
40+ hs-source-dirs: src
41+ ghc-options: -ferror-spans -Wall
42+
jsaddle-webkit2gtk/src/Language/Javascript/JSaddle/WebKit2GTK.hsnew file+176
@@ -0,0 +1,176 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE PatternSynonyms #-}
4+{-# LANGUAGE LambdaCase #-}
5+-----------------------------------------------------------------------------
6+--
7+-- Module : Language.Javascript.JSaddle.WebSockets
8+-- Copyright : (c) Hamish Mackenzie
9+-- License : MIT
10+--
11+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
12+--
13+-- |
14+--
15+-----------------------------------------------------------------------------
16+module Language.Javascript.JSaddle.WebKit2GTK (
17+ -- * Running JSM in a WebView
18+ run
19+ , runInWebView
20+ ) where
21+
22+import Control.Monad (void)
23+import Control.Monad.IO.Class (MonadIO(..), MonadIO)
24+import Control.Concurrent (forkIO, yield)
25+
26+import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch))
27+import System.Directory (getCurrentDirectory)
28+
29+import Data.Monoid ((<>))
30+import Data.ByteString.Lazy (toStrict, fromStrict)
31+import qualified Data.ByteString.Lazy as LB (ByteString)
32+import Data.Aeson (encode, decode)
33+import Data.Text (Text)
34+import qualified Data.Text as T (pack)
35+import Data.Text.Foreign (fromPtr)
36+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
37+
38+import Foreign.Ptr (castPtr, nullPtr)
39+
40+import Data.GI.Base.BasicTypes (GObject)
41+import Data.GI.Base.Signals
42+ (connectSignalFunPtr, SignalConnectMode(..), SignalConnectMode,
43+ SignalHandlerId)
44+import Data.GI.Base.ManagedPtr (withManagedPtr)
45+
46+import GI.GLib (timeoutAdd, idleAdd, pattern PRIORITY_HIGH, pattern PRIORITY_DEFAULT)
47+import qualified GI.Gtk as Gtk (main, init)
48+import GI.Gtk
49+ (windowSetPosition, windowSetDefaultSize, windowNew,
50+ scrolledWindowNew, noAdjustment, containerAdd,
51+ WindowType(..), WindowPosition(..), widgetDestroy,
52+ widgetGetToplevel, widgetShowAll, onWidgetDestroy,
53+ mainQuit)
54+import GI.Gio (noCancellable)
55+import GI.JavaScriptCore (Value(..), GlobalContext(..))
56+import GI.WebKit2
57+ (WebView, setSettingsEnableWriteConsoleMessagesToStdout,
58+ setSettingsEnableJavascript,
59+ webViewNewWithUserContentManager, userContentManagerNew,
60+ userContentManagerRegisterScriptMessageHandler,
61+ javascriptResultGetValue, javascriptResultGetGlobalContext,
62+ webViewGetUserContentManager,
63+ mk_UserContentManagerScriptMessageReceivedCallback,
64+ wrap_UserContentManagerScriptMessageReceivedCallback,
65+ webViewRunJavascript, LoadEvent(..),
66+ UserContentManagerScriptMessageReceivedCallback, webViewLoadHtml,
67+ onWebViewLoadChanged, setSettingsEnableDeveloperExtras,
68+ webViewSetSettings, webViewGetSettings)
69+
70+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
71+ (JSValueRef, JSContextRef)
72+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
73+ (jsstringgetcharactersptr, jsstringgetlength, jsstringrelease)
74+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
75+ (jsvaluetostringcopy)
76+
77+import Language.Javascript.JSaddle (JSM, Results)
78+import Language.Javascript.JSaddle.Run (runJavaScript)
79+import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
80+
81+quitWebView :: WebView -> IO ()
82+quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't this be postGUISync?
83+ widgetDestroy w
84+
85+installQuitHandler :: WebView -> IO ()
86+installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing
87+
88+postGUIAsync :: IO () -> IO ()
89+postGUIAsync action =
90+ void . idleAdd PRIORITY_DEFAULT $ action >> return False
91+
92+withJSContextRef :: GlobalContext -> (JSContextRef -> IO a) -> IO a
93+withJSContextRef (GlobalContext ctx) f = withManagedPtr ctx (f . castPtr)
94+
95+withJSValueRef :: Value -> (JSValueRef -> IO a) -> IO a
96+withJSValueRef (Value ptr) f = withManagedPtr ptr (f . castPtr)
97+
98+valueToText :: JSContextRef -> JSValueRef -> IO Text
99+valueToText ctxRef s = do
100+ jsstring <- jsvaluetostringcopy ctxRef s nullPtr
101+ l <- jsstringgetlength jsstring
102+ p <- jsstringgetcharactersptr jsstring
103+ result <- fromPtr (castPtr p) (fromIntegral l)
104+ jsstringrelease jsstring
105+ return result
106+
107+run :: JSM () -> IO ()
108+run main = do
109+ _ <- Gtk.init Nothing
110+ window <- windowNew WindowTypeToplevel
111+ _ <- timeoutAdd PRIORITY_HIGH 10 (yield >> return True)
112+ windowSetDefaultSize window 900 600
113+ windowSetPosition window WindowPositionCenter
114+ scrollWin <- scrolledWindowNew noAdjustment noAdjustment
115+ contentManager <- userContentManagerNew
116+ webView <- webViewNewWithUserContentManager contentManager
117+ settings <- webViewGetSettings webView
118+ -- setSettingsEnableUniversalAccessFromFileUris settings True
119+ setSettingsEnableDeveloperExtras settings True
120+ setSettingsEnableJavascript settings True
121+ setSettingsEnableWriteConsoleMessagesToStdout settings True
122+ webViewSetSettings webView settings
123+ window `containerAdd` scrollWin
124+ scrollWin `containerAdd` webView
125+ _ <- onWidgetDestroy window mainQuit
126+ widgetShowAll window
127+ pwd <- getCurrentDirectory
128+ void . onWebViewLoadChanged webView $ \case
129+ LoadEventFinished -> runInWebView main webView
130+ _ -> return ()
131+ webViewLoadHtml webView "" . Just $ "file://" <> T.pack pwd <> "/"
132+ installQuitHandler webView
133+ Gtk.main
134+
135+runInWebView :: JSM () -> WebView -> IO ()
136+runInWebView f webView = do
137+ (processResults, start) <- runJavaScript (\batch -> postGUIAsync $
138+ webViewRunJavascript webView (decodeUtf8 . toStrict $ "runJSaddleBatch(" <> encode batch <> ");") noCancellable Nothing)
139+ f
140+
141+ addJSaddleHandler webView processResults
142+ webViewRunJavascript webView (decodeUtf8 $ toStrict jsaddleJs) noCancellable . Just $
143+ \_obj _asyncResult ->
144+ void $ forkIO start
145+
146+onUserContentManagerScriptMessageReceived :: (GObject a, MonadIO m) => a -> UserContentManagerScriptMessageReceivedCallback -> m SignalHandlerId
147+onUserContentManagerScriptMessageReceived obj cb = liftIO $ connectUserContentManagerScriptMessageReceived obj cb SignalConnectBefore
148+
149+connectUserContentManagerScriptMessageReceived :: (GObject a, MonadIO m) =>
150+ a -> UserContentManagerScriptMessageReceivedCallback -> SignalConnectMode -> m SignalHandlerId
151+connectUserContentManagerScriptMessageReceived obj cb after = liftIO $ do
152+ let cb' = wrap_UserContentManagerScriptMessageReceivedCallback cb
153+ cb'' <- mk_UserContentManagerScriptMessageReceivedCallback cb'
154+ connectSignalFunPtr obj "script-message-received::jsaddle" cb'' after
155+
156+addJSaddleHandler :: WebView -> (Results -> IO ()) -> IO ()
157+addJSaddleHandler webView processResult = do
158+ manager <- webViewGetUserContentManager webView
159+ _ <- onUserContentManagerScriptMessageReceived manager $ \result -> do
160+ ctx <- javascriptResultGetGlobalContext result
161+ arg <- javascriptResultGetValue result
162+ bs <- withJSContextRef ctx $ \ctxRef ->
163+ withJSValueRef arg $ \argRef ->
164+ encodeUtf8 <$> valueToText ctxRef argRef
165+ mapM_ processResult (decode (fromStrict bs))
166+ void $ userContentManagerRegisterScriptMessageHandler manager "jsaddle"
167+
168+jsaddleJs :: LB.ByteString
169+jsaddleJs = ghcjsHelpers <> "\
170+ \runJSaddleBatch = (function() {\n\
171+ \ " <> initState <> "\n\
172+ \ return function(batch) {\n\
173+ \ " <> runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));") <> "\
174+ \ };\n\
175+ \})()\n\
176+ \"
jsaddle-webkitgtk/LICENSEnew file+21
@@ -0,0 +1,21 @@
1+Copyright (c) 2010-2012 Hamish Mackenzie, Victor Nazarov, Luite Stegeman
2+
3+Permission is hereby granted, free of charge, to any person obtaining
4+a copy of this software and associated documentation files (the
5+"Software"), to deal in the Software without restriction, including
6+without limitation the rights to use, copy, modify, merge, publish,
7+distribute, sublicense, and/or sell copies of the Software, and to
8+permit persons to whom the Software is furnished to do so, subject to
9+the following conditions:
10+
11+The above copyright notice and this permission notice shall be
12+included in all copies or substantial portions of the Software.
13+
14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
17+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
18+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
19+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
20+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21+
jsaddle-webkitgtk/Setup.lhsnew file+6
@@ -0,0 +1,6 @@
1+#!/usr/bin/runhaskell
2+> module Main where
3+> import Distribution.Simple
4+> main :: IO ()
5+> main = defaultMain
6+
jsaddle-webkitgtk/jsaddle-webkitgtk.cabalnew file+41
@@ -0,0 +1,41 @@
1+name: jsaddle-webkitgtk
2+version: 0.7.1.0
3+cabal-version: >=1.10
4+build-type: Simple
5+license: MIT
6+license-file: LICENSE
7+maintainer: Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
8+synopsis: Interface for JavaScript that works with GHCJS and GHC
9+description:
10+ This package provides an EDSL for calling JavaScript that
11+ can be used both from GHCJS and GHC. When using GHC
12+ the application is run using Warp and WebSockets to
13+ drive a small JavaScipt helper.
14+category: Web, Javascript
15+author: Hamish Mackenzie
16+
17+source-repository head
18+ type: git
19+ location: https://github.com/ghcjs/jsaddle
20+
21+library
22+ exposed-modules:
23+ Language.Javascript.JSaddle.WebKitGTK
24+ build-depends:
25+ aeson >=0.8.0.2 && <1.1,
26+ base <5,
27+ bytestring >=0.10.6.0 && <0.11,
28+ directory >=1.0.0.2 && <1.3,
29+ gi-glib >=2.0.6 && <2.1,
30+ gi-gtk >=3.0.6 && <3.1,
31+ gi-webkit >=3.0.6 && <3.1,
32+ gi-javascriptcore >=3.0.6 && <3.1,
33+ haskell-gi-base >=0.20 && <0.21,
34+ jsaddle >=0.7.0.0 && <0.8,
35+ text >=1.2.1.3 && <1.3,
36+ unix >=2.3.1.0 && <2.8,
37+ webkitgtk3-javascriptcore >=0.14.0.0 && <0.15
38+ default-language: Haskell2010
39+ hs-source-dirs: src
40+ ghc-options: -ferror-spans -Wall
41+
jsaddle-webkitgtk/src/Language/Javascript/JSaddle/WebKitGTK.hsnew file+211
@@ -0,0 +1,211 @@
1+{-# LANGUAGE ScopedTypeVariables #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE PatternSynonyms #-}
4+{-# LANGUAGE LambdaCase #-}
5+-----------------------------------------------------------------------------
6+--
7+-- Module : Language.Javascript.JSaddle.WebSockets
8+-- Copyright : (c) Hamish Mackenzie
9+-- License : MIT
10+--
11+-- Maintainer : Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
12+--
13+-- |
14+--
15+-----------------------------------------------------------------------------
16+module Language.Javascript.JSaddle.WebKitGTK (
17+ -- * Running JSM in a WebView
18+ run
19+ , runInWebView
20+ ) where
21+
22+import Control.Monad (when, void)
23+import qualified Control.Exception as E (catch)
24+import Control.Exception (SomeException(..))
25+import Control.Concurrent (forkIO, yield)
26+
27+import System.Posix.Signals (installHandler)
28+import System.Directory (getCurrentDirectory)
29+
30+import Data.Monoid ((<>))
31+import Data.ByteString.Lazy (toStrict, fromStrict)
32+import qualified Data.ByteString.Lazy as LB (ByteString)
33+import Data.Aeson (encode, decode)
34+import Data.Text (Text)
35+import qualified Data.Text as T (unpack, pack)
36+import Data.Text.Foreign (useAsPtr, fromPtr)
37+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
38+
39+import Foreign.Ptr (castPtr, nullPtr)
40+import Foreign.Marshal.Array (withArray, peekArray)
41+import Foreign.Storable (Storable(..))
42+import Foreign.Marshal.Alloc (alloca)
43+
44+import Data.GI.Base.ManagedPtr (withManagedPtr)
45+import GI.GLib
46+ (timeoutAdd, idleAdd, pattern PRIORITY_HIGH, pattern PRIORITY_DEFAULT)
47+import qualified GI.Gtk as Gtk (main, init)
48+import GI.Gtk
49+ (windowSetPosition, windowSetDefaultSize, windowNew, scrolledWindowNew,
50+ noAdjustment, containerAdd, WindowType(..), WindowPosition(..),
51+ widgetDestroy, widgetGetToplevel, widgetShowAll, onWidgetDestroy,
52+ mainQuit)
53+import GI.JavaScriptCore.Structs.GlobalContext (GlobalContext(..))
54+import GI.WebKit
55+ (WebView, webViewGetMainFrame, webFrameGetGlobalContext,
56+ onWebInspectorInspectWebView, webViewGetInspector, webViewSetSettings,
57+ setWebSettingsEnableDeveloperExtras,
58+ setWebSettingsEnableUniversalAccessFromFileUris,
59+ webViewGetSettings, webViewNew, onWebViewLoadFinished,
60+ webViewLoadString)
61+
62+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
63+ (JSValueRef, JSValueRefRef, JSObjectRef, JSContextRef,
64+ jsevaluatescript, JSStringRef)
65+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
66+ (jsstringretain, jsstringrelease, jsstringgetcharactersptr,
67+ jsstringgetlength, jsstringcreatewithcharacters)
68+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
69+ (jsobjectcallasfunction, JSCSize, jsobjectsetproperty,
70+ jsobjectmakefunctionwithcallback, mkJSObjectCallAsFunctionCallback)
71+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSContextRef
72+ (jscontextgetglobalobject)
73+import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
74+ (jsvalueprotect, jsvalueunprotect,
75+ jsvaluetostringcopy, jsvaluemakestring, jsvaluemakeundefined)
76+
77+import Language.Javascript.JSaddle (JSM, Results)
78+import Language.Javascript.JSaddle.Run (runJavaScript)
79+import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
80+
81+quitWebView :: WebView -> IO ()
82+quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't this be postGUISync?
83+ widgetDestroy w
84+
85+installQuitHandler :: WebView -> IO ()
86+installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing
87+
88+postGUIAsync :: IO () -> IO ()
89+postGUIAsync action =
90+ void . idleAdd PRIORITY_DEFAULT $ action >> return False
91+
92+withJSString :: Text -> (JSStringRef -> IO a) -> IO a
93+withJSString s f = do
94+ jsstring <- useAsPtr s $ \p l -> jsstringcreatewithcharacters (castPtr p) (fromIntegral l)
95+ _ <- jsstringretain jsstring
96+ result <- f jsstring
97+ jsstringrelease jsstring
98+ return result
99+
100+withJSContextRef :: GlobalContext -> (JSContextRef -> IO a) -> IO a
101+withJSContextRef (GlobalContext ctx) f = withManagedPtr ctx (f . castPtr)
102+
103+valueToText :: JSContextRef -> JSValueRef -> IO Text
104+valueToText ctxRef s = do
105+ jsstring <- jsvaluetostringcopy ctxRef s nullPtr
106+ l <- jsstringgetlength jsstring
107+ p <- jsstringgetcharactersptr jsstring
108+ result <- fromPtr (castPtr p) (fromIntegral l)
109+ jsstringrelease jsstring
110+ return result
111+
112+check :: JSContextRef -> (JSValueRefRef -> IO a) -> IO a
113+check ctxRef f =
114+ alloca $ \exceptionPtr -> do
115+ poke exceptionPtr nullPtr
116+ result <- f exceptionPtr
117+ exception <- peek exceptionPtr
118+ when (exception /= nullPtr) $ do
119+ errorText <- valueToText ctxRef exception
120+ error $ T.unpack errorText
121+ return result
122+
123+eval :: JSContextRef -> Text -> IO JSValueRef
124+eval ctxRef script =
125+ withJSString script $ \script' ->
126+ check ctxRef $ jsevaluatescript ctxRef script' nullPtr nullPtr 0
127+
128+run :: JSM () -> IO ()
129+run main = do
130+ _ <- Gtk.init Nothing
131+ window <- windowNew WindowTypeToplevel
132+ _ <- timeoutAdd PRIORITY_HIGH 10 (yield >> return True)
133+ windowSetDefaultSize window 900 600
134+ windowSetPosition window WindowPositionCenter
135+ scrollWin <- scrolledWindowNew noAdjustment noAdjustment
136+ webView <- webViewNew
137+ settings <- webViewGetSettings webView
138+ setWebSettingsEnableUniversalAccessFromFileUris settings True
139+ setWebSettingsEnableDeveloperExtras settings True
140+ webViewSetSettings webView settings
141+ window `containerAdd` scrollWin
142+ scrollWin `containerAdd` webView
143+ _ <- onWidgetDestroy window mainQuit
144+ widgetShowAll window
145+ inspector <- webViewGetInspector webView
146+ _ <- onWebInspectorInspectWebView inspector $ \_ -> do
147+ inspectorWindow <- windowNew WindowTypeToplevel
148+ windowSetDefaultSize inspectorWindow 900 600
149+ inspectorScrollWin <- scrolledWindowNew noAdjustment noAdjustment
150+ inspectorWebView <- webViewNew
151+ inspectorWindow `containerAdd` inspectorScrollWin
152+ inspectorScrollWin `containerAdd` inspectorWebView
153+ widgetShowAll inspectorWindow
154+ return inspectorWebView
155+ pwd <- getCurrentDirectory
156+ void . onWebViewLoadFinished webView $ \ _ ->
157+ runInWebView main webView
158+ webViewLoadString webView "" "text/html" "UTF-8" $ "file://" <> T.pack pwd <> "/"
159+ installQuitHandler webView
160+ Gtk.main
161+
162+runInWebView :: JSM () -> WebView -> IO ()
163+runInWebView f webView = do
164+ ctx <- webViewGetMainFrame webView >>= webFrameGetGlobalContext
165+ runJSaddleBatch <-
166+ withJSContextRef ctx $ \ctxRef -> do
167+ result <- eval ctxRef (decodeUtf8 $ toStrict jsaddleJs)
168+ jsvalueprotect ctxRef result
169+ return result
170+
171+ (processResults, start) <- runJavaScript (\batch -> postGUIAsync $
172+ withJSContextRef ctx $ \ctxRef ->
173+ withJSString (decodeUtf8 . toStrict $ encode batch) $ \script -> do
174+ val <- jsvaluemakestring ctxRef script
175+ withArray [val] $ \args ->
176+ void . check ctxRef $ jsobjectcallasfunction ctxRef runJSaddleBatch nullPtr 1 args
177+ jsvalueunprotect ctxRef val)
178+ f
179+
180+ withJSContextRef ctx $ \ctxRef -> do
181+ addJSaddleHandler ctxRef processResults
182+ void $ forkIO start
183+
184+addJSaddleHandler :: JSContextRef -> (Results -> IO ()) -> IO ()
185+addJSaddleHandler ctxRef processResult = do
186+ callback <- mkJSObjectCallAsFunctionCallback wrap
187+ function <- jsobjectmakefunctionwithcallback ctxRef nullPtr callback
188+ global <- jscontextgetglobalobject ctxRef
189+ withJSString "jsaddleCallback" $ \propName ->
190+ jsobjectsetproperty ctxRef global propName function 0 nullPtr
191+ where
192+ wrap :: JSContextRef -> JSObjectRef -> JSObjectRef -> JSCSize -> JSValueRefRef -> JSValueRefRef -> IO JSValueRef
193+ wrap _ctx _fobj _this argc argv exception = do
194+ [arg] <- peekArray (fromIntegral argc) argv
195+ bs <- encodeUtf8 <$> valueToText ctxRef arg
196+ mapM_ processResult (decode (fromStrict bs))
197+ jsvaluemakeundefined ctxRef
198+ `E.catch` \(e :: SomeException) -> do
199+ withJSString (T.pack (show e)) (jsvaluemakestring ctxRef) >>= poke exception
200+ jsvaluemakeundefined ctxRef
201+
202+jsaddleJs :: LB.ByteString
203+jsaddleJs = ghcjsHelpers <> "\
204+ \(function() {\n\
205+ \ " <> initState <> "\n\
206+ \ return function(batchJSON) {\n\
207+ \ var batch = JSON.parse(batchJSON);\n\
208+ \ " <> runBatch (\a -> "window.jsaddleCallback(JSON.stringify(" <> a <> "));") <> "\
209+ \ };\n\
210+ \})()\n\
211+ \"
jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView.hs+1−2
@@ -17,6 +17,7 @@ import Foreign.Ptr (Ptr)
17import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr)
17import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr)
18
18
19import Language.Javascript.JSaddle (Result, JSM)
19import Language.Javascript.JSaddle (Result, JSM)
20+import Language.Javascript.JSaddle.Types (Batch(..))
20import Language.Javascript.JSaddle.Run (runJavaScript)
21import Language.Javascript.JSaddle.Run (runJavaScript)
21import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
22import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
22
23
@@ -73,5 +74,3 @@ indexHtml =
73 \<body>\n\
74 \<body>\n\
74 \</body>\n\
75 \</body>\n\
75 \</html>"
76 \</html>"
76−
77−-- jsaddle
jsaddle/jsaddle.cabal+1−2
@@ -1,5 +1,5 @@
1name: jsaddle
1name: jsaddle
2−version: 0.7.0.0
2+version: 0.7.1.0
3cabal-version: >=1.10
3cabal-version: >=1.10
4build-type: Simple
4build-type: Simple
5license: MIT
5license: MIT
@@ -72,7 +72,6 @@ library
72 bytestring >=0.10.6.0 && <0.11,
72 bytestring >=0.10.6.0 && <0.11,
73 lens >=3.8.5 && <4.16,
73 lens >=3.8.5 && <4.16,
74 primitive >=0.6.1.0 && <0.7,
74 primitive >=0.6.1.0 && <0.7,
75− template-haskell -any,
76 text >=1.2.1.3 && <1.3,
75 text >=1.2.1.3 && <1.3,
77 transformers >=0.4.2.0 && <0.6
76 transformers >=0.4.2.0 && <0.6
78 default-language: Haskell2010
77 default-language: Haskell2010
jsaddle/src-ghc/GHCJS/Marshal.hs+1−1
@@ -99,7 +99,7 @@ instance FromJSVal Double where
99instance FromJSVal AE.Value where
99instance FromJSVal AE.Value where
100 fromJSVal r =
100 fromJSVal r =
101 withToJSVal r $ \rval -> do
101 withToJSVal r $ \rval -> do
102− ValueToJSONValueResult result <- sendCommand (ValueToJSONValue rval)
102+ ~(ValueToJSONValueResult result) <- sendCommand (ValueToJSONValue rval)
103 return $ Just result
103 return $ Just result
104 {-# INLINE fromJSVal #-}
104 {-# INLINE fromJSVal #-}
105instance (FromJSVal a, FromJSVal b) => FromJSVal (a,b) where
105instance (FromJSVal a, FromJSVal b) => FromJSVal (a,b) where
jsaddle/src-ghc/JavaScript/Array/Internal.hs+1−1
@@ -28,7 +28,7 @@ toListIO (SomeJSArray x) =
28 withObject (Object x) $ \this -> do
28 withObject (Object x) $ \this -> do
29 l <- withJSString (JSString "length") $ sendLazyCommand . GetPropertyByName this
29 l <- withJSString (JSString "length") $ sendLazyCommand . GetPropertyByName this
30 withJSVal l $ \l' -> do
30 withJSVal l $ \l' -> do
31− ValueToNumberResult len <- sendCommand (ValueToNumber l')
31+ ~(ValueToNumberResult len) <- sendCommand (ValueToNumber l')
32 mapM (sendLazyCommand . GetPropertyAtIndex this) [0..round len - 1]
32 mapM (sendLazyCommand . GetPropertyAtIndex this) [0..round len - 1]
33{-# INLINE toListIO #-}
33{-# INLINE toListIO #-}
34
34
jsaddle/src-ghc/JavaScript/Object/Internal.hs+1−1
@@ -22,7 +22,7 @@ create = Object <$> sendLazyCommand NewEmptyObject
22listProps :: Object -> JSM [JSString]
22listProps :: Object -> JSM [JSString]
23listProps this =
23listProps this =
24 withObject this $ \rthis -> do
24 withObject this $ \rthis -> do
25− PropertyNamesResult result <- sendCommand $ PropertyNames rthis
25+ ~(PropertyNamesResult result) <- sendCommand $ PropertyNames rthis
26 mapM wrapJSString result
26 mapM wrapJSString result
27{-# INLINE listProps #-}
27{-# INLINE listProps #-}
28
28
jsaddle/src/Language/Javascript/JSaddle/Foreign.hs+3−3
@@ -70,7 +70,7 @@ isTruthyIO (JSVal 1) = return False -- undefined
70isTruthyIO (JSVal 2) = return False -- false
70isTruthyIO (JSVal 2) = return False -- false
71isTruthyIO (JSVal 3) = return True -- true
71isTruthyIO (JSVal 3) = return True -- true
72isTruthyIO v = withJSVal v $ \rval -> do
72isTruthyIO v = withJSVal v $ \rval -> do
73− ValueToBoolResult result <- sendCommand (ValueToBool rval)
73+ ~(ValueToBoolResult result) <- sendCommand (ValueToBool rval)
74 return result
74 return result
75#endif
75#endif
76{-# INLINE isTruthyIO #-}
76{-# INLINE isTruthyIO #-}
@@ -81,7 +81,7 @@ isNullIO = return . isNull
81#else
81#else
82isNullIO (JSVal 0) = return True
82isNullIO (JSVal 0) = return True
83isNullIO v = withJSVal v $ \rval -> do
83isNullIO v = withJSVal v $ \rval -> do
84− IsNullResult result <- sendCommand $ IsNull rval
84+ ~(IsNullResult result) <- sendCommand $ IsNull rval
85 return result
85 return result
86#endif
86#endif
87{-# INLINE isNullIO #-}
87{-# INLINE isNullIO #-}
@@ -92,7 +92,7 @@ isUndefinedIO = return . isUndefined
92#else
92#else
93isUndefinedIO (JSVal 1) = return True
93isUndefinedIO (JSVal 1) = return True
94isUndefinedIO v = withJSVal v $ \rval -> do
94isUndefinedIO v = withJSVal v $ \rval -> do
95− IsUndefinedResult result <- sendCommand $ IsUndefined rval
95+ ~(IsUndefinedResult result) <- sendCommand $ IsUndefined rval
96 return result
96 return result
97#endif
97#endif
98{-# INLINE isUndefinedIO #-}
98{-# INLINE isUndefinedIO #-}
jsaddle/src/Language/Javascript/JSaddle/Object.hs−1
@@ -113,7 +113,6 @@ import Language.Javascript.JSaddle.Types
113 (JSString, Object(..),
113 (JSString, Object(..),
114 JSVal(..), JSCallAsFunction)
114 JSVal(..), JSCallAsFunction)
115#else
115#else
116−import Data.Text (Text)
117import GHCJS.Marshal.Internal (ToJSVal(..))
116import GHCJS.Marshal.Internal (ToJSVal(..))
118import Language.Javascript.JSaddle.Native
117import Language.Javascript.JSaddle.Native
119 (withJSVals, withObject)
118 (withJSVals, withObject)
jsaddle/src/Language/Javascript/JSaddle/Run.hs+44−39
@@ -37,10 +37,10 @@ import qualified JavaScript.Web.AnimationFrame as GHCJS
37 (waitForAnimationFrame)
37 (waitForAnimationFrame)
38#else
38#else
39import Control.Exception (throwIO)
39import Control.Exception (throwIO)
40−import Control.Monad (void, forever)
40+import Control.Monad (void, forever, zipWithM_)
41import Control.Monad.IO.Class (MonadIO(..))
41import Control.Monad.IO.Class (MonadIO(..))
42import Control.Monad.Trans.Reader (ask, runReaderT)
42import Control.Monad.Trans.Reader (ask, runReaderT)
43−import Control.Monad.STM (STM, atomically)
43+import Control.Monad.STM (atomically)
44import Control.Concurrent (forkIO)
44import Control.Concurrent (forkIO)
45import Control.Concurrent.STM.TChan
45import Control.Concurrent.STM.TChan
46 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
46 (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
@@ -49,16 +49,19 @@ import Control.Concurrent.STM.TVar
49import Control.Concurrent.MVar
49import Control.Concurrent.MVar
50 (MVar, MVar, putMVar, takeMVar, newEmptyMVar)
50 (MVar, MVar, putMVar, takeMVar, newEmptyMVar)
51
51
52+import System.IO.Unsafe (unsafeInterleaveIO)
53+
52import Data.Monoid ((<>))
54import Data.Monoid ((<>))
53import qualified Data.Text as T (unpack)
55import qualified Data.Text as T (unpack)
54import qualified Data.Map as M (lookup, delete, insert, empty)
56import qualified Data.Map as M (lookup, delete, insert, empty)
55import Data.Time.Clock (getCurrentTime,diffUTCTime)
57import Data.Time.Clock (getCurrentTime,diffUTCTime)
56
58
57import Language.Javascript.JSaddle.Types
59import Language.Javascript.JSaddle.Types
58− (Command(..), AsyncCommand(..), Result(..), JSContextRef(..), JSVal(..),
60+ (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
59 Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
61 Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
60import Language.Javascript.JSaddle.Exception (JSException(..))
62import Language.Javascript.JSaddle.Exception (JSException(..))
61import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
63import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
64+import Control.DeepSeq (deepseq)
62#endif
65#endif
63
66
64-- | Forces execution of pending asyncronous code
67-- | Forces execution of pending asyncronous code
@@ -66,7 +69,9 @@ syncPoint :: JSM ()
66#ifdef ghcjs_HOST_OS
69#ifdef ghcjs_HOST_OS
67syncPoint = return ()
70syncPoint = return ()
68#else
71#else
72+syncPoint = do
69−syncPoint = void $ sendCommand Sync
73+ SyncResult <- sendCommand Sync
74+ return ()
70#endif
75#endif
71
76
72-- | Forces execution of pending asyncronous code after performing `f`
77-- | Forces execution of pending asyncronous code after performing `f`
@@ -126,7 +131,7 @@ sendAsyncCommand cmd = do
126 s <- doSendAsyncCommand <$> JSM ask
131 s <- doSendAsyncCommand <$> JSM ask
127 liftIO $ s cmd
132 liftIO $ s cmd
128
133
129−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Result -> IO (), IO ())
134+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())
130runJavaScript sendBatch entryPoint = do
135runJavaScript sendBatch entryPoint = do
131 startTime' <- getCurrentTime
136 startTime' <- getCurrentTime
132 recvChan <- newTChanIO
137 recvChan <- newTChanIO
@@ -135,18 +140,19 @@ runJavaScript sendBatch entryPoint = do
135 nextRef' <- newTVarIO 0
140 nextRef' <- newTVarIO 0
136 let ctx = JSContextRef {
141 let ctx = JSContextRef {
137 startTime = startTime'
142 startTime = startTime'
138− , doSendCommand = \cmd -> do
143+ , doSendCommand = \cmd -> cmd `deepseq` do
139 result <- newEmptyMVar
144 result <- newEmptyMVar
140 atomically $ writeTChan commandChan (Right (cmd, result))
145 atomically $ writeTChan commandChan (Right (cmd, result))
146+ unsafeInterleaveIO $
141− takeMVar result >>= \case
147+ takeMVar result >>= \case
142− (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
148+ (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)
143− r -> return r
149+ r -> return r
144− , doSendAsyncCommand = atomically . writeTChan commandChan . Left
150+ , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)
145 , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar callbacks (M.insert val cb)
151 , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar callbacks (M.insert val cb)
146 , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar callbacks (M.delete val)
152 , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar callbacks (M.delete val)
147 , nextRef = nextRef'
153 , nextRef = nextRef'
148 }
154 }
149− let processResult = \case
155+ let processResults = \case
150 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
156 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err
151 (Callback f this a) -> do
157 (Callback f this a) -> do
152 f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
158 f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
@@ -157,40 +163,39 @@ runJavaScript sendBatch entryPoint = do
157 Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
163 Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx
158 m -> atomically $ writeTChan recvChan m
164 m -> atomically $ writeTChan recvChan m
159 _ <- forkIO . forever $ readBatch commandChan >>= \case
165 _ <- forkIO . forever $ readBatch commandChan >>= \case
160− (batch, Just resultMVar) -> do
166+ (batch, resultMVars) -> do
161− sendBatch batch
162− atomically (readTChan recvChan) >>= putMVar resultMVar
163− (batch, Nothing) -> do
164 sendBatch batch
167 sendBatch batch
165 atomically (readTChan recvChan) >>= \case
168 atomically (readTChan recvChan) >>= \case
166− SyncResult -> return ()
169+ Success results -> zipWithM_ putMVar resultMVars results
167− ThrowJSValue e -> atomically (discardToSyncPoint commandChan) >>= (`putMVar` ThrowJSValue e)
170+ Failure results exception -> zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
168− _ -> error "Unexpected result processing batch"
171+ _ -> error "Unexpected jsaddle results"
169− return ()
170− return (processResult, runReaderT (unJSM entryPoint) ctx)
172+ return (processResults, runReaderT (unJSM entryPoint) ctx)
171 where
173 where
172− readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, Maybe (MVar Result))
174+ readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
173 readBatch chan = do
175 readBatch chan = do
174 first <- atomically $ readTChan chan -- We want at least one command to send
176 first <- atomically $ readTChan chan -- We want at least one command to send
175− loop first []
177+ loop first ([], [])
176 where
178 where
179+ loop :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
177− loop (Left asyncCmd@(SyncWithAnimationFrame _)) asyncCmds =
180+ loop (Left asyncCmd@(SyncWithAnimationFrame _)) (cmds, resultMVars) =
178− atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (asyncCmd:asyncCmds)
181+ atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
179− loop (Right (cmd, resultMVar)) asyncCmds =
182+ loop (Right (syncCmd, resultMVar)) (cmds', resultMVars') = do
183+ let cmds = Right syncCmd:cmds'
184+ resultMVars = resultMVar:resultMVars'
185+ atomically (tryReadTChan chan) >>= \case
180− return (Batch (reverse asyncCmds) cmd False, Just resultMVar)
186+ Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
187+ Just cmd -> loop cmd (cmds, resultMVars)
181− loop (Left asyncCmd) asyncCmds' = do
188+ loop (Left asyncCmd) (cmds', resultMVars) = do
182− let asyncCmds = asyncCmd:asyncCmds'
189+ let cmds = Left asyncCmd:cmds'
183 atomically (tryReadTChan chan) >>= \case
190 atomically (tryReadTChan chan) >>= \case
184− Nothing -> return (Batch (reverse asyncCmds) Sync False, Nothing)
191+ Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)
185− Just cmd -> loop cmd asyncCmds
192+ Just cmd -> loop cmd (cmds, resultMVars)
186 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
193 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
187− loopAnimation (Right (cmd, resultMVar)) asyncCmds =
188− return (Batch (reverse asyncCmds) cmd True, Just resultMVar)
189− loopAnimation (Left asyncCmd) asyncCmds =
190− atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (asyncCmd:asyncCmds)
191− discardToSyncPoint :: TChan (Either AsyncCommand (Command, MVar Result)) -> STM (MVar Result)
194+ loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
192− discardToSyncPoint chan =
195+ loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =
193− readTChan chan >>= \case
196+ return (Batch (reverse (Right Sync:cmds)) True, reverse (resultMVar:resultMVars))
194− Right (_, resultMVar) -> return resultMVar
197+ loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =
195− _ -> discardToSyncPoint chan
198+ atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)
199+ loopAnimation (Left asyncCmd) (cmds, resultMVars) =
200+ atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Left asyncCmd:cmds, resultMVars)
196#endif
201#endif
jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+78−72
@@ -47,12 +47,15 @@ initState = "\
47
47
48runBatch :: (ByteString -> ByteString) -> ByteString
48runBatch :: (ByteString -> ByteString) -> ByteString
49runBatch send = "\
49runBatch send = "\
50− \ var processBatch = function(timestamp) {\n\
50+ \ var processBatch = function(timestamp) {\n\
51+ \ var results = [];\n\
51− \ try {\n\
52+ \ try {\n\
52− \ var nAsyncLength = batch[0].length;\n\
53+ \ var nCommandsLength = batch[0].length;\n\
53− \ for (var nAsync = 0; nAsync != nAsyncLength; nAsync++) {\n\
54+ \ for (var nCommand = 0; nCommand != nCommandsLength; nCommand++) {\n\
54− \ var d = batch[0][nAsync];\n\
55+ \ var cmd = batch[0][nCommand];\n\
56+ \ if (cmd.Left) {\n\
57+ \ var d = cmd.Left;\n\
55− \ switch (d.tag) {\n\
58+ \ switch (d.tag) {\n\
56 \ case \"FreeRef\":\n\
59 \ case \"FreeRef\":\n\
57 \ jsaddle_values.delete(d.contents);\n\
60 \ jsaddle_values.delete(d.contents);\n\
58 \ break;\n\
61 \ break;\n\
@@ -148,76 +151,79 @@ runBatch send = "\
148 \ default:\n\
151 \ default:\n\
149 \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\
152 \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\
150 \ return;\n\
153 \ return;\n\
151− \ }\n\
152 \ }\n\
154 \ }\n\
155+ \ } else {\n\
153− \ var d = batch[1];\n\
156+ \ var d = cmd.Right;\n\
154 \ switch (d.tag) {\n\
157 \ switch (d.tag) {\n\
155− \ case \"ValueToString\":\n\
158+ \ case \"ValueToString\":\n\
156− \ var val = jsaddle_values.get(d.contents);\n\
159+ \ var val = jsaddle_values.get(d.contents);\n\
157− \ var s = val === null ? \"null\" : val === undefined ? \"undefined\" : val.toString();\n\
160+ \ var s = val === null ? \"null\" : val === undefined ? \"undefined\" : val.toString();\n\
158− \ " <> send "{\"tag\": \"ValueToStringResult\", \"contents\": s}" <> "\n\
161+ \ results.push({\"tag\": \"ValueToStringResult\", \"contents\": s});\n\
159− \ break;\n\
162+ \ break;\n\
160− \ case \"ValueToBool\":\n\
163+ \ case \"ValueToBool\":\n\
161− \ " <> send "{\"tag\": \"ValueToBoolResult\", \"contents\": jsaddle_values.get(d.contents) ? true : false}" <> "\n\
164+ \ results.push({\"tag\": \"ValueToBoolResult\", \"contents\": jsaddle_values.get(d.contents) ? true : false});\n\
162− \ break;\n\
165+ \ break;\n\
163− \ case \"ValueToNumber\":\n\
166+ \ case \"ValueToNumber\":\n\
164− \ " <> send "{\"tag\": \"ValueToNumberResult\", \"contents\": Number(jsaddle_values.get(d.contents))}" <> "\n\
167+ \ results.push({\"tag\": \"ValueToNumberResult\", \"contents\": Number(jsaddle_values.get(d.contents))});\n\
165− \ break;\n\
168+ \ break;\n\
166− \ case \"ValueToJSON\":\n\
169+ \ case \"ValueToJSON\":\n\
167− \ var s = jsaddle_values.get(d.contents) === undefined ? \"\" : JSON.stringify(jsaddle_values.get(d.contents));\n\
170+ \ var s = jsaddle_values.get(d.contents) === undefined ? \"\" : JSON.stringify(jsaddle_values.get(d.contents));\n\
168− \ " <> send "{\"tag\": \"ValueToJSONResult\", \"contents\": s}" <> "\n\
171+ \ results.push({\"tag\": \"ValueToJSONResult\", \"contents\": s});\n\
169− \ break;\n\
172+ \ break;\n\
170− \ case \"ValueToJSONValue\":\n\
173+ \ case \"ValueToJSONValue\":\n\
171− \ " <> send "{\"tag\": \"ValueToJSONValueResult\", \"contents\": jsaddle_values.get(d.contents)}" <> "\n\
174+ \ results.push({\"tag\": \"ValueToJSONValueResult\", \"contents\": jsaddle_values.get(d.contents)});\n\
172− \ break;\n\
175+ \ break;\n\
173− \ case \"DeRefVal\":\n\
176+ \ case \"DeRefVal\":\n\
174− \ var n = d.contents;\n\
177+ \ var n = d.contents;\n\
175− \ var v = jsaddle_values.get(n);\n\
178+ \ var v = jsaddle_values.get(n);\n\
176− \ var c = (v === null ) ? [0, \"\"] :\n\
179+ \ var c = (v === null ) ? [0, \"\"] :\n\
177− \ (v === undefined ) ? [1, \"\"] :\n\
180+ \ (v === undefined ) ? [1, \"\"] :\n\
178− \ (v === false ) ? [2, \"\"] :\n\
181+ \ (v === false ) ? [2, \"\"] :\n\
179− \ (v === true ) ? [3, \"\"] :\n\
182+ \ (v === true ) ? [3, \"\"] :\n\
180− \ (typeof v === \"number\") ? [-1, v.toString()] :\n\
183+ \ (typeof v === \"number\") ? [-1, v.toString()] :\n\
181− \ (typeof v === \"string\") ? [-2, v]\n\
184+ \ (typeof v === \"string\") ? [-2, v]\n\
182− \ : [n, \"\"];\n\
185+ \ : [n, \"\"];\n\
183− \ " <> send "{\"tag\": \"DeRefValResult\", \"contents\": c}" <> "\n\
186+ \ results.push({\"tag\": \"DeRefValResult\", \"contents\": c});\n\
184− \ break;\n\
187+ \ break;\n\
185− \ case \"IsNull\":\n\
188+ \ case \"IsNull\":\n\
186− \ " <> send "{\"tag\": \"IsNullResult\", \"contents\": jsaddle_values.get(d.contents) === null}" <> "\n\
189+ \ results.push({\"tag\": \"IsNullResult\", \"contents\": jsaddle_values.get(d.contents) === null});\n\
187− \ break;\n\
190+ \ break;\n\
188− \ case \"IsUndefined\":\n\
191+ \ case \"IsUndefined\":\n\
189− \ " <> send "{\"tag\": \"IsUndefinedResult\", \"contents\": jsaddle_values.get(d.contents) === undefined}" <> "\n\
192+ \ results.push({\"tag\": \"IsUndefinedResult\", \"contents\": jsaddle_values.get(d.contents) === undefined});\n\
190− \ break;\n\
193+ \ break;\n\
191− \ case \"InstanceOf\":\n\
194+ \ case \"InstanceOf\":\n\
192− \ " <> send "{\"tag\": \"InstanceOfResult\", \"contents\": jsaddle_values.get(d.contents[0]) instanceof jsaddle_values.get(d.contents[1])}" <> "\n\
195+ \ results.push({\"tag\": \"InstanceOfResult\", \"contents\": jsaddle_values.get(d.contents[0]) instanceof jsaddle_values.get(d.contents[1])});\n\
193− \ break;\n\
196+ \ break;\n\
194− \ case \"StrictEqual\":\n\
197+ \ case \"StrictEqual\":\n\
195− \ " <> send "{\"tag\": \"StrictEqualResult\", \"contents\": jsaddle_values.get(d.contents[0]) === jsaddle_values.get(d.contents[1])}" <> "\n\
198+ \ results.push({\"tag\": \"StrictEqualResult\", \"contents\": jsaddle_values.get(d.contents[0]) === jsaddle_values.get(d.contents[1])});\n\
196− \ break;\n\
199+ \ break;\n\
197− \ case \"PropertyNames\":\n\
200+ \ case \"PropertyNames\":\n\
198− \ var result = [];\n\
201+ \ var result = [];\n\
199− \ for (name in jsaddle_values.get(d.contents)) { result.push(name); }\n\
202+ \ for (name in jsaddle_values.get(d.contents)) { result.push(name); }\n\
200− \ " <> send "{\"tag\": \"PropertyNamesResult\", \"contents\": result}" <> "\n\
203+ \ results.push({\"tag\": \"PropertyNamesResult\", \"contents\": result});\n\
201− \ break;\n\
204+ \ break;\n\
202− \ case \"Sync\":\n\
205+ \ case \"Sync\":\n\
203− \ " <> send "{\"tag\": \"SyncResult\", \"contents\": []}" <> "\n\
206+ \ results.push({\"tag\": \"SyncResult\", \"contents\": []});\n\
204− \ break;\n\
207+ \ break;\n\
205− \ default:\n\
208+ \ default:\n\
206− \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\
209+ \ results.push({\"tag\": \"ProtocolError\", \"contents\": e.data});\n\
207− \ }\n\
210+ \ }\n\
208− \ }\n\
209− \ catch (err) {\n\
210− \ var n = ++jsaddle_index;\n\
211− \ jsaddle_values.set(n, err);\n\
212− \ " <> send "{\"tag\": \"ThrowJSValue\", \"contents\": n}" <> "\n\
213 \ }\n\
211 \ }\n\
214− \ };\n\
215− \ if(batch[2]) {\n\
216− \ window.requestAnimationFrame(processBatch);\n\
217− \ }\n\
218− \ else {\n\
219− \ processBatch(window.performance ? window.performance.now() : null);\n\
220 \ }\n\
212 \ }\n\
213+ \ " <> send "{\"tag\": \"Success\", \"contents\": results}" <> "\n\
214+ \ }\n\
215+ \ catch (err) {\n\
216+ \ var n = ++jsaddle_index;\n\
217+ \ jsaddle_values.set(n, err);\n\
218+ \ " <> send "{\"tag\": \"Failure\", \"contents\": [results,n]}" <> "\n\
219+ \ }\n\
220+ \ };\n\
221+ \ if(batch[1]) {\n\
222+ \ window.requestAnimationFrame(processBatch);\n\
223+ \ }\n\
224+ \ else {\n\
225+ \ processBatch(window.performance ? window.performance.now() : null);\n\
226+ \ }\n\
221 \"
227 \"
222
228
223-- Use this to generate this string for embedding
229-- Use this to generate this string for embedding
jsaddle/src/Language/Javascript/JSaddle/Types.hs+29−8
@@ -36,6 +36,8 @@ module Language.Javascript.JSaddle.Types (
36
36
37 -- * JavaScript Value Types
37 -- * JavaScript Value Types
38 , JSVal(..)
38 , JSVal(..)
39+ , IsJSVal
40+ , jsval
39 , SomeJSArray(..)
41 , SomeJSArray(..)
40 , JSArray
42 , JSArray
41 , MutableJSArray
43 , MutableJSArray
@@ -55,6 +57,7 @@ module Language.Javascript.JSaddle.Types (
55 , Command(..)
57 , Command(..)
56 , Batch(..)
58 , Batch(..)
57 , Result(..)
59 , Result(..)
60+ , Results(..)
58#endif
61#endif
59) where
62) where
60
63
@@ -228,16 +231,19 @@ newtype JSString = JSString Text deriving(Show, ToJSON, FromJSON)
228newtype JSValueReceived = JSValueReceived JSValueRef deriving(Show, ToJSON, FromJSON)
231newtype JSValueReceived = JSValueReceived JSValueRef deriving(Show, ToJSON, FromJSON)
229
232
230-- | Wrapper used when sending a 'JSVal' to the JavaScript context
233-- | Wrapper used when sending a 'JSVal' to the JavaScript context
231−newtype JSValueForSend = JSValueForSend JSValueRef deriving(Show, ToJSON, FromJSON)
234+newtype JSValueForSend = JSValueForSend JSValueRef deriving(Show, ToJSON, FromJSON, Generic)
235+instance NFData JSValueForSend
232
236
233-- | Wrapper used when sending a 'Object' to the JavaScript context
237-- | Wrapper used when sending a 'Object' to the JavaScript context
234−newtype JSObjectForSend = JSObjectForSend JSValueForSend deriving(Show, ToJSON, FromJSON)
238+newtype JSObjectForSend = JSObjectForSend JSValueForSend deriving(Show, ToJSON, FromJSON, Generic)
239+instance NFData JSObjectForSend
235
240
236-- | Wrapper used when receiving a 'JSString' from the JavaScript context
241-- | Wrapper used when receiving a 'JSString' from the JavaScript context
237newtype JSStringReceived = JSStringReceived Text deriving(Show, ToJSON, FromJSON)
242newtype JSStringReceived = JSStringReceived Text deriving(Show, ToJSON, FromJSON)
238
243
239-- | Wrapper used when sending a 'JString' to the JavaScript context
244-- | Wrapper used when sending a 'JString' to the JavaScript context
240−newtype JSStringForSend = JSStringForSend Text deriving(Show, ToJSON, FromJSON)
245+newtype JSStringForSend = JSStringForSend Text deriving(Show, ToJSON, FromJSON, Generic)
246+instance NFData JSStringForSend
241
247
242-- | Command sent to a JavaScript context for execution asynchronously
248-- | Command sent to a JavaScript context for execution asynchronously
243data AsyncCommand = FreeRef JSValueForSend
249data AsyncCommand = FreeRef JSValueForSend
@@ -255,13 +261,15 @@ data AsyncCommand = FreeRef JSValueForSend
255 | NewArray [JSValueForSend] JSValueForSend
261 | NewArray [JSValueForSend] JSValueForSend
256 | EvaluateScript JSStringForSend JSValueForSend
262 | EvaluateScript JSStringForSend JSValueForSend
257 | SyncWithAnimationFrame JSValueForSend
263 | SyncWithAnimationFrame JSValueForSend
258− deriving (Show, Generic)
264+ deriving (Show, Generic)
259
265
260instance ToJSON AsyncCommand where
266instance ToJSON AsyncCommand where
261 toEncoding = genericToEncoding defaultOptions
267 toEncoding = genericToEncoding defaultOptions
262
268
263instance FromJSON AsyncCommand
269instance FromJSON AsyncCommand
264
270
271+instance NFData AsyncCommand
272+
265-- | Command sent to a JavaScript context for execution synchronously
273-- | Command sent to a JavaScript context for execution synchronously
266data Command = DeRefVal JSValueForSend
274data Command = DeRefVal JSValueForSend
267 | ValueToBool JSValueForSend
275 | ValueToBool JSValueForSend
@@ -282,8 +290,10 @@ instance ToJSON Command where
282
290
283instance FromJSON Command
291instance FromJSON Command
284
292
293+instance NFData Command
294+
285-- | Batch of commands that can be sent together to the JavaScript context
295-- | Batch of commands that can be sent together to the JavaScript context
286−data Batch = Batch [AsyncCommand] Command Bool
296+data Batch = Batch [Either AsyncCommand Command] Bool
287 deriving (Show, Generic)
297 deriving (Show, Generic)
288
298
289instance ToJSON Batch where
299instance ToJSON Batch where
@@ -291,6 +301,8 @@ instance ToJSON Batch where
291
301
292instance FromJSON Batch
302instance FromJSON Batch
293
303
304+instance NFData Batch
305+
294-- | Result of a 'Command' returned from the JavaScript context
306-- | Result of a 'Command' returned from the JavaScript context
295data Result = DeRefValResult JSValueRef Text
307data Result = DeRefValResult JSValueRef Text
296 | ValueToBoolResult Bool
308 | ValueToBoolResult Bool
@@ -302,17 +314,26 @@ data Result = DeRefValResult JSValueRef Text
302 | IsUndefinedResult Bool
314 | IsUndefinedResult Bool
303 | StrictEqualResult Bool
315 | StrictEqualResult Bool
304 | InstanceOfResult Bool
316 | InstanceOfResult Bool
305− | Callback JSValueReceived JSValueReceived [JSValueReceived]
306 | PropertyNamesResult [JSStringReceived]
317 | PropertyNamesResult [JSStringReceived]
307 | ThrowJSValue JSValueReceived
318 | ThrowJSValue JSValueReceived
308− | ProtocolError Text
309 | SyncResult
319 | SyncResult
310− deriving (Show, Generic)
320+ deriving (Show, Generic)
311
321
312instance ToJSON Result where
322instance ToJSON Result where
313 toEncoding = genericToEncoding defaultOptions
323 toEncoding = genericToEncoding defaultOptions
314
324
315instance FromJSON Result
325instance FromJSON Result
326+
327+data Results = Success [Result]
328+ | Failure [Result] JSValueReceived
329+ | Callback JSValueReceived JSValueReceived [JSValueReceived]
330+ | ProtocolError Text
331+ deriving (Show, Generic)
332+
333+instance ToJSON Results where
334+ toEncoding = genericToEncoding defaultOptions
335+
336+instance FromJSON Results
316#endif
337#endif
317
338
318
339
jsaddle/src/Language/Javascript/JSaddle/Value.hs+16−15
@@ -97,7 +97,7 @@ import Data.Word (Word, Word8, Word16, Word32)
97import Data.Int (Int8, Int16, Int32)
97import Data.Int (Int8, Int16, Int32)
98import GHCJS.Marshal.Internal (ToJSVal(..), FromJSVal(..))
98import GHCJS.Marshal.Internal (ToJSVal(..), FromJSVal(..))
99import Language.Javascript.JSaddle.Types
99import Language.Javascript.JSaddle.Types
100− (Object(..), JSString(..), JSVal(..), JSValueForSend(..))
100+ (Object(..), JSString(..), JSVal(..))
101import Language.Javascript.JSaddle.Native
101import Language.Javascript.JSaddle.Native
102 (wrapJSString, withJSVal, withObject, withJSString, withToJSVal)
102 (wrapJSString, withJSVal, withObject, withJSString, withToJSVal)
103import Language.Javascript.JSaddle.Run
103import Language.Javascript.JSaddle.Run
@@ -194,7 +194,7 @@ foreign import javascript unsafe "$r = Number($1);" jsrefToNumber :: JSVal -> Do
194#else
194#else
195valToNumber value =
195valToNumber value =
196 withToJSVal value $ \rval -> do
196 withToJSVal value $ \rval -> do
197− ValueToNumberResult result <- sendCommand (ValueToNumber rval)
197+ ~(ValueToNumberResult result) <- sendCommand (ValueToNumber rval)
198 return result
198 return result
199#endif
199#endif
200
200
@@ -224,7 +224,7 @@ foreign import javascript unsafe "$r = $1.toString();" jsrefToString :: JSVal ->
224#else
224#else
225valToStr value =
225valToStr value =
226 withToJSVal value $ \rval -> do
226 withToJSVal value $ \rval -> do
227− ValueToStringResult result <- sendCommand (ValueToString rval)
227+ ~(ValueToStringResult result) <- sendCommand (ValueToString rval)
228 wrapJSString result
228 wrapJSString result
229#endif
229#endif
230
230
@@ -278,7 +278,7 @@ foreign import javascript unsafe "$r = $1 === undefined ? \"\" : JSON.stringify(
278#else
278#else
279valToJSON value =
279valToJSON value =
280 withToJSVal value $ \rval -> do
280 withToJSVal value $ \rval -> do
281− ValueToJSONResult result <- sendCommand (ValueToJSON rval)
281+ ~(ValueToJSONResult result) <- sendCommand (ValueToJSON rval)
282 wrapJSString result
282 wrapJSString result
283#endif
283#endif
284
284
@@ -645,15 +645,16 @@ foreign import javascript unsafe "$r = ($1 === undefined)?0:\
645deRefVal value = do
645deRefVal value = do
646 v <- toJSVal value
646 v <- toJSVal value
647 withJSVal v $ \rval ->
647 withJSVal v $ \rval ->
648− sendCommand (DeRefVal rval) >>= \case
648+ sendCommand (DeRefVal rval) >>= \result -> return $
649+ case result of
649− DeRefValResult 0 _ -> return ValNull
650+ DeRefValResult 0 _ -> ValNull
650− DeRefValResult 1 _ -> return ValUndefined
651+ DeRefValResult 1 _ -> ValUndefined
651− DeRefValResult 2 _ -> return $ ValBool False
652+ DeRefValResult 2 _ -> ValBool False
652− DeRefValResult 3 _ -> return $ ValBool True
653+ DeRefValResult 3 _ -> ValBool True
653− DeRefValResult (-1) s -> return $ ValNumber (read (T.unpack s))
654+ DeRefValResult (-1) s -> ValNumber (read (T.unpack s))
654− DeRefValResult (-2) s -> return $ ValString s
655+ DeRefValResult (-2) s -> ValString s
655− DeRefValResult ref _ -> return $ ValObject (Object (JSVal ref))
656+ DeRefValResult ref _ -> ValObject (Object (JSVal ref))
656− _ -> error "Unexpected result dereferencing JSaddle value"
657+ _ -> error "Unexpected result dereferencing JSaddle value"
657#endif
658#endif
658
659
659-- | Make a JavaScript value out of a 'JSValue' ADT.
660-- | Make a JavaScript value out of a 'JSValue' ADT.
@@ -714,7 +715,7 @@ strictEqual a b = do
714#else
715#else
715 withJSVal aval $ \aref ->
716 withJSVal aval $ \aref ->
716 withJSVal bval $ \bref -> do
717 withJSVal bval $ \bref -> do
717− StrictEqualResult result <- sendCommand $ StrictEqual aref bref
718+ ~(StrictEqualResult result) <- sendCommand $ StrictEqual aref bref
718 return result
719 return result
719#endif
720#endif
720
721
@@ -735,7 +736,7 @@ instanceOf value constructor = do
735#else
736#else
736 withJSVal v $ \rval ->
737 withJSVal v $ \rval ->
737 withObject c $ \c' -> do
738 withObject c $ \c' -> do
738− InstanceOfResult result <- sendCommand $ InstanceOf rval c'
739+ ~(InstanceOfResult result) <- sendCommand $ InstanceOf rval c'
739 return result
740 return result
740#endif
741#endif
741
742