git.iko.soy/jsaddle
on master help sign in
Sync callback support in jsaddle-clib
commit623c4e23159cc54463408fb9a60727b403ffee9c authorHamish Mackenzie <Hamish.K.Mackenzie@googlemail.com> dateSat 27 May 2017, 13:13 (9 years ago) parent16fedc5
4 files changed+20−6
compare with master
unifiedsplit
jsaddle-clib/cbits/include/jsaddle.h+1 jsaddle-clib/jsaddle-clib.cabal+1−1 jsaddle-clib/src-ghc/Language/Javascript/JSaddle/CLib.hs+15−5 jsaddle-clib/src/Language/Javascript/JSaddle/CLib/Internal.hsc+3
jsaddle-clib/cbits/include/jsaddle.h+1
@@ -4,6 +4,7 @@
44typedef struct native_callbacks {
55 void (* jsaddleStart) ();
66 void (* jsaddleResult) (char *);
7+ char * (* jsaddleSyncResult) (char *);
78 char * jsaddleJsData;
89 char * jsaddleHtmlData;
910} native_callbacks;
jsaddle-clib/jsaddle-clib.cabal+1−1
@@ -24,7 +24,7 @@ library
2424 aeson >=0.8.0.2 && <1.3,
2525 base <5,
2626 bytestring >=0.10.6.0 && <0.11,
27− jsaddle >= 0.9.0.0 && <0.10
27+ jsaddle >= 0.9.0.0 && <0.10,
2828 data-default,
2929 text
3030 default-language: Haskell2010
jsaddle-clib/src-ghc/Language/Javascript/JSaddle/CLib.hs+15−5
@@ -40,23 +40,32 @@ foreign import ccall safe "wrapper"
4040foreign import ccall safe "wrapper"
4141 wrapMessageCallback :: (CString -> IO ()) -> IO (FunPtr (CString -> IO ()))
4242
43+foreign import ccall safe "wrapper"
44+ wrapSyncCallback :: (CString -> IO CString) -> IO (FunPtr (CString -> IO CString))
45+
4346jsaddleInit :: JSM () -> FunPtr (CString -> IO ()) -> IO (Ptr NativeCallbacks)
4447jsaddleInit jsm evaluateJavascriptAsyncPtr = do
4548 let evaluateJavascriptAsync = mkCallback evaluateJavascriptAsyncPtr
46− (processResult, _, start) <- runJavaScript (\batch ->
47− useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $
49+ (processResult, processSyncResult, start) <- runJavaScript (\batch ->
50+ useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");")
4851 evaluateJavascriptAsync) jsm
49− jsaddleStartPtr <- wrapStartCallback $ void $ forkIO $ start
52+ jsaddleStartPtr <- wrapStartCallback $ void $ forkIO start
5053 jsaddleResultPtr <- wrapMessageCallback $ \s -> do
5154 result <- decode . fromStrict <$> packCString s
5255 case result of
5356 Nothing -> error $ "jsaddle message decode failed: " <> show result
5457 Just r -> processResult r
58+ jsaddleSyncResultPtr <- wrapSyncCallback $ \s -> do
59+ result <- decode . fromStrict <$> packCString s
60+ case result of
61+ Nothing -> error $ "jsaddle message decode failed: " <> show result
62+ Just r -> newCString =<< unpack . toStrict . encode <$> processSyncResult r
5563 jsaddleJsPtr <- newCString $ unpack $ toStrict jsaddleJs
5664 jsaddleHtmlPtr <- newCString $ unpack $ toStrict indexHtml
57− new $ NativeCallbacks
65+ new NativeCallbacks
5866 { _nativeCallbacks_jsaddleStart = jsaddleStartPtr
5967 , _nativeCallbacks_jsaddleResult = jsaddleResultPtr
68+ , _nativeCallbacks_jsaddleSyncResult = jsaddleSyncResultPtr
6069 , _nativeCallbacks_jsaddleJsData = jsaddleJsPtr
6170 , _nativeCallbacks_jsaddleHtmlData = jsaddleHtmlPtr
6271 }
@@ -115,7 +124,8 @@ jsaddleJs = ghcjsHelpers <> "\
115124 \runJSaddleBatch = (function() {\n\
116125 \ " <> initState <> "\n\
117126 \ return function(batch) {\n\
118− \ " <> runBatch (\a -> "jsaddle.postMessage(JSON.stringify(" <> a <> "));") Nothing <> "\
127+ \ " <> runBatch (\a -> "jsaddle.postMessage(JSON.stringify(" <> a <> "));")
128+ (Just (\a -> "JSON.parse(jsaddle.syncMessage(JSON.stringify(" <> a <> ")))")) <> "\
119129 \ };\n\
120130 \})();\n\
121131 \jsaddle.postReady();\n"
jsaddle-clib/src/Language/Javascript/JSaddle/CLib/Internal.hsc+3
@@ -9,6 +9,7 @@ import Foreign.C
99data NativeCallbacks = NativeCallbacks
1010 { _nativeCallbacks_jsaddleStart :: !(FunPtr (IO ())) -- void (jsaddleStart *)()
1111 , _nativeCallbacks_jsaddleResult :: !(FunPtr (CString -> IO ())) -- void (jsaddleResult *)(char *)
12+ , _nativeCallbacks_jsaddleSyncResult :: !(FunPtr (CString -> IO CString)) -- char * (jsaddleSyncResult *)(char *)
1213 , _nativeCallbacks_jsaddleJsData :: !CString -- char * jsaddleJsData
1314 , _nativeCallbacks_jsaddleHtmlData :: !CString -- char * jsaddleHtmlData
1415 }
@@ -19,11 +20,13 @@ instance Storable NativeCallbacks where
1920 poke p nc = do
2021 #{poke native_callbacks, jsaddleStart} p $ _nativeCallbacks_jsaddleStart nc
2122 #{poke native_callbacks, jsaddleResult} p $ _nativeCallbacks_jsaddleResult nc
23+ #{poke native_callbacks, jsaddleSyncResult} p $ _nativeCallbacks_jsaddleSyncResult nc
2224 #{poke native_callbacks, jsaddleJsData} p $ _nativeCallbacks_jsaddleJsData nc
2325 #{poke native_callbacks, jsaddleHtmlData} p $ _nativeCallbacks_jsaddleHtmlData nc
2426 peek p = NativeCallbacks
2527 <$> #{peek native_callbacks, jsaddleStart} p
2628 <*> #{peek native_callbacks, jsaddleResult} p
29+ <*> #{peek native_callbacks, jsaddleSyncResult} p
2730 <*> #{peek native_callbacks, jsaddleJsData} p
2831 <*> #{peek native_callbacks, jsaddleHtmlData} p
2932