675f74b · jsaddle · git.iko.soy

git.iko.soy/jsaddle

on master help sign in

Synchronous callbacks for jsaddle-wkwebview

675f74bHamish Mackenzie9 years ago

cabal.project+1

compare with master

unifiedsplit

@@ -6,6 +6,7 @@ packages:

6 jsaddle-wkwebview/

7-- jsaddle-webkitgtk/

8 jsaddle-webkit2gtk/

9+ jsaddle-clib/

10package gi-atk

11package gi-atk

11 flags: -overloaded-methods -overloaded-signals -overloaded-properties

12 flags: -overloaded-methods -overloaded-signals -overloaded-properties

jsaddle-clib/src-ghc/Language/Javascript/JSaddle/CLib.hs+2−2

@@ -35,7 +35,7 @@ foreign import ccall safe "wrapper"

35jsaddleInit :: JSM () -> FunPtr (CString -> IO ()) -> IO (Ptr NativeCallbacks)

36jsaddleInit jsm evaluateJavascriptAsyncPtr = do

37 let evaluateJavascriptAsync = mkCallback evaluateJavascriptAsyncPtr

38− (processResult, start) <- runJavaScript (\batch ->

38+ (processResult, _, start) <- runJavaScript (\batch ->

39 useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $

40 evaluateJavascriptAsync) jsm

41 jsaddleStartPtr <- wrapStartCallback $ void $ forkIO $ start

@@ -58,7 +58,7 @@ jsaddleJs = ghcjsHelpers <> "\

58 \runJSaddleBatch = (function() {\n\

59 \ " <> initState <> "\n\

60 \ return function(batch) {\n\

61− \ " <> runBatch (\a -> "jsaddle.postMessage(JSON.stringify(" <> a <> "));") <> "\

61+ \ " <> runBatch (\a -> "jsaddle.postMessage(JSON.stringify(" <> a <> "));") Nothing <> "\

62 \ };\n\

63 \})();\n\

64 \jsaddle.postReady();\n"

jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+1−1

@@ -48,7 +48,7 @@ jsaddleOr opts entryPoint = websocketsOr opts wsApp

48 wsApp :: ServerApp

49 wsApp pending_conn = do

50 conn <- acceptRequest pending_conn

51− (processResult, start) <- runJavaScript (sendTextData conn . encode) entryPoint

51+ (processResult, _, start) <- runJavaScript (sendTextData conn . encode) entryPoint

52 _ <- forkIO . forever $

53 receiveDataMessage conn >>= \case

54 (WS.Text t) ->

jsaddle-webkit2gtk/src/Language/Javascript/JSaddle/WebKitGTK.hs+30−9

@@ -67,9 +67,12 @@ import GI.Gtk

67import GI.Gio (noCancellable)

68import GI.JavaScriptCore (Value(..), GlobalContext(..))

69import GI.WebKit2

70+ (scriptDialogPromptSetText, scriptDialogPromptGetDefaultText,

71+ scriptDialogGetMessage, scriptDialogGetDialogType,

72+ onWebViewScriptDialog, WebView,

70− (WebView, setSettingsEnableWriteConsoleMessagesToStdout,

73+ setSettingsEnableWriteConsoleMessagesToStdout,

71− setSettingsEnableJavascript,

74+ setSettingsEnableJavascript, webViewNewWithUserContentManager,

72− webViewNewWithUserContentManager, userContentManagerNew,

75+ userContentManagerNew,

73 userContentManagerRegisterScriptMessageHandler,

76 userContentManagerRegisterScriptMessageHandler,

74 javascriptResultGetValue, javascriptResultGetGlobalContext,

77 javascriptResultGetValue, javascriptResultGetGlobalContext,

75 webViewGetUserContentManager,

78 webViewGetUserContentManager,

@@ -78,7 +81,7 @@ import GI.WebKit2

78 webViewRunJavascript, LoadEvent(..),

81 webViewRunJavascript, LoadEvent(..),

79 UserContentManagerScriptMessageReceivedCallback, webViewLoadHtml,

82 UserContentManagerScriptMessageReceivedCallback, webViewLoadHtml,

80 onWebViewLoadChanged, setSettingsEnableDeveloperExtras,

83 onWebViewLoadChanged, setSettingsEnableDeveloperExtras,

81− webViewSetSettings, webViewGetSettings)

84+ webViewSetSettings, webViewGetSettings, ScriptDialogType(..))

83import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

86import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

84 (JSValueRef, JSContextRef)

87 (JSValueRef, JSContextRef)

@@ -87,7 +90,7 @@ import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

87import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

90import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

88 (jsvaluetostringcopy)

91 (jsvaluetostringcopy)

90−import Language.Javascript.JSaddle (JSM, Results)

93+import Language.Javascript.JSaddle (JSM, Results, Batch)

91import Language.Javascript.JSaddle.Run (runJavaScript)

94import Language.Javascript.JSaddle.Run (runJavaScript)

92import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)

95import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)

@@ -151,11 +154,11 @@ run main = do

151

154

152runInWebView :: JSM () -> WebView -> IO ()

155runInWebView :: JSM () -> WebView -> IO ()

153runInWebView f webView = do

156runInWebView f webView = do

154− (processResults, start) <- runJavaScript (\batch -> postGUIAsync $

157+ (processResults, syncResults, start) <- runJavaScript (\batch -> postGUIAsync $

155 webViewRunJavascript webView (decodeUtf8 . toStrict $ "runJSaddleBatch(" <> encode batch <> ");") noCancellable Nothing)

158 webViewRunJavascript webView (decodeUtf8 . toStrict $ "runJSaddleBatch(" <> encode batch <> ");") noCancellable Nothing)

156 f

159 f

157

160

158− addJSaddleHandler webView processResults

161+ addJSaddleHandler webView processResults syncResults

159 webViewRunJavascript webView (decodeUtf8 $ toStrict jsaddleJs) noCancellable . Just $

