{-# 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 ->
    ByteString -> (CString -> IO ()) -> IO ()
forall a. ByteString -> (CString -> IO a) -> IO a
useAsCString (ByteString -> ByteString
toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
"runJSaddleBatch(" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Batch -> ByteString
forall a. ToJSON a => a -> ByteString
encode Batch
batch ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
");")
      CString -> IO ()
evaluateJavascriptAsync) JSM ()
jsm
  FunPtr (IO ())
jsaddleStartPtr <- IO () -> IO (FunPtr (IO ()))
wrapStartCallback (IO () -> IO (FunPtr (IO ()))) -> IO () -> IO (FunPtr (IO ()))
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO IO ()
start
  FunPtr (CString -> IO ())
jsaddleResultPtr <- (CString -> IO ()) -> IO (FunPtr (CString -> IO ()))
wrapMessageCallback ((CString -> IO ()) -> IO (FunPtr (CString -> IO ())))
-> (CString -> IO ()) -> IO (FunPtr (CString -> IO ()))
forall a b. (a -> b) -> a -> b
$ \CString
s -> do
    Maybe Results
result <- ByteString -> Maybe Results
forall a. FromJSON a => ByteString -> Maybe a
decode (ByteString -> Maybe Results)
-> (ByteString -> ByteString) -> ByteString -> Maybe Results
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict (ByteString -> Maybe Results)
-> IO ByteString -> IO (Maybe Results)
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 -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"jsaddle message decode failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe Results -> [Char]
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 ((CString -> IO CString) -> IO (FunPtr (CString -> IO CString)))
-> (CString -> IO CString) -> IO (FunPtr (CString -> IO CString))
forall a b. (a -> b) -> a -> b
$ \CString
s -> do
    Maybe Results
result <- ByteString -> Maybe Results
forall a. FromJSON a => ByteString -> Maybe a
decode (ByteString -> Maybe Results)
-> (ByteString -> ByteString) -> ByteString -> Maybe Results
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
fromStrict (ByteString -> Maybe Results)
-> IO ByteString -> IO (Maybe Results)
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 -> [Char] -> IO CString
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO CString) -> [Char] -> IO CString
forall a b. (a -> b) -> a -> b
$ [Char]
"jsaddle message decode failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Maybe Results -> [Char]
forall a. Show a => a -> [Char]
show Maybe Results
result
      Just Results
r -> [Char] -> IO CString
newCString ([Char] -> IO CString) -> IO [Char] -> IO CString
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ByteString -> [Char]
unpack (ByteString -> [Char]) -> (Batch -> ByteString) -> Batch -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict (ByteString -> ByteString)
-> (Batch -> ByteString) -> Batch -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Batch -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Batch -> [Char]) -> IO Batch -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Results -> IO Batch
processSyncResult Results
r
  CString
