{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-} module Language.Javascript.JSaddle.CLib ( jsaddleInit , NativeCallbacks (..) , AppCallbacks (..) , AppConfig (..) , pokeAppConfig , appConfigToAppCallbacks ) where import Prelude () import Prelude.Compat import Control.Monad (void) import Control.Concurrent (forkIO) import Data.Aeson (encode, decode) import Data.ByteString (useAsCString, packCString) import Data.ByteString.Char8 (unpack) import Data.ByteString.Lazy (ByteString, toStrict, fromStrict) import Data.Default (def, Default) import Data.Text (Text) import qualified Data.Text.Encoding as T import Foreign.C.String (CString, newCString) import Foreign.Ptr (FunPtr, Ptr) import Foreign.Storable (poke) import Foreign.Marshal.Utils (new) import Language.Javascript.JSaddle (JSM) import Language.Javascript.JSaddle.Run (runJavaScript) import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers) import Language.Javascript.JSaddle.CLib.Internal foreign import ccall safe "dynamic" mkCallback :: FunPtr (CString -> IO ()) -> CString -> IO () foreign import ccall safe "wrapper" wrapStartCallback :: IO () -> IO (FunPtr (IO ())) foreign import ccall safe "wrapper" wrapMessageCallback :: (CString -> IO ()) -> IO (FunPtr (CString -> IO ())) foreign import ccall safe "wrapper" wrapMessageCallback2 :: (CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ())) foreign import ccall safe "wrapper" wrapSyncCallback :: (CString -> IO CString) -> IO (FunPtr (CString -> IO CString)) jsaddleInit :: JSM () -> FunPtr (CString -> IO ()) -> IO (Ptr NativeCallbacks) jsaddleInit :: JSM () -> FunPtr (CString -> IO ()) -> IO (Ptr NativeCallbacks) jsaddleInit JSM () jsm FunPtr (CString -> IO ()) evaluateJavascriptAsyncPtr = do let evaluateJavascriptAsync :: CString -> IO () evaluateJavascriptAsync = FunPtr (CString -> IO ()) -> CString -> IO () mkCallback FunPtr (CString -> IO ()) evaluateJavascriptAsyncPtr (Results -> IO () processResult, Results -> IO Batch processSyncResult, IO () start) <- (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ()) runJavaScript (\Batch batch -> forall a. ByteString -> (CString -> IO a) -> IO a useAsCString (ByteString -> ByteString toStrict forall a b. (a -> b) -> a -> b $ ByteString "runJSaddleBatch(" forall a. Semigroup a => a -> a -> a <> forall a. ToJSON a => a -> ByteString encode Batch batch forall a. Semigroup a => a -> a -> a <> ByteString ");") CString -> IO () evaluateJavascriptAsync) JSM () jsm FunPtr (IO ()) jsaddleStartPtr <- IO () -> IO (FunPtr (IO ())) wrapStartCallback forall a b. (a -> b) -> a -> b $ forall (f :: * -> *) a. Functor f => f a -> f () void forall a b. (a -> b) -> a -> b $ IO () -> IO ThreadId forkIO IO () start FunPtr (CString -> IO ()) jsaddleResultPtr <- (CString -> IO ()) -> IO (FunPtr (CString -> IO ())) wrapMessageCallback forall a b. (a -> b) -> a -> b $ \CString s -> do Maybe Results result <- forall a. FromJSON a => ByteString -> Maybe a decode forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> ByteString fromStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> CString -> IO ByteString packCString CString s case Maybe Results result of Maybe Results Nothing -> forall a. HasCallStack => [Char] -> a error forall a b. (a -> b) -> a -> b $ [Char] "jsaddle message decode failed: " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> [Char] show Maybe Results result Just Results r -> Results -> IO () processResult Results r FunPtr (CString -> IO CString) jsaddleSyncResultPtr <- (CString -> IO CString) -> IO (FunPtr (CString -> IO CString)) wrapSyncCallback forall a b. (a -> b) -> a -> b $ \CString s -> do Maybe Results result <- forall a. FromJSON a => ByteString -> Maybe a decode forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> ByteString fromStrict forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> CString -> IO ByteString packCString CString s case Maybe Results result of Maybe Results Nothing -> forall a. HasCallStack => [Char] -> a error forall a b. (a -> b) -> a -> b $ [Char] "jsaddle message decode failed: " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> [Char] show Maybe Results result Just Results r -> [Char] -> IO CString newCString forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< ByteString -> [Char] unpack forall b c a. (b -> c) -> (a -> b) -> a -> c . ByteString -> ByteString toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. ToJSON a => a -> ByteString encode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Results -> IO Batch processSyncResult Results r CString jsaddleJsPtr <- [Char] -> IO CString newCString forall a b. (a -> b) -> a -> b $ ByteString -> [Char] unpack forall a b. (a -> b) -> a -> b $ ByteString -> ByteString toStrict ByteString jsaddleJs CString jsaddleHtmlPtr <- [Char] -> IO CString newCString forall a b. (a -> b) -> a -> b $ ByteString -> [Char] unpack forall a b. (a -> b) -> a -> b $ ByteString -> ByteString toStrict ByteString indexHtml forall a. Storable a => a -> IO (Ptr a) new NativeCallbacks { _nativeCallbacks_jsaddleStart :: FunPtr (IO ()) _nativeCallbacks_jsaddleStart = FunPtr (IO ()) jsaddleStartPtr , _nativeCallbacks_jsaddleResult :: FunPtr (CString -> IO ()) _nativeCallbacks_jsaddleResult = FunPtr (CString -> IO ()) jsaddleResultPtr , _nativeCallbacks_jsaddleSyncResult :: FunPtr (CString -> IO CString) _nativeCallbacks_jsaddleSyncResult = FunPtr (CString -> IO CString) jsaddleSyncResultPtr , _nativeCallbacks_jsaddleJsData :: CString _nativeCallbacks_jsaddleJsData = CString jsaddleJsPtr , _nativeCallbacks_jsaddleHtmlData :: CString _nativeCallbacks_jsaddleHtmlData = CString jsaddleHtmlPtr } data AppConfig = AppConfig { AppConfig -> IO () _appConfig_mainActivityOnCreate :: IO () , AppConfig -> IO () _appConfig_mainActivityOnStart :: IO () , AppConfig -> IO () _appConfig_mainActivityOnResume :: IO () , AppConfig -> IO () _appConfig_mainActivityOnPause :: IO () , AppConfig -> IO () _appConfig_mainActivityOnStop :: IO () , AppConfig -> IO () _appConfig_mainActivityOnDestroy :: IO () , AppConfig -> IO () _appConfig_mainActivityOnRestart :: IO () , AppConfig -> Text -> Text -> IO () _appConfig_mainActivityOnNewIntent :: (Text -> Text -> IO ()) , AppConfig -> Text -> IO () _appConfig_firebaseInstanceIdServiceSendRegistrationToServer :: Text -> IO () } instance Default AppConfig where def :: AppConfig def = AppConfig { _appConfig_mainActivityOnCreate :: IO () _appConfig_mainActivityOnCreate = forall (m :: * -> *) a. Monad m => a -> m a return () , _appConfig_mainActivityOnStart :: IO () _appConfig_mainActivityOnStart = forall (m :: * -> *) a. Monad m => a -> m a return () , _appConfig_mainActivityOnResume :: IO () _appConfig_mainActivityOnResume = forall (m :: * -> *) a. Monad m => a -> m a return () , _appConfig_mainActivityOnPause :: IO () _appConfig_mainActivityOnPause = forall (m :: * -> *) a. Monad m => a -> m a return () , _appConfig_mainActivityOnStop :: IO () _appConfig_mainActivityOnStop = forall (m :: * -> *) a. Monad m => a -> m a return () , _appConfig_mainActivityOnDestroy :: IO () _appConfig_mainActivityOnDestroy = forall (m :: * -> *) a. Monad m => a -> m a return () , _appConfig_mainActivityOnRestart :: IO () _appConfig_mainActivityOnRestart = forall (m :: * -> *) a. Monad m => a -> m a return () , _appConfig_mainActivityOnNewIntent :: Text -> Text -> IO () _appConfig_mainActivityOnNewIntent = \Text _ Text _ -> forall (m :: * -> *) a. Monad m => a -> m a return () , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer :: Text -> IO () _appConfig_firebaseInstanceIdServiceSendRegistrationToServer = \Text _ -> forall (m :: * -> *) a. Monad m => a -> m a return () } appConfigToAppCallbacks :: AppConfig -> IO AppCallbacks appConfigToAppCallbacks :: AppConfig -> IO AppCallbacks appConfigToAppCallbacks AppConfig c = do FunPtr (IO ()) create <- IO () -> IO (FunPtr (IO ())) wrapStartCallback forall a b. (a -> b) -> a -> b $ AppConfig -> IO () _appConfig_mainActivityOnCreate AppConfig c FunPtr (IO ()) start <- IO () -> IO (FunPtr (IO ())) wrapStartCallback forall a b. (a -> b) -> a -> b $ AppConfig -> IO () _appConfig_mainActivityOnStart AppConfig c FunPtr (IO ()) resume <- IO () -> IO (FunPtr (IO ())) wrapStartCallback forall a b. (a -> b) -> a -> b $ AppConfig -> IO () _appConfig_mainActivityOnResume AppConfig c FunPtr (IO ()) pause <- IO () -> IO (FunPtr (IO ())) wrapStartCallback forall a b. (a -> b) -> a -> b $ AppConfig -> IO () _appConfig_mainActivityOnPause AppConfig c FunPtr (IO ()) stop <- IO () -> IO (FunPtr (IO ())) wrapStartCallback forall a b. (a -> b) -> a -> b $ AppConfig -> IO () _appConfig_mainActivityOnStop AppConfig c FunPtr (IO ()) destroy <- IO () -> IO (FunPtr (IO ())) wrapStartCallback forall a b. (a -> b) -> a -> b $ AppConfig -> IO () _appConfig_mainActivityOnDestroy AppConfig c FunPtr (IO ()) restart <- IO () -> IO (FunPtr (IO ())) wrapStartCallback forall a b. (a -> b) -> a -> b $ AppConfig -> IO () _appConfig_mainActivityOnRestart AppConfig c FunPtr (CString -> CString -> IO ()) newIntent <- (CString -> CString -> IO ()) -> IO (FunPtr (CString -> CString -> IO ())) wrapMessageCallback2 forall a b. (a -> b) -> a -> b $ \CString intentAction CString intentData -> do Text intentAction' <- CString -> IO Text fromUtf8CString CString intentAction Text intentData' <- CString -> IO Text fromUtf8CString CString intentData AppConfig -> Text -> Text -> IO () _appConfig_mainActivityOnNewIntent AppConfig c Text intentAction' Text intentData' FunPtr (CString -> IO ()) firebaseRegPtr <- (CString -> IO ()) -> IO (FunPtr (CString -> IO ())) wrapMessageCallback forall a b. (a -> b) -> a -> b $ \CString token -> do Text token' <- CString -> IO Text fromUtf8CString CString token AppConfig -> Text -> IO () _appConfig_firebaseInstanceIdServiceSendRegistrationToServer AppConfig c Text token' forall (m :: * -> *) a. Monad m => a -> m a return forall a b. (a -> b) -> a -> b $ AppCallbacks { _appCallbacks_mainActivity_onCreate :: FunPtr (IO ()) _appCallbacks_mainActivity_onCreate = FunPtr (IO ()) create , _appCallbacks_mainActivity_onStart :: FunPtr (IO ()) _appCallbacks_mainActivity_onStart = FunPtr (IO ()) start , _appCallbacks_mainActivity_onResume :: FunPtr (IO ()) _appCallbacks_mainActivity_onResume = FunPtr (IO ()) resume , _appCallbacks_mainActivity_onPause :: FunPtr (IO ()) _appCallbacks_mainActivity_onPause = FunPtr (IO ()) pause , _appCallbacks_mainActivity_onStop :: FunPtr (IO ()) _appCallbacks_mainActivity_onStop = FunPtr (IO ()) stop , _appCallbacks_mainActivity_onDestroy :: FunPtr (IO ()) _appCallbacks_mainActivity_onDestroy = FunPtr (IO ()) destroy , _appCallbacks_mainActivity_onRestart :: FunPtr (IO ()) _appCallbacks_mainActivity_onRestart = FunPtr (IO ()) restart , _appCallbacks_mainActivity_onNewIntent :: FunPtr (CString -> CString -> IO ()) _appCallbacks_mainActivity_onNewIntent = FunPtr (CString -> CString -> IO ()) newIntent , _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer :: FunPtr (CString -> IO ()) _appCallbacks_firebaseInstanceIdService_sendRegistrationToServer = FunPtr (CString -> IO ()) firebaseRegPtr } fromUtf8CString :: CString -> IO Text fromUtf8CString :: CString -> IO Text fromUtf8CString = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ByteString -> Text T.decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c . CString -> IO ByteString packCString pokeAppConfig :: Ptr AppCallbacks -> AppConfig -> IO () pokeAppConfig :: Ptr AppCallbacks -> AppConfig -> IO () pokeAppConfig Ptr AppCallbacks ptr AppConfig cfg = forall a. Storable a => Ptr a -> a -> IO () poke Ptr AppCallbacks ptr forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b =<< AppConfig -> IO AppCallbacks appConfigToAppCallbacks AppConfig cfg jsaddleJs :: ByteString jsaddleJs :: ByteString jsaddleJs = ByteString ghcjsHelpers forall a. Semigroup a => a -> a -> a <> ByteString "\ \runJSaddleBatch = (function() {\n\ \ " forall a. Semigroup a => a -> a -> a <> ByteString initState forall a. Semigroup a => a -> a -> a <> ByteString "\n\ \ return function(batch) {\n\ \ " forall a. Semigroup a => a -> a -> a <> (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString runBatch (\ByteString a -> ByteString "jsaddle.postMessage(JSON.stringify(" forall a. Semigroup a => a -> a -> a <> ByteString a forall a. Semigroup a => a -> a -> a <> ByteString "));") (forall a. a -> Maybe a Just (\ByteString a -> ByteString "JSON.parse(jsaddle.syncMessage(JSON.stringify(" forall a. Semigroup a => a -> a -> a <> ByteString a forall a. Semigroup a => a -> a -> a <> ByteString ")))")) forall a. Semigroup a => a -> a -> a <> ByteString "\ \ };\n\ \})();\n\ \jsaddle.postReady();\n" indexHtml :: ByteString indexHtml :: ByteString indexHtml = ByteString "<!DOCTYPE html>\n\ \<html>\n\ \<head>\n\ \<title>JSaddle</title>\n\ \</head>\n\ \<body>\n\ \</body>\n\ \</html>"