162 webViewRunJavascript webView (decodeUtf8 $ toStrict jsaddleJs) noCancellable . Just $

160 \_obj _asyncResult ->

163 \_obj _asyncResult ->

161 void $ forkIO start

164 void $ forkIO start

@@ -170,8 +173,8 @@ connectUserContentManagerScriptMessageReceived obj cb after = liftIO $ do

170 cb'' <- mk_UserContentManagerScriptMessageReceivedCallback cb'

173 cb'' <- mk_UserContentManagerScriptMessageReceivedCallback cb'

171 connectSignalFunPtr obj "script-message-received::jsaddle" cb'' after

174 connectSignalFunPtr obj "script-message-received::jsaddle" cb'' after

172

175

173−addJSaddleHandler :: WebView -> (Results -> IO ()) -> IO ()

176+addJSaddleHandler :: WebView -> (Results -> IO ()) -> (Results -> IO Batch) -> IO ()

174−addJSaddleHandler webView processResult = do

177+addJSaddleHandler webView processResult syncResults = do

175 manager <- webViewGetUserContentManager webView

178 manager <- webViewGetUserContentManager webView

176 _ <- onUserContentManagerScriptMessageReceived manager $ \result -> do

179 _ <- onUserContentManagerScriptMessageReceived manager $ \result -> do

177 ctx <- javascriptResultGetGlobalContext result

180 ctx <- javascriptResultGetGlobalContext result

@@ -180,6 +183,21 @@ addJSaddleHandler webView processResult = do

180 withJSValueRef arg $ \argRef ->

183 withJSValueRef arg $ \argRef ->

181 encodeUtf8 <$> valueToText ctxRef argRef

184 encodeUtf8 <$> valueToText ctxRef argRef

182 mapM_ processResult (decode (fromStrict bs))

185 mapM_ processResult (decode (fromStrict bs))

186+ _ <- onWebViewScriptDialog webView $ \dialog ->

187+ scriptDialogGetDialogType dialog >>= \case

188+ ScriptDialogTypePrompt ->

189+ scriptDialogGetMessage dialog >>= \case

190+ "JSaddleSync" -> do

191+ resultsText <- scriptDialogPromptGetDefaultText dialog

192+ case decode (fromStrict $ encodeUtf8 resultsText) of

193+ Just results -> do

194+ batch <- syncResults results

195+ scriptDialogPromptSetText dialog (decodeUtf8 . toStrict $ encode batch)

196+ return True

197+ Nothing -> return False

198+ _ -> return False

199+ _ -> return False

200+

183 void $ userContentManagerRegisterScriptMessageHandler manager "jsaddle"

201 void $ userContentManagerRegisterScriptMessageHandler manager "jsaddle"

184

202

185jsaddleJs :: LB.ByteString

203jsaddleJs :: LB.ByteString

@@ -188,6 +206,9 @@ jsaddleJs = ghcjsHelpers <> mconcat

188 , initState

206 , initState

189 , "\nreturn function(batch) {\n"

207 , "\nreturn function(batch) {\n"

190 , runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));\n")

208 , runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));\n")

209+ Nothing

210+ -- TODO fix https://github.com/haskell-gi/haskell-gi/issues/97 then use

211+ -- (Just (\a -> "JSON.parse(window.prompt(\"JSaddleSync\", JSON.stringify(" <> a <> ")))"))

191 , "};\n"

212 , "};\n"

192 , "})()"

213 , "})()"

193 ]

214 ]

jsaddle-webkitgtk/src/Language/Javascript/JSaddle/WebKitGTK.hs+2−2

@@ -185,7 +185,7 @@ runInWebView f webView = do

185 jsvalueprotect ctxRef result

186 return result

187

188− (processResults, start) <- runJavaScript (\batch -> postGUIAsync $

188+ (processResults, _, start) <- runJavaScript (\batch -> postGUIAsync $

189 withJSContextRef ctx $ \ctxRef ->

190 withJSString (decodeUtf8 . toStrict $ encode batch) $ \script -> do

191 val <- jsvaluemakestring ctxRef script

@@ -222,7 +222,7 @@ jsaddleJs = ghcjsHelpers <> mconcat

222 , initState

223 , "\nreturn function(batchJSON) {\n"

224 , " var batch = JSON.parse(batchJSON);\n"

225− , runBatch (\a -> "window.jsaddleCallback(JSON.stringify(" <> a <> "));\n")

225+ , runBatch (\a -> "window.jsaddleCallback(JSON.stringify(" <> a <> "));\n") Nothing

226 , "};\n"

227 , "})()\n"

228 ]

jsaddle-wkwebview/cbits/WKWebView.m+31−8

@@ -4,26 +4,30 @@

5BOOL openApp(NSURL * url);

7−extern void jsaddleStart(HsStablePtr);

8−extern void jsaddleResult(HsStablePtr, const char * _Nonnull result);

9−

10−@interface JSaddleHandler : NSObject<WKNavigationDelegate, WKScriptMessageHandler>

7+@interface JSaddleHandler : NSObject<WKNavigationDelegate, WKScriptMessageHandler, WKUIDelegate>

12@property (nonatomic, assign) HsStablePtr startHandler;

9@property (nonatomic, assign) HsStablePtr startHandler;

13@property (nonatomic, assign) HsStablePtr resultHandler;

10@property (nonatomic, assign) HsStablePtr resultHandler;

11+@property (nonatomic, assign) HsStablePtr syncHandler;

12+@property (nonatomic, assign) void (^completionHandler)(NSString *result);

15−- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler;

14+- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler syncHandler:(HsStablePtr)syncHandler;

17@end

16@end

18+extern void jsaddleStart(HsStablePtr);

19+extern void jsaddleResult(HsStablePtr, const char * _Nonnull result);

20+extern void jsaddleSyncResult(HsStablePtr, JSaddleHandler *, const char * _Nonnull result);

21+

19@implementation JSaddleHandler

22@implementation JSaddleHandler

21−- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler

24+- (instancetype)initHandler:(HsStablePtr)startHandler resultHandler:(HsStablePtr)resultHandler syncHandler:(HsStablePtr)syncHandler

22{

25{

23 self = [super init];

26 self = [super init];

24 if (self) {

27 if (self) {

25 _startHandler = startHandler;

28 _startHandler = startHandler;

26 _resultHandler = resultHandler;

29 _resultHandler = resultHandler;

30+ _syncHandler = syncHandler;

27 }

31 }

28 return self;

32 return self;

29}

33}

@@ -39,6 +43,18 @@ extern void jsaddleResult(HsStablePtr, const char * _Nonnull result);

39 jsaddleResult(self.resultHandler, [s UTF8String]);

43 jsaddleResult(self.resultHandler, [s UTF8String]);

40}