jsaddleJsPtr <- [Char] -> IO CString
newCString ([Char] -> IO CString) -> [Char] -> IO CString
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
unpack (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict ByteString
jsaddleJs
  CString
jsaddleHtmlPtr <- [Char] -> IO CString
newCString ([Char] -> IO CString) -> [Char] -> IO CString
forall a b. (a -> b) -> a -> b
$ ByteString -> [Char]
unpack (ByteString -> [Char]) -> ByteString -> [Char]
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict ByteString
indexHtml
  NativeCallbacks -> IO (Ptr NativeCallbacks)
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 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , _appConfig_mainActivityOnStart :: IO ()
_appConfig_mainActivityOnStart = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , _appConfig_mainActivityOnResume :: IO ()
_appConfig_mainActivityOnResume = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , _appConfig_mainActivityOnPause :: IO ()
_appConfig_mainActivityOnPause = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , _appConfig_mainActivityOnStop :: IO ()
_appConfig_mainActivityOnStop = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , _appConfig_mainActivityOnDestroy :: IO ()
_appConfig_mainActivityOnDestroy = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , _appConfig_mainActivityOnRestart :: IO ()
_appConfig_mainActivityOnRestart = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , _appConfig_mainActivityOnNewIntent :: Text -> Text -> IO ()
_appConfig_mainActivityOnNewIntent = \Text
_ Text
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    , _appConfig_firebaseInstanceIdServiceSendRegistrationToServer :: Text -> IO ()
_appConfig_firebaseInstanceIdServiceSendRegistrationToServer = \Text
_ -> () -> IO ()
forall a. a -> IO a
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 (IO () -> IO (FunPtr (IO ()))) -> IO () -> IO (FunPtr (IO ()))
forall a b. (a -> b) -> a -> b
$ AppConfig -> IO ()
_appConfig_mainActivityOnCreate AppConfig
c
  FunPtr (IO ())
start <- IO () -> IO (FunPtr (IO ()))
wrapStartCallback (IO () -> IO (FunPtr (IO ()))) -> IO () -> IO (FunPtr (IO ()))
forall a b. (a -> b) -> a -> b
$ AppConfig -> IO ()
_appConfig_mainActivityOnStart AppConfig
c
  FunPtr (IO ())
resume <- IO () -> IO (FunPtr (IO ()))
wrapStartCallback (IO () -> IO (FunPtr (IO ()))) -> IO () -> IO (FunPtr (IO ()))
forall a b. (a -> b) -> a -> b
$ AppConfig -> IO ()
_appConfig_mainActivityOnResume AppConfig
c
  FunPtr (IO ())
pause <- IO () -> IO (FunPtr (IO ()))
wrapStartCallback (IO () -> IO (FunPtr (IO ()))) -> IO () -> IO (FunPtr (IO ()))
forall a b. (a -> b) -> a -> b
$ AppConfig -> IO ()
_appConfig_mainActivityOnPause AppConfig
c
  FunPtr (IO ())
stop <- IO () -> IO (FunPtr (IO ()))
wrapStartCallback (IO () -> IO (FunPtr (IO ()))) -> IO () -> IO (FunPtr (IO ()))
forall a b. (a -> b) -> a -> b
$ AppConfig -> IO ()
_appConfig_mainActivityOnStop AppConfig
c
  FunPtr (IO ())
destroy <- IO () -> IO (FunPtr (IO ()))
wrapStartCallback (IO () -> IO (FunPtr (IO ()))) -> IO () -> IO (FunPtr (IO ()))
forall a b. (a -> b) -> a -> b
$ AppConfig -> IO ()
_appConfig_mainActivityOnDestroy AppConfig
c
  FunPtr (IO ())
restart <- IO () -> IO (FunPtr (IO ()))
wrapStartCallback (IO () -> IO (FunPtr (IO ()))) -> IO () -> IO (FunPtr (IO ()))
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 ((CString -> CString -> IO ())
 -> IO (FunPtr (CString -> CString -> IO ())))
-> (CString -> CString -> IO ())
-> IO (FunPtr (CString -> CString -> IO ()))
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 ((CString -> IO ()) -> IO (FunPtr (CString -> IO ())))
-> (CString -> IO ()) -> IO (FunPtr (CString -> IO ()))
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'
  AppCallbacks -> IO AppCallbacks
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AppCallbacks -> IO AppCallbacks)
-> AppCallbacks -> IO AppCallbacks
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 = (ByteString -> Text) -> IO ByteString -> IO Text
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
T.decodeUtf8 (IO ByteString -> IO Text)
-> (CString -> IO ByteString) -> CString -> IO Text
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 = Ptr AppCallbacks -> AppCallbacks -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr AppCallbacks
ptr (AppCallbacks -> IO ()) -> IO AppCallbacks -> IO ()
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 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\
    \runJSaddleBatch = (function() {\n\
    \ " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
initState ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n\
    \ return function(batch) {\n\
    \ " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> (ByteString -> ByteString)
-> Maybe (ByteString -> ByteString) -> ByteString
runBatch (\ByteString
a -> ByteString
"jsaddle.postMessage(JSON.stringify(" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
a ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"));")
              ((ByteString -> ByteString) -> Maybe (ByteString -> ByteString)
forall a. a -> Maybe a
Just (\ByteString
a -> ByteString
"JSON.parse(jsaddle.syncMessage(JSON.stringify(" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
a ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
")))")) ByteString -> ByteString -> 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>"