@@ -0,0 +1,75 @@
1+{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}
2+module Language.Javascript.JSaddle.CLib
3+ ( jsaddleInit
4+ , NativeCallbacks (..)
5+ ) where
6+
7+import Control.Monad (void)
8+import Control.Concurrent (forkIO)
9+
10+import Data.Monoid ((<>))
11+import Data.ByteString (useAsCString, packCString)
12+import Data.ByteString.Unsafe (unsafeUseAsCString)
13+import Data.ByteString.Lazy (ByteString, toStrict, fromStrict)
14+import Data.Aeson (encode, decode)
15+
16+import Foreign.C.String (CString)
17+import Foreign.Ptr (FunPtr, Ptr)
18+import Foreign.Marshal.Utils (new)
19+
20+import Language.Javascript.JSaddle (JSM)
21+import Language.Javascript.JSaddle.Run (runJavaScript)
22+import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers)
23+
24+import Language.Javascript.JSaddle.CLib.Internal
25+
26+foreign import ccall "dynamic"
27+ mkCallback :: FunPtr (CString -> IO ()) -> CString -> IO ()
28+
29+foreign import ccall "wrapper"
30+ wrapStartCallback :: IO () -> IO (FunPtr (IO ()))
31+
32+foreign import ccall "wrapper"
33+ wrapMessageCallback :: (CString -> IO ()) -> IO (FunPtr (CString -> IO ()))
34+
35+jsaddleInit :: JSM () -> FunPtr (CString -> IO ()) -> IO (Ptr NativeCallbacks)
36+jsaddleInit jsm evaluateJavascriptAsyncPtr = do
37+ let evaluateJavascriptAsync = mkCallback evaluateJavascriptAsyncPtr
38+ (processResult, start) <- runJavaScript (\batch ->
39+ useAsCString (toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $
40+ evaluateJavascriptAsync) jsm
41+ jsaddleStartPtr <- wrapStartCallback $ void $ forkIO start
42+ jsaddleResultPtr <- wrapMessageCallback $ \s -> do
43+ result <- decode . fromStrict <$> packCString s
44+ case result of
45+ Nothing -> error $ "jsaddle message decode failed: " <> show result
46+ Just r -> processResult r
47+ unsafeUseAsCString (toStrict jsaddleJs) $ \jsaddleJsData ->
48+ unsafeUseAsCString (toStrict indexHtml) $ \jsaddleHtmlData -> new $
49+ NativeCallbacks
50+ { _nativeCallbacks_jsaddleStart = jsaddleStartPtr
51+ , _nativeCallbacks_jsaddleResult = jsaddleResultPtr
52+ , _nativeCallbacks_jsaddleJsData = jsaddleJsData
53+ , _nativeCallbacks_jsaddleHtmlData = jsaddleHtmlData
54+ }
55+
56+jsaddleJs :: ByteString
57+jsaddleJs = ghcjsHelpers <> "\
58+ \runJSaddleBatch = (function() {\n\
59+ \ " <> initState <> "\n\
60+ \ return function(batch) {\n\
61+ \ " <> runBatch (\a -> "jsaddle.postMessage(JSON.stringify(" <> a <> "));") <> "\
62+ \ };\n\
63+ \})();\n\
64+ \\0"
65+
66+indexHtml :: ByteString
67+indexHtml =
68+ "<!DOCTYPE html>\n\
69+ \<html>\n\
70+ \<head>\n\
71+ \<title>JSaddle</title>\n\
72+ \</head>\n\
73+ \<body>\n\
74+ \</body>\n\
75+ \</html>\0"