44}

46+- (void)webView:(WKWebView *)webView runJavaScriptTextInputPanelWithPrompt:(NSString *)prompt

47+ defaultText:(NSString *)defaultText initiatedByFrame:(WKFrameInfo *)frame completionHandler:(void (^)(NSString *result))completionHandler

48+{

49+ if([prompt isEqualToString:@"JSaddleSync"]) {

50+ _completionHandler = completionHandler;

51+ jsaddleSyncResult(self.syncHandler, self, [defaultText UTF8String]);

52+ }

53+ else {

54+ // TODO decide what if anything should go here

55+ }

56+}

57+

42- (void)webView:(WKWebView *)webView decidePolicyForNavigationAction:(WKNavigationAction *)navigationAction decisionHandler:(void (^)(WKNavigationActionPolicy))decisionHandler

58- (void)webView:(WKWebView *)webView decidePolicyForNavigationAction:(WKNavigationAction *)navigationAction decisionHandler:(void (^)(WKNavigationActionPolicy))decisionHandler

43{

59{

44 NSURL *url = navigationAction.request.URL;

60 NSURL *url = navigationAction.request.URL;

@@ -55,10 +71,11 @@ extern void jsaddleResult(HsStablePtr, const char * _Nonnull result);

56@end

72@end

58−void addJSaddleHandler(WKWebView *webView, HsStablePtr startHandler, HsStablePtr resultHandler) {

74+void addJSaddleHandler(WKWebView *webView, HsStablePtr startHandler, HsStablePtr resultHandler, HsStablePtr syncHandler) {

59− JSaddleHandler * handler = [[JSaddleHandler alloc] initHandler:startHandler resultHandler:resultHandler];

75+ JSaddleHandler * handler = [[JSaddleHandler alloc] initHandler:startHandler resultHandler:resultHandler syncHandler:syncHandler];

60 [[[webView configuration] userContentController] addScriptMessageHandler:handler name:@"jsaddle"];

76 [[[webView configuration] userContentController] addScriptMessageHandler:handler name:@"jsaddle"];

61 webView.navigationDelegate = handler;

77 webView.navigationDelegate = handler;

78+ webView.UIDelegate = handler;

62}

79}

64void evaluateJavaScript(WKWebView *webView, const char * _Nonnull js) {

81void evaluateJavaScript(WKWebView *webView, const char * _Nonnull js) {

@@ -69,6 +86,12 @@ void evaluateJavaScript(WKWebView *webView, const char * _Nonnull js) {

69 });

86 });

70}

87}

89+void completeSync(JSaddleHandler *handler, const char * _Nonnull s) {

90+ NSString *string = [[NSString alloc] initWithCString:s encoding:NSUTF8StringEncoding];

91+ handler.completionHandler(string);

92+ handler.completionHandler = NULL;

93+}

94+

