{-# 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>"