@@ -0,0 +1,106 @@
1+{-# LANGUAGE ForeignFunctionInterface #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Reflex.Dom.Android.MainWidget
4+ ( startMainWidget
5+ ) where
6+
7+import Android.HaskellActivity
8+import Control.Concurrent
9+import Control.Monad
10+import Data.Aeson
11+import Data.ByteString (ByteString)
12+import qualified Data.ByteString as BS
13+import qualified Data.ByteString.Lazy as LBS
14+import Data.IORef
15+import Data.Monoid
16+import Foreign.C.String
17+import Foreign.Marshal.Utils
18+import Foreign.Ptr
19+import Foreign.Storable
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+#include "MainWidget.h"
25+
26+
27+startMainWidget :: HaskellActivity -> ByteString -> JSM () -> IO ()
28+startMainWidget a url jsm = do
29+ --TODO: Find a way to eventually release this
30+ executorRef <- newIORef $ error "startMainWidget: executor not created yet"
31+ let go batch = do
32+ executor <- readIORef executorRef
33+ BS.useAsCString (LBS.toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $ \cstr -> do
34+ runJS executor cstr
35+ (processResult, processSyncResult, start) <- runJavaScript go jsm
36+ callbacks <- new <=< jsaddleCallbacksToPtrs $ JSaddleCallbacks
37+ { _jsaddleCallbacks_jsaddleStart = void $ forkIO start
38+ , _jsaddleCallbacks_jsaddleResult = \s -> do
39+ case decode $ LBS.fromStrict s of
40+ Nothing -> error $ "jsaddle message decode failed: " <> show s
41+ Just r -> processResult r
42+ , _jsaddleCallbacks_jsaddleSyncResult = \s -> do
43+ case decode $ LBS.fromStrict s of
44+ Nothing -> error $ "jsaddle message decode failed: " <> show s
45+ Just r -> LBS.toStrict . encode <$> processSyncResult r
46+ , _jsaddleCallbacks_jsaddleJsData = LBS.toStrict $ ghcjsHelpers <> "\
47+ \runJSaddleBatch = (function() {\n\
48+ \ " <> initState <> "\n\
49+ \ return function(batch) {\n\
50+ \ " <> runBatch (\a -> "jsaddle.postMessage(JSON.stringify(" <> a <> "));")
51+ (Just (\a -> "JSON.parse(jsaddle.syncMessage(JSON.stringify(" <> a <> ")))")) <> "\
52+ \ };\n\
53+ \})();\n\
54+ \jsaddle.postReady();\n"
55+ }
56+ BS.useAsCString url $ \curl -> do
57+ writeIORef executorRef =<< startMainWidget_ a curl callbacks
58+
59+newtype JSExecutor = JSExecutor { unJSExecutor :: Ptr JSExecutor }
60+
61+foreign import ccall safe "Reflex_Dom_Android_MainWidget_start" startMainWidget_ :: HaskellActivity -> CString -> Ptr JSaddleCallbacksPtrs -> IO JSExecutor
62+
63+foreign import ccall safe "Reflex_Dom_Android_MainWidget_runJS" runJS :: JSExecutor -> CString -> IO ()
64+
65+data JSaddleCallbacks = JSaddleCallbacks
66+ { _jsaddleCallbacks_jsaddleStart :: IO ()
67+ , _jsaddleCallbacks_jsaddleResult :: ByteString -> IO ()
68+ , _jsaddleCallbacks_jsaddleSyncResult :: ByteString -> IO ByteString
69+ , _jsaddleCallbacks_jsaddleJsData :: ByteString
70+ }
71+
72+data JSaddleCallbacksPtrs = JSaddleCallbacksPtrs
73+ { _jsaddleCallbacksPtrs_jsaddleStart :: !(FunPtr (IO ()))
74+ , _jsaddleCallbacksPtrs_jsaddleResult :: !(FunPtr (CString -> IO ()))
75+ , _jsaddleCallbacksPtrs_jsaddleSyncResult :: !(FunPtr (CString -> IO CString))
76+ , _jsaddleCallbacksPtrs_jsaddleJsData :: !CString
77+ }
78+
79+foreign import ccall "wrapper" wrapIO :: IO () -> IO (FunPtr (IO ()))
80+foreign import ccall "wrapper" wrapCStringIO :: (CString -> IO ()) -> IO (FunPtr (CString -> IO ()))
81+foreign import ccall "wrapper" wrapCStringIOCString :: (CString -> IO CString) -> IO (FunPtr (CString -> IO CString))
82+
83+--TODO: Get rid of the extra copy step
84+newCStringFromByteString :: ByteString -> IO CString
85+newCStringFromByteString bs = BS.useAsCString bs $ newCString <=< peekCString
86+
87+jsaddleCallbacksToPtrs :: JSaddleCallbacks -> IO JSaddleCallbacksPtrs
88+jsaddleCallbacksToPtrs jc = JSaddleCallbacksPtrs
89+ <$> wrapIO (_jsaddleCallbacks_jsaddleStart jc)
90+ <*> wrapCStringIO (\cstr -> _jsaddleCallbacks_jsaddleResult jc =<< BS.packCString cstr)
91+ <*> wrapCStringIOCString (\cstr -> newCStringFromByteString =<< _jsaddleCallbacks_jsaddleSyncResult jc =<< BS.packCString cstr)
92+ <*> newCStringFromByteString (_jsaddleCallbacks_jsaddleJsData jc)
93+
94+instance Storable JSaddleCallbacksPtrs where
95+ sizeOf _ = #{size JSaddleCallbacks}
96+ alignment _ = #{alignment JSaddleCallbacks}
97+ poke p jc = do
98+ #{poke JSaddleCallbacks, jsaddleStart} p $ _jsaddleCallbacksPtrs_jsaddleStart jc
99+ #{poke JSaddleCallbacks, jsaddleResult} p $ _jsaddleCallbacksPtrs_jsaddleResult jc
100+ #{poke JSaddleCallbacks, jsaddleSyncResult} p $ _jsaddleCallbacksPtrs_jsaddleSyncResult jc
101+ #{poke JSaddleCallbacks, jsaddleJsData} p $ _jsaddleCallbacksPtrs_jsaddleJsData jc
102+ peek p = JSaddleCallbacksPtrs
103+ <$> #{peek JSaddleCallbacks, jsaddleStart} p
104+ <*> #{peek JSaddleCallbacks, jsaddleResult} p
105+ <*> #{peek JSaddleCallbacks, jsaddleSyncResult} p
106+ <*> #{peek JSaddleCallbacks, jsaddleJsData} p