72void loadHTMLString(WKWebView *webView, const char * _Nonnull html) {

95void loadHTMLString(WKWebView *webView, const char * _Nonnull html) {

73 NSString *htmlString = [NSString stringWithCString:html encoding:NSUTF8StringEncoding];

96 NSString *htmlString = [NSString stringWithCString:html encoding:NSUTF8StringEncoding];

74 dispatch_async(dispatch_get_main_queue(), ^{

97 dispatch_async(dispatch_get_main_queue(), ^{

jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView/Internal.hs+23−7

@@ -20,24 +20,27 @@ import Foreign.C.String (CString)

20import Foreign.Ptr (Ptr, nullPtr)

21import Foreign.StablePtr (StablePtr, newStablePtr, deRefStablePtr)

23−import Language.Javascript.JSaddle (Results, JSM)

23+import Language.Javascript.JSaddle (Results, Batch, JSM)

24import Language.Javascript.JSaddle.Run (runJavaScript)

25import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)

27newtype WKWebView = WKWebView (Ptr WKWebView)

28+newtype JSaddleHandler = JSaddleHandler (Ptr JSaddleHandler)

29foreign export ccall jsaddleStart :: StablePtr (IO ()) -> IO ()

30foreign export ccall jsaddleStart :: StablePtr (IO ()) -> IO ()

30foreign export ccall jsaddleResult :: StablePtr (Results -> IO ()) -> CString -> IO ()

31foreign export ccall jsaddleResult :: StablePtr (Results -> IO ()) -> CString -> IO ()

32+foreign export ccall jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()

31foreign export ccall withWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()

33foreign export ccall withWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()

32−foreign import ccall addJSaddleHandler :: WKWebView -> StablePtr (IO ()) -> StablePtr (Results -> IO ()) -> IO ()

34+foreign import ccall addJSaddleHandler :: WKWebView -> StablePtr (IO ()) -> StablePtr (Results -> IO ()) -> StablePtr (Results -> IO Batch) -> IO ()

33foreign import ccall loadHTMLString :: WKWebView -> CString -> IO ()

35foreign import ccall loadHTMLString :: WKWebView -> CString -> IO ()

34foreign import ccall loadBundleFile :: WKWebView -> CString -> CString -> IO ()

36foreign import ccall loadBundleFile :: WKWebView -> CString -> CString -> IO ()

35foreign import ccall evaluateJavaScript :: WKWebView -> CString -> IO ()

37foreign import ccall evaluateJavaScript :: WKWebView -> CString -> IO ()

38+foreign import ccall completeSync :: JSaddleHandler -> CString -> IO ()

36foreign import ccall mainBundleResourcePathC :: IO CString

39foreign import ccall mainBundleResourcePathC :: IO CString

38-- | Run JSaddle in WKWebView

41-- | Run JSaddle in WKWebView

39jsaddleMain :: JSM () -> WKWebView -> IO ()

42jsaddleMain :: JSM () -> WKWebView -> IO ()

40−jsaddleMain f webView = do

43+jsaddleMain f webView =

41 jsaddleMain' f webView $

44 jsaddleMain' f webView $

42 useAsCString (toStrict indexHtml) $ loadHTMLString webView

45 useAsCString (toStrict indexHtml) $ loadHTMLString webView

@@ -46,7 +49,7 @@ jsaddleMain f webView = do

46jsaddleMainFile :: BS.ByteString -- ^ The file to navigate to.

49jsaddleMainFile :: BS.ByteString -- ^ The file to navigate to.

47 -> BS.ByteString -- ^ The path to allow read access to.

50 -> BS.ByteString -- ^ The path to allow read access to.

48 -> JSM () -> WKWebView -> IO ()

51 -> JSM () -> WKWebView -> IO ()

49−jsaddleMainFile url allowing f webView = do

52+jsaddleMainFile url allowing f webView =

50 jsaddleMain' f webView $

53 jsaddleMain' f webView $

51 useAsCString url $ \u ->

54 useAsCString url $ \u ->

52 useAsCString allowing $ \a ->

55 useAsCString allowing $ \a ->

@@ -56,14 +59,15 @@ jsaddleMain' :: JSM () -> WKWebView -> IO () -> IO ()

56jsaddleMain' f webView loadHtml = do

59jsaddleMain' f webView loadHtml = do

57 ready <- newEmptyMVar

60 ready <- newEmptyMVar

59− (processResult, start) <- runJavaScript (\batch ->

62+ (processResult, syncResult, start) <- runJavaScript (\batch ->

60 useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $

63 useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $

61 evaluateJavaScript webView)

64 evaluateJavaScript webView)

62 f

65 f

64 startHandler <- newStablePtr (putMVar ready ())

67 startHandler <- newStablePtr (putMVar ready ())

65 resultHandler <- newStablePtr processResult

68 resultHandler <- newStablePtr processResult

69+ syncResultHandler <- newStablePtr syncResult

66− addJSaddleHandler webView startHandler resultHandler

70+ addJSaddleHandler webView startHandler resultHandler syncResultHandler

67 loadHtml

71 loadHtml

68 void . forkOS $ do

72 void . forkOS $ do

69 takeMVar ready

73 takeMVar ready

@@ -80,6 +84,17 @@ jsaddleResult ptrHandler s = do

80 Nothing -> error $ "jsaddle WebSocket decode failed : " <> show result

84 Nothing -> error $ "jsaddle WebSocket decode failed : " <> show result

81 Just r -> processResult r

85 Just r -> processResult r

87+jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()

88+jsaddleSyncResult ptrHandler jsaddleHandler s = do

89+ syncProcessResult <- deRefStablePtr ptrHandler

90+ result <- packCString s

91+ case decode (fromStrict result) of

92+ Nothing -> error $ "jsaddle WebSocket decode failed : " <> show result

93+ Just r -> do -- void . forkIO $ do

94+ batch <- syncProcessResult r

95+ useAsCString (toStrict $ encode batch) $

96+ completeSync jsaddleHandler

97+

83withWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()

98withWebView :: WKWebView -> StablePtr (WKWebView -> IO ()) -> IO ()

84withWebView webView ptrF = do

99withWebView webView ptrF = do

85 f <- deRefStablePtr ptrF

100 f <- deRefStablePtr ptrF

@@ -90,7 +105,8 @@ jsaddleJs = ghcjsHelpers <> "\

90 \runJSaddleBatch = (function() {\n\

105 \runJSaddleBatch = (function() {\n\

91 \ " <> initState <> "\n\

106 \ " <> initState <> "\n\

92 \ return function(batch) {\n\

107 \ return function(batch) {\n\

93− \ " <> runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));") <> "\

108+ \ " <> runBatch (\a -> "window.webkit.messageHandlers.jsaddle.postMessage(JSON.stringify(" <> a <> "));\n")

109+ (Just (\a -> "JSON.parse(window.prompt(\"JSaddleSync\", JSON.stringify(" <> a <> ")))")) <> "\

94 \ };\n\

110 \ };\n\

95 \})();\n\

111 \})();\n\

96 \"

112 \"

jsaddle/src-ghc/JavaScript/Array/Internal.hs−2

@@ -21,8 +21,6 @@ import Data.JSString.Internal.Type (JSString(..))

21import Language.Javascript.JSaddle.Types (JSM, SomeJSArray(..), JSArray, MutableJSArray, STJSArray, Object(..), GHCJSPure(..))

22import Language.Javascript.JSaddle.Native.Internal

23 (newArray, getPropertyByName, getPropertyAtIndex, callAsFunction, valueToNumber)

24−import Language.Javascript.JSaddle.Run

25− (Command(..), Result(..), AsyncCommand(..), sendCommand, sendLazyCommand)

27create :: JSM MutableJSArray

25create :: JSM MutableJSArray

28create = SomeJSArray <$> newArray []

26create = SomeJSArray <$> newArray []

jsaddle/src/Language/Javascript/JSaddle/Native/Internal.hs+15−6

@@ -27,7 +27,8 @@ module Language.Javascript.JSaddle.Native.Internal (

27 , callAsFunction

28 , callAsConstructor

29 , newEmptyObject

30− , newCallback

30+ , newAsyncCallback

31+ , newSyncCallback

31 , newArray

32 , newArray

32 , evaluateScript

33 , evaluateScript

33 , deRefVal

34 , deRefVal

@@ -54,7 +55,7 @@ import Language.Javascript.JSaddle.Types

54 JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..))

55 JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..))

55import Language.Javascript.JSaddle.Monad (askJSM)

56import Language.Javascript.JSaddle.Monad (askJSM)

56import Language.Javascript.JSaddle.Run

57import Language.Javascript.JSaddle.Run

57− (Command(..), AsyncCommand(..), Result(..), sendCommand,

58+ (Command(..), Result(..), sendCommand,

58 sendAsyncCommand, sendLazyCommand, wrapJSVal)

59 sendAsyncCommand, sendLazyCommand, wrapJSVal)

60wrapJSString :: MonadIO m => JSStringReceived -> m JSString

61wrapJSString :: MonadIO m => JSStringReceived -> m JSString

@@ -136,13 +137,21 @@ newEmptyObject :: JSM Object

136newEmptyObject = Object <$> sendLazyCommand NewEmptyObject

137newEmptyObject = Object <$> sendLazyCommand NewEmptyObject

137{-# INLINE newEmptyObject #-}

138{-# INLINE newEmptyObject #-}

138

139

139−newCallback :: JSCallAsFunction -> JSM Object

140+newAsyncCallback :: JSCallAsFunction -> JSM Object

140−newCallback f = do

141+newAsyncCallback f = do

141− object <- Object <$> sendLazyCommand NewCallback

142+ object <- Object <$> sendLazyCommand NewAsyncCallback

142 add <- addCallback <$> askJSM

143 add <- addCallback <$> askJSM

143 liftIO $ add object f

144 liftIO $ add object f

144 return object

145 return object

145−{-# INLINE newCallback #-}

146+{-# INLINE newAsyncCallback #-}

147+

148+newSyncCallback :: JSCallAsFunction -> JSM Object

149+newSyncCallback f = do

150+ object <- Object <$> sendLazyCommand NewSyncCallback

151+ add <- addCallback <$> askJSM

152+ liftIO $ add object f

153+ return object

154+{-# INLINE newSyncCallback #-}

146

155

147newArray :: [JSVal] -> JSM JSVal

156newArray :: [JSVal] -> JSM JSVal

148newArray xs = withJSVals xs $ \xs' -> sendLazyCommand (NewArray xs')

157newArray xs = withJSVals xs $ \xs' -> sendLazyCommand (NewArray xs')

jsaddle/src/Language/Javascript/JSaddle/Object.hs+25−3

@@ -66,6 +66,7 @@ module Language.Javascript.JSaddle.Object (

66 -- * Calling Haskell From JavaScript

67 , Function(..)

68 , function

69+ , asyncFunction

69 , freeFunction

70 , freeFunction

70 , fun

71 , fun

71 , JSCallAsFunction

72 , JSCallAsFunction

@@ -115,7 +116,7 @@ import Language.Javascript.JSaddle.Types

115#else

116#else

116import GHCJS.Marshal.Internal (ToJSVal(..))

117import GHCJS.Marshal.Internal (ToJSVal(..))

117import Language.Javascript.JSaddle.Native

118import Language.Javascript.JSaddle.Native

118− (newCallback, callAsFunction, callAsConstructor)

119+ (newAsyncCallback, newSyncCallback, callAsFunction, callAsConstructor)

119import Language.Javascript.JSaddle.Monad (askJSM, JSM)

120import Language.Javascript.JSaddle.Monad (askJSM, JSM)

120import Language.Javascript.JSaddle.Types

121import Language.Javascript.JSaddle.Types

121 (JSString, Object(..), SomeJSArray(..),

122 (JSString, Object(..), SomeJSArray(..),

@@ -436,8 +437,10 @@ newtype Function = Function {functionObject :: Object}

436

437

438

438-- ^ Make a JavaScript function object that wraps a Haskell function.

439-- ^ Make a JavaScript function object that wraps a Haskell function.

440+-- Calls made to the function will be synchronous where possible

441+-- (on GHCJS it uses on `syncCallback2` with `ContinueAsync`).

439function :: JSCallAsFunction -- ^ Haskell function to call

442function :: JSCallAsFunction -- ^ Haskell function to call

440− -> JSM Function -- ^ Returns a JavaScript function object that will

443+ -> JSM Function -- ^ Returns a JavaScript function object that will

441 -- call the Haskell one when it is called

444 -- call the Haskell one when it is called

442#ifdef ghcjs_HOST_OS

445#ifdef ghcjs_HOST_OS

443function f = do

446function f = do

@@ -449,7 +452,26 @@ foreign import javascript unsafe "$r = function () { $1(this, arguments); }"

449 makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object

452 makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object

450#else

453#else

451function f = do

454function f = do

452− object <- newCallback f

455+ object <- newSyncCallback f

456+ return $ Function object

457+#endif

458+

459+-- ^ Make a JavaScript function object that wraps a Haskell function.

460+-- Calls made to the function will be Asynchronous.

461+asyncFunction :: JSCallAsFunction -- ^ Haskell function to call

462+ -> JSM Function -- ^ Returns a JavaScript function object that will

463+ -- call the Haskell one when it is called

464+#ifdef ghcjs_HOST_OS

465+asyncFunction f = do

466+ callback <- asyncCallback2 $ \this args -> do

467+ rargs <- Array.toListIO (coerce args)

468+ f this this rargs -- TODO pass function object through

469+ Function callback <$> makeFunctionWithCallback callback

470+foreign import javascript unsafe "$r = function () { $1(this, arguments); }"

471+ makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object

472+#else

473+asyncFunction f = do

474+ object <- newAsyncCallback f

453 return $ Function object

475 return $ Function object

454#endif

476#endif

455

477

jsaddle/src/Language/Javascript/JSaddle/Run.hs+56−23

@@ -49,7 +49,7 @@ import Control.Concurrent.STM.TChan

49import Control.Concurrent.STM.TVar

50 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)

51import Control.Concurrent.MVar

52− (MVar, MVar, putMVar, takeMVar, newEmptyMVar)

52+ (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar)

54import System.IO.Unsafe (unsafeInterleaveIO)

55import System.Mem.Weak (addFinalizer)

@@ -67,6 +67,8 @@ import Language.Javascript.JSaddle.Exception (JSException(..))

67-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)

68import Control.DeepSeq (deepseq)

69import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))

70+import Data.Maybe (isJust)

71+import Data.Foldable (forM_)

70#endif

72#endif

72-- | Enable (or disable) JSaddle logging

74-- | Enable (or disable) JSaddle logging

@@ -146,10 +148,12 @@ sendAsyncCommand cmd = do

146 s <- doSendAsyncCommand <$> JSM ask

148 s <- doSendAsyncCommand <$> JSM ask

147 liftIO $ s cmd

149 liftIO $ s cmd

148

150

149−runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ())

151+runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())

150runJavaScript sendBatch entryPoint = do

152runJavaScript sendBatch entryPoint = do

151 startTime' <- getCurrentTime

153 startTime' <- getCurrentTime

152 recvMVar <- newEmptyMVar

154 recvMVar <- newEmptyMVar

155+ syncSendBatch <- newEmptyMVar

156+ lastAsyncBatch <- newEmptyMVar

153 commandChan <- newTChanIO

157 commandChan <- newTChanIO

154 callbacks <- newTVarIO M.empty

158 callbacks <- newTVarIO M.empty

155 nextRef' <- newTVarIO 0

159 nextRef' <- newTVarIO 0

@@ -169,17 +173,39 @@ runJavaScript sendBatch entryPoint = do

169 , nextRef = nextRef'

173 , nextRef = nextRef'

170 , doEnableLogging = atomicWriteIORef loggingEnabled

174 , doEnableLogging = atomicWriteIORef loggingEnabled

171 }

175 }

172− let processResults = \case

176+ let processResults :: Bool -> Results -> IO ()

177+ processResults syncCallbacks = \case

173 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

178 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

174 (Callback f this a) -> do

179 (Callback f this a) -> do

175− logInfo ("Call " <>)

176 f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx

180 f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx

177 this' <- runReaderT (unJSM $ wrapJSVal this) ctx

181 this' <- runReaderT (unJSM $ wrapJSVal this) ctx

178 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx

182 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx

183+ logInfo (("Call " <> show fNumber <> " ") <>)

179 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case

184 (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case

180 Nothing -> liftIO $ putStrLn "Callback called after it was freed"

185 Nothing -> liftIO $ putStrLn "Callback called after it was freed"

186+ Just cb -> void . forkIO $ do

181− Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx

187+ runReaderT (unJSM $ cb f' this' args) ctx

188+ when syncCallbacks $ do

189+ doSendAsyncCommand ctx EndSyncBlock

190+ void $ doSendCommand ctx Sync

191+ Duplicate -> error "Error : Unexpected Duplicate"

182 m -> putMVar recvMVar m

192 m -> putMVar recvMVar m

193+ asyncResults :: Results -> IO ()

194+ asyncResults = processResults False

195+ syncResults :: Results -> IO Batch

196+ syncResults results = do

197+ existing <- tryTakeMVar syncSendBatch

198+ when (isJust existing) $ error "Error : Unexpected Sync Results"

199+ tryTakeMVar lastAsyncBatch >>= \case

200+ Just lastAsync -> processResults True results >> return lastAsync

201+ Nothing -> do

202+ nextBatch <- newEmptyMVar

203+ putMVar syncSendBatch (\batch -> do

204+ existing <- tryTakeMVar nextBatch

205+ when (isJust existing) $ error "Error : Unexpected Sync Results"

206+ putMVar nextBatch batch)

207+ processResults True results

208+ takeMVar nextBatch

183 logInfo s =

209 logInfo s =

184 readIORef loggingEnabled >>= \case

210 readIORef loggingEnabled >>= \case

185 True -> do

211 True -> do

@@ -189,23 +215,30 @@ runJavaScript sendBatch entryPoint = do

189 cbCount <- M.size <$> readTVarIO callbacks

215 cbCount <- M.size <$> readTVarIO callbacks

190 putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount

216 putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount

191 False -> return ()

217 False -> return ()

218+ _ <- forkIO . forM_ [1..] $ \nBatch ->

192− _ <- forkIO . forever $ readBatch commandChan >>= \case

219+ readBatch nBatch commandChan >>= \case

193− (batch@(Batch cmds _), resultMVars) -> do

220+ (batch@(Batch cmds _ _), resultMVars) -> do

194 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))

221 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))

222+ tryTakeMVar syncSendBatch >>= \case

223+ Just send -> send batch

224+ Nothing -> do

225+ putMVar lastAsyncBatch batch

195− sendBatch batch

226+ sendBatch batch

196− takeMVar recvMVar >>= \case

227+ takeMVar recvMVar >>= \r -> do

228+ _ <- tryTakeMVar lastAsyncBatch

229+ case r of

197− Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"

230+ Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"

198− | otherwise -> zipWithM_ putMVar resultMVars results

231+ | otherwise -> zipWithM_ putMVar resultMVars results

199− Failure results exception -> do

232+ Failure results exception -> do

200− -- The exception will only be rethrown in Haskell if/when one of the

233+ -- The exception will only be rethrown in Haskell if/when one of the

201− -- missing results (if any) is evaluated.

234+ -- missing results (if any) is evaluated.

202− putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"

235+ putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"

203− zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)

236+ zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)

204− _ -> error "Unexpected jsaddle results"

237+ _ -> error "Unexpected jsaddle results"

205− return (processResults, runReaderT (unJSM entryPoint) ctx)

238+ return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)

206 where

239 where

207− readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])

240+ readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])

208− readBatch chan = do

241+ readBatch nBatch chan = do

209 first <- atomically $ readTChan chan -- We want at least one command to send

242 first <- atomically $ readTChan chan -- We want at least one command to send

210 loop first ([], [])

243 loop first ([], [])

211 where

244 where

@@ -216,17 +249,17 @@ runJavaScript sendBatch entryPoint = do

216 let cmds = Right syncCmd:cmds'

249 let cmds = Right syncCmd:cmds'

217 resultMVars = resultMVar:resultMVars'

250 resultMVars = resultMVar:resultMVars'

218 atomically (tryReadTChan chan) >>= \case

251 atomically (tryReadTChan chan) >>= \case

219− Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)

252+ Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)

220 Just cmd -> loop cmd (cmds, resultMVars)

253 Just cmd -> loop cmd (cmds, resultMVars)

221 loop (Left asyncCmd) (cmds', resultMVars) = do

254 loop (Left asyncCmd) (cmds', resultMVars) = do

222 let cmds = Left asyncCmd:cmds'

255 let cmds = Left asyncCmd:cmds'

223 atomically (tryReadTChan chan) >>= \case

256 atomically (tryReadTChan chan) >>= \case

224− Nothing -> return (Batch (reverse cmds) False, reverse resultMVars)

257+ Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars)

225 Just cmd -> loop cmd (cmds, resultMVars)

258 Just cmd -> loop cmd (cmds, resultMVars)

226 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch

259 -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch

227 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])

260 loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])

228 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =

261 loopAnimation (Right (Sync, resultMVar)) (cmds, resultMVars) =

229− return (Batch (reverse (Right Sync:cmds)) True, reverse (resultMVar:resultMVars))

262+ return (Batch (reverse (Right Sync:cmds)) True nBatch, reverse (resultMVar:resultMVars))

230 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =

263 loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) =

231 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)

264 atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars)

232 loopAnimation (Left asyncCmd) (cmds, resultMVars) =

265 loopAnimation (Left asyncCmd) (cmds, resultMVars) =

jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+75−13

@@ -43,13 +43,20 @@ initState = "\

43 \ jsaddle_values.set(3, true);\n\

44 \ jsaddle_values.set(4, window);\n\

45 \ var jsaddle_index = 100;\n\

46+ \ var expectedBatch = 1;\n\

46 \"

47 \"

48−runBatch :: (ByteString -> ByteString) -> ByteString

49+runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString

49−runBatch send = "\

50+runBatch send sendSync = "\

51+ \ var runBatch = function(firstBatch, initialSyncDepth) {\n\

50 \ var processBatch = function(timestamp) {\n\

52 \ var processBatch = function(timestamp) {\n\

53+ \ var batch = firstBatch;\n\

51− \ var results = [];\n\

54+ \ var results = [];\n\

52− \ try {\n\

55+ \ try {\n\

56+ \ syncDepth = initialSyncDepth || 0;\n\

57+ \ for(;;){\n\

58+ \ if(batch[2] === expectedBatch) {\n\

59+ \ expectedBatch++;\n\

53 \ var nCommandsLength = batch[0].length;\n\

60 \ var nCommandsLength = batch[0].length;\n\

54 \ for (var nCommand = 0; nCommand != nCommandsLength; nCommand++) {\n\

61 \ for (var nCommand = 0; nCommand != nCommandsLength; nCommand++) {\n\

55 \ var cmd = batch[0][nCommand];\n\

62 \ var cmd = batch[0][nCommand];\n\

@@ -89,7 +96,7 @@ runBatch send = "\

89 \ var n = d.contents;\n\

96 \ var n = d.contents;\n\

90 \ jsaddle_values.set(n, {});\n\

97 \ jsaddle_values.set(n, {});\n\

91 \ break;\n\

98 \ break;\n\

92− \ case \"NewCallback\":\n\

99+ \ case \"NewAsyncCallback\":\n\

93 \ (function() {\n\

100 \ (function() {\n\

94 \ var nFunction = d.contents;\n\

101 \ var nFunction = d.contents;\n\

95 \ jsaddle_values.set(nFunction, function() {\n\

102 \ jsaddle_values.set(nFunction, function() {\n\

@@ -104,6 +111,26 @@ runBatch send = "\

104 \ " <> send "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> "\n\

111 \ " <> send "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> "\n\

105 \ })})();\n\

112 \ })})();\n\

106 \ break;\n\

113 \ break;\n\

114+ \ case \"NewSyncCallback\":\n\

115+ \ (function() {\n\

116+ \ var nFunction = d.contents;\n\

117+ \ jsaddle_values.set(nFunction, function() {\n\

118+ \ var nThis = ++jsaddle_index;\n\

119+ \ jsaddle_values.set(nThis, this);\n\

120+ \ var args = [];\n\

121+ \ for (var i = 0; i != arguments.length; i++) {\n\

122+ \ var nArg = ++jsaddle_index;\n\

123+ \ jsaddle_values.set(nArg, arguments[i]);\n\

124+ \ args[i] = nArg;\n\

125+ \ }\n" <> (

126+ case sendSync of

127+ Just s ->

128+ " runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> ", 1);\n"

129+ Nothing ->

130+ " " <> send "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> "\n"

131+ ) <>

132+ " })})();\n\

133+ \ break;\n\

107 \ case \"CallAsFunction\":\n\

134 \ case \"CallAsFunction\":\n\

108 \ var n = d.contents[3];\n\

135 \ var n = d.contents[3];\n\

109 \ jsaddle_values.set(n,\n\

136 \ jsaddle_values.set(n,\n\

@@ -148,6 +175,12 @@ runBatch send = "\

148 \ var n = d.contents[0];\n\

175 \ var n = d.contents[0];\n\

149 \ jsaddle_values.set(n, timestamp);\n\

176 \ jsaddle_values.set(n, timestamp);\n\

150 \ break;\n\

177 \ break;\n\

178+ \ case \"StartSyncBlock\":\n\

179+ \ syncDepth++;\n\

180+ \ break;\n\

181+ \ case \"EndSyncBlock\":\n\

182+ \ syncDepth--;\n\

183+ \ break;\n\

151 \ default:\n\

184 \ default:\n\

152 \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\

185 \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\

153 \ return;\n\

186 \ return;\n\

@@ -210,20 +243,49 @@ runBatch send = "\

210 \ }\n\

243 \ }\n\

211 \ }\n\

244 \ }\n\

212 \ }\n\

245 \ }\n\

246+ \ if(syncDepth === 0) {\n\

213− \ " <> send "{\"tag\": \"Success\", \"contents\": results}" <> "\n\

247+ \ " <> send "{\"tag\": \"Success\", \"contents\": results}" <> "\n\

214− \ }\n\

248+ \ break;\n\

215− \ catch (err) {\n\

249+ \ } else {\n" <> (

216− \ var n = ++jsaddle_index;\n\

250+ case sendSync of

217− \ jsaddle_values.set(n, err);\n\

251+ Just s ->

218− \ " <> send "{\"tag\": \"Failure\", \"contents\": [results,n]}" <> "\n\

252+ " batch = " <> s "{\"tag\": \"Success\", \"contents\": results}" <> "\n\

253+ \ results = [];\n"

254+ Nothing ->

255+ " " <> send "{\"tag\": \"Success\", \"contents\": results}" <> "\n\

256+ \ break;\n"

257+ ) <>

258+ " }\n\

259+ \ } else {\n\

260+ \ if(syncDepth === 0) {\n\

261+ \ break;\n\

262+ \ } else {\n" <> (

263+ case sendSync of

264+ Just s ->

265+ " batch = " <> s "{\"tag\": \"Duplicate\"}" <> "\n\

266+ \ results = [];\n"

267+ Nothing ->

268+ " " <> send "{\"tag\": \"Duplicate\"}" <> "\n\

269+ \ break;\n"

270+ ) <>

271+ " }\n\

272+ \ }\n\

219 \ }\n\

273 \ }\n\

274+ \ }\n\

275+ \ catch (err) {\n\

276+ \ var n = ++jsaddle_index;\n\

277+ \ jsaddle_values.set(n, err);\n\

278+ \ " <> send "{\"tag\": \"Failure\", \"contents\": [results,n]}" <> "\n\

279+ \ }\n\

220 \ };\n\

280 \ };\n\

221− \ if(batch[1]) {\n\

281+ \ if(batch[1] && (initialSyncDepth || 0) === 0) {\n\

222 \ window.requestAnimationFrame(processBatch);\n\

282 \ window.requestAnimationFrame(processBatch);\n\

223 \ }\n\

283 \ }\n\

224 \ else {\n\

284 \ else {\n\

225 \ processBatch(window.performance ? window.performance.now() : null);\n\

285 \ processBatch(window.performance ? window.performance.now() : null);\n\

226 \ }\n\

286 \ }\n\

287+ \ };\n\

288+ \ runBatch(batch);\n\

227 \"

289 \"

228

290

229-- Use this to generate this string for embedding

291-- Use this to generate this string for embedding

@@ -249,7 +311,7 @@ jsaddleJs = "\

249 \ ws.onmessage = function(e) {\n\

311 \ ws.onmessage = function(e) {\n\

250 \ var batch = JSON.parse(e.data);\n\

312 \ var batch = JSON.parse(e.data);\n\

251 \\n\

313 \\n\

252− \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));") <> "\

314+ \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));") Nothing <> "\

253 \ };\n\

315 \ };\n\

254 \ };\n\

316 \ };\n\

255 \ ws.onerror = function() {\n\

317 \ ws.onerror = function() {\n\

jsaddle/src/Language/Javascript/JSaddle/Types.hs+7−3

@@ -315,11 +315,14 @@ data AsyncCommand = FreeRef JSValueForSend

315 | CallAsFunction JSObjectForSend JSObjectForSend [JSValueForSend] JSValueForSend

316 | CallAsConstructor JSObjectForSend [JSValueForSend] JSValueForSend

317 | NewEmptyObject JSValueForSend

318+ | NewAsyncCallback JSValueForSend

318− | NewCallback JSValueForSend

319+ | NewSyncCallback JSValueForSend

319 | NewArray [JSValueForSend] JSValueForSend

320 | NewArray [JSValueForSend] JSValueForSend

320 | EvaluateScript JSStringForSend JSValueForSend

321 | EvaluateScript JSStringForSend JSValueForSend

321 | SyncWithAnimationFrame JSValueForSend

322 | SyncWithAnimationFrame JSValueForSend

323+ | StartSyncBlock

324+ | EndSyncBlock

322− deriving (Show, Generic)

325+ deriving (Show, Generic)

323

326

324instance ToJSON AsyncCommand where

327instance ToJSON AsyncCommand where

325 toEncoding = genericToEncoding defaultOptions

328 toEncoding = genericToEncoding defaultOptions

@@ -351,7 +354,7 @@ instance FromJSON Command

351instance NFData Command

354instance NFData Command

352

355

353-- | Batch of commands that can be sent together to the JavaScript context

356-- | Batch of commands that can be sent together to the JavaScript context

354−data Batch = Batch [Either AsyncCommand Command] Bool

357+data Batch = Batch [Either AsyncCommand Command] Bool Int

355 deriving (Show, Generic)

358 deriving (Show, Generic)

356

359

357instance ToJSON Batch where

360instance ToJSON Batch where

@@ -384,6 +387,7 @@ instance FromJSON Result

384

387

385data Results = Success [Result]

388data Results = Success [Result]

386 | Failure [Result] JSValueReceived

389 | Failure [Result] JSValueReceived

390+ | Duplicate

387 | Callback JSValueReceived JSValueReceived [JSValueReceived]

391 | Callback JSValueReceived JSValueReceived [JSValueReceived]

388 | ProtocolError Text

392 | ProtocolError Text

389 deriving (Show, Generic)

393 deriving (Show, Generic)