{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Language.JavaScript.Inline.Core.Instruction where

import Control.Concurrent.STM
import Control.Exception
import Data.Binary.Get
import qualified Data.ByteString.Lazy as LBS
import Data.Proxy
import Foreign
import Language.JavaScript.Inline.Core.Class
import Language.JavaScript.Inline.Core.Dict
import Language.JavaScript.Inline.Core.Export
import Language.JavaScript.Inline.Core.JSVal
import Language.JavaScript.Inline.Core.Message
import Language.JavaScript.Inline.Core.Session
import Language.JavaScript.Inline.Core.Utils
import System.Directory
import System.IO.Unsafe

evalWithDecoder ::
  RawJSType ->
  (Session -> LBS.ByteString -> IO a) ->
  Session ->
  JSExpr ->
  IO a
evalWithDecoder :: RawJSType
-> (Session -> ByteString -> IO a) -> Session -> JSExpr -> IO a
evalWithDecoder RawJSType
_return_type Session -> ByteString -> IO a
_decoder _session :: Session
_session@Session {IO ()
TMVar (Either SomeException ByteString)
IPC
killSession :: Session -> IO ()
closeSession :: Session -> IO ()
fatalErrorInbox :: Session -> TMVar (Either SomeException ByteString)
ipc :: Session -> IPC
killSession :: IO ()
closeSession :: IO ()
fatalErrorInbox :: TMVar (Either SomeException ByteString)
ipc :: IPC
..} JSExpr
_code = do
  TMVar (Either SomeException ByteString)
_inbox <- IO (TMVar (Either SomeException ByteString))
forall a. IO (TMVar a)
newEmptyTMVarIO
  StablePtr (TMVar (Either SomeException ByteString))
_sp <- TMVar (Either SomeException ByteString)
-> IO (StablePtr (TMVar (Either SomeException ByteString)))
forall a. a -> IO (StablePtr a)
newStablePtr TMVar (Either SomeException ByteString)
_inbox
  let _id :: Word64
_id = StablePtr (TMVar (Either SomeException ByteString)) -> Word64
forall a. StablePtr a -> Word64
word64FromStablePtr StablePtr (TMVar (Either SomeException ByteString))
_sp
  Session -> MessageHS -> IO ()
sessionSend
    Session
_session
    JSEvalRequest :: Word64 -> JSExpr -> RawJSType -> MessageHS
JSEvalRequest
      { jsEvalRequestId :: Word64
jsEvalRequestId = Word64
_id,
        code :: JSExpr
code = JSExpr
_code,
        returnType :: RawJSType
returnType = RawJSType
_return_type
      }
  JSExpr -> IO ()
forall a. a -> IO ()
touch JSExpr
_code
  IO a -> IO a
forall a. IO a -> IO a
unsafeInterleaveIO (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    Either SomeException ByteString
_resp <- STM (Either SomeException ByteString)
-> IO (Either SomeException ByteString)
forall a. STM a -> IO a
atomically (STM (Either SomeException ByteString)
 -> IO (Either SomeException ByteString))
-> STM (Either SomeException ByteString)
-> IO (Either SomeException ByteString)
forall a b. (a -> b) -> a -> b
$ TMVar (Either SomeException ByteString)
-> STM (Either SomeException ByteString)
forall a. TMVar a -> STM a
takeTMVar TMVar (Either SomeException ByteString)
_inbox STM (Either SomeException ByteString)
-> STM (Either SomeException ByteString)
-> STM (Either SomeException ByteString)
forall a. STM a -> STM a -> STM a
`orElse` TMVar (Either SomeException ByteString)
-> STM (Either SomeException ByteString)
forall a. TMVar a -> STM a
readTMVar TMVar (Either SomeException ByteString)
fatalErrorInbox
    StablePtr (TMVar (Either SomeException ByteString)) -> IO ()
forall a. StablePtr a -> IO ()
freeStablePtr StablePtr (TMVar (Either SomeException ByteString))
_sp
    case Either SomeException ByteString
_resp of
      Left SomeException
err -> SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeException
err
      Right ByteString
_result_buf -> Session -> ByteString -> IO a
_decoder Session
_session ByteString
_result_buf

-- | Evaluate a 'JSExpr' and return the result. Evaluation is /asynchronous/.
-- When this function returns, the eval request has been sent to the eval
-- server, but the result may not be sent back yet. The returned value is a
-- thunk, and forcing it to WHNF will block until the result is sent back.
--
-- The caveats of lazy I/O apply here as well. For instance, returning
-- evaluation result from a @with@-style function may cause a use-after-free
-- problem. In case when it's desirable to ensure the evaluation has completed
-- at a certain point, use 'Control.Exception.evaluate' or @BangPatterns@ to
-- force the result value.
--
-- Modeling asynchronousity with laziness enables us to simplify API. Users can
-- easily regain strictness from the lazy API; if we do it the other way around
-- and provide strict-by-default eval functions, we'll need to explicitly
-- decouple sending of eval requests and receiving of eval results, which
-- complicates the API.
--
-- On the eval server side, the result value is @await@ed before further
-- processing. Therefore if it's a @Promise@, the eval result will be the
-- resolved value instead of the @Promise@ itself. If the @Promise@ value needs
-- to be returned, wrap it in another object (e.g. a single-element array).
eval :: forall a. FromJS a => Session -> JSExpr -> IO a
eval :: Session -> JSExpr -> IO a
eval Session
s JSExpr
c =
  RawJSType
-> (Session -> ByteString -> IO a) -> Session -> JSExpr -> IO a
forall a.
RawJSType
-> (Session -> ByteString -> IO a) -> Session -> JSExpr -> IO a
evalWithDecoder (Proxy a -> RawJSType
forall a. FromJS a => Proxy a -> RawJSType
rawJSType (Proxy a
forall k (t :: k). Proxy t
Proxy @a)) Session -> ByteString -> IO a
forall a. FromJS a => Session -> ByteString -> IO a
fromJS Session
s (JSExpr -> IO a) -> JSExpr -> IO a
forall a b. (a -> b) -> a -> b
$
    JSExpr
"((x, f) => (Boolean(x) && typeof x.then === 'function') ? x.then(f) : f(x))("
      JSExpr -> JSExpr -> JSExpr
forall a. Semigroup a => a -> a -> a
<> JSExpr
c
      JSExpr -> JSExpr -> JSExpr
forall a. Semigroup a => a -> a -> a
<> JSExpr
", "
      JSExpr -> JSExpr -> JSExpr
forall a. Semigroup a => a -> a -> a
<> Proxy a -> JSExpr
forall a. FromJS a => Proxy a -> JSExpr
toRawJSType (Proxy a
forall k (t :: k). Proxy t
Proxy @a)
      JSExpr -> JSExpr -> JSExpr
forall a. Semigroup a => a -> a -> a
<> JSExpr
")"

-- | Import a CommonJS module file and return its @module.exports@ object. The
-- module file path can be absolute, or relative to the current Haskell process.
-- The imported module will be retained in the @require()@ loader cache.
importCJS :: Session -> FilePath -> IO JSVal
importCJS :: Session -> FilePath -> IO JSVal
importCJS Session
s FilePath
p = do
  FilePath
p' <- FilePath -> IO FilePath
makeAbsolute FilePath
p
  Session -> JSExpr -> IO JSVal
forall a. FromJS a => Session -> JSExpr -> IO a
eval Session
s (JSExpr -> IO JSVal) -> JSExpr -> IO JSVal
forall a b. (a -> b) -> a -> b
$ JSExpr
"require(" JSExpr -> JSExpr -> JSExpr
forall a. Semigroup a => a -> a -> a
<> FilePath -> JSExpr
string FilePath
p' JSExpr -> JSExpr -> JSExpr
forall a. Semigroup a => a -> a -> a
<> JSExpr
")"

-- | Import an ECMAScript module file and return its module namespace object.
-- The module file path can be absolute, or relative to the current Haskell
-- process. The imported module will be retained in the ESM loader cache.
importMJS :: Session -> FilePath -> IO JSVal
importMJS :: Session -> FilePath -> IO JSVal
importMJS Session
s FilePath
p = do
  FilePath
p' <- FilePath -> IO FilePath
makeAbsolute FilePath
p
  Session -> JSExpr -> IO JSVal
forall a. FromJS a => Session -> JSExpr -> IO a
eval Session
s (JSExpr -> IO JSVal) -> JSExpr -> IO JSVal
forall a b. (a -> b) -> a -> b
$
    JSExpr
"import('url').then(url => import(url.pathToFileURL("
      JSExpr -> JSExpr -> JSExpr
forall a. Semigroup a => a -> a -> a
<> FilePath -> JSExpr
string FilePath
p'
      JSExpr -> JSExpr -> JSExpr
forall a. Semigroup a => a -> a -> a
<> JSExpr
")))"

string :: String -> JSExpr
string :: FilePath -> JSExpr
string = EncodedString -> JSExpr
forall a. ToJS a => a -> JSExpr
toJS (EncodedString -> JSExpr)
-> (FilePath -> EncodedString) -> FilePath -> JSExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> EncodedString
EncodedString (ByteString -> EncodedString)
-> (FilePath -> ByteString) -> FilePath -> EncodedString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ByteString
stringToLBS

exportAsyncOrSync :: forall f. Export f => Bool -> Session -> f -> IO JSVal
exportAsyncOrSync :: Bool -> Session -> f -> IO JSVal
exportAsyncOrSync Bool
_is_sync _session :: Session
_session@Session {IO ()
TMVar (Either SomeException ByteString)
IPC
killSession :: IO ()
closeSession :: IO ()
fatalErrorInbox :: TMVar (Either SomeException ByteString)
ipc :: IPC
killSession :: Session -> IO ()
closeSession :: Session -> IO ()
fatalErrorInbox :: Session -> TMVar (Either SomeException ByteString)
ipc :: Session -> IPC
..} f
f = do
  TMVar (Either SomeException ByteString)
_inbox <- IO (TMVar (Either SomeException ByteString))
forall a. IO (TMVar a)
newEmptyTMVarIO
  let args_type :: [(JSExpr, RawJSType)]
args_type =
        (Dict FromJS -> (JSExpr, RawJSType))
-> [Dict FromJS] -> [(JSExpr, RawJSType)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Dict Proxy a
p) -> (Proxy a -> JSExpr
forall a. FromJS a => Proxy a -> JSExpr
toRawJSType Proxy a
p, Proxy a -> RawJSType
forall a. FromJS a => Proxy a -> RawJSType
rawJSType Proxy a
p)) ([Dict FromJS] -> [(JSExpr, RawJSType)])
-> [Dict FromJS] -> [(JSExpr, RawJSType)]
forall a b. (a -> b) -> a -> b
$
          Proxy f -> [Dict FromJS]
forall f. Export f => Proxy f -> [Dict FromJS]
exportArgsFromJS (Proxy f
forall k (t :: k). Proxy t
Proxy @f)
      f' :: [ByteString] -> IO JSExpr
f' = Session -> f -> [ByteString] -> IO JSExpr
forall f. Export f => Session -> f -> [ByteString] -> IO JSExpr
exportMonomorphize Session
_session f
f
  StablePtr (TMVar (Either SomeException ByteString))
_sp_inbox <- TMVar (Either SomeException ByteString)
-> IO (StablePtr (TMVar (Either SomeException ByteString)))
forall a. a -> IO (StablePtr a)
newStablePtr TMVar (Either SomeException ByteString)
_inbox
  StablePtr ([ByteString] -> IO JSExpr)
_sp_f <- ([ByteString] -> IO JSExpr)
-> IO (StablePtr ([ByteString] -> IO JSExpr))
forall a. a -> IO (StablePtr a)
newStablePtr [ByteString] -> IO JSExpr
f'
  let _id_inbox :: Word64
_id_inbox = StablePtr (TMVar (Either SomeException ByteString)) -> Word64
forall a. StablePtr a -> Word64
word64FromStablePtr StablePtr (TMVar (Either SomeException ByteString))
_sp_inbox
      _id_f :: Word64
_id_f = StablePtr ([ByteString] -> IO JSExpr) -> Word64
forall a. StablePtr a -> Word64
word64FromStablePtr StablePtr ([ByteString] -> IO JSExpr)
_sp_f
  Session -> MessageHS -> IO ()
sessionSend
    Session
_session
    HSExportRequest :: Bool -> Word64 -> Word64 -> [(JSExpr, RawJSType)] -> MessageHS
HSExportRequest
      { exportIsSync :: Bool
exportIsSync = Bool
_is_sync,
        exportRequestId :: Word64
exportRequestId = Word64
_id_inbox,
        exportFuncId :: Word64
exportFuncId = Word64
_id_f,
        argsType :: [(JSExpr, RawJSType)]
argsType = [(JSExpr, RawJSType)]
args_type
      }
  IO JSVal -> IO JSVal
forall a. IO a -> IO a
unsafeInterleaveIO (IO JSVal -> IO JSVal) -> IO JSVal -> IO JSVal
forall a b. (a -> b) -> a -> b
$ do
    Either SomeException ByteString
_resp <- STM (Either SomeException ByteString)
-> IO (Either SomeException ByteString)
forall a. STM a -> IO a
atomically (STM (Either SomeException ByteString)
 -> IO (Either SomeException ByteString))
-> STM (Either SomeException ByteString)
-> IO (Either SomeException ByteString)
forall a b. (a -> b) -> a -> b
$ TMVar (Either SomeException ByteString)
-> STM (Either SomeException ByteString)
forall a. TMVar a -> STM a
takeTMVar TMVar (Either SomeException ByteString)
_inbox STM (Either SomeException ByteString)
-> STM (Either SomeException ByteString)
-> STM (Either SomeException ByteString)
forall a. STM a -> STM a -> STM a
`orElse` TMVar (Either SomeException ByteString)
-> STM (Either SomeException ByteString)
forall a. TMVar a -> STM a
readTMVar TMVar (Either SomeException ByteString)
fatalErrorInbox
    StablePtr (TMVar (Either SomeException ByteString)) -> IO ()
forall a. StablePtr a -> IO ()
freeStablePtr StablePtr (TMVar (Either SomeException ByteString))
_sp_inbox
    case Either SomeException ByteString
_resp of
      Left SomeException
err -> SomeException -> IO JSVal
forall e a. Exception e => e -> IO a
throwIO SomeException
err
      Right ByteString
_jsval_id_buf -> do
        Word64
_jsval_id <- Get Word64 -> ByteString -> IO Word64
forall a. Typeable a => Get a -> ByteString -> IO a
runGetExact Get Word64
getWord64host ByteString
_jsval_id_buf
        Bool -> Word64 -> IO () -> IO JSVal
newJSVal Bool
False Word64
_jsval_id (IO () -> IO JSVal) -> IO () -> IO JSVal
forall a b. (a -> b) -> a -> b
$ do
          StablePtr ([ByteString] -> IO JSExpr) -> IO ()
forall a. StablePtr a -> IO ()
freeStablePtr StablePtr ([ByteString] -> IO JSExpr)
_sp_f
          Session -> MessageHS -> IO ()
sessionSend Session
_session (MessageHS -> IO ()) -> MessageHS -> IO ()
forall a b. (a -> b) -> a -> b
$ Word64 -> MessageHS
JSValFree Word64
_jsval_id

-- | Export a Haskell function as a JavaScript async function, and return its
-- 'JSVal'. Some points to keep in mind:
--
-- * The Haskell function itself can call into JavaScript again via 'eval', and
--   vice versa.
-- * When called in JavaScript, the Haskell function is run in a forked thread.
-- * If the Haskell function throws, the JavaScript function will reject with an
--   @Error@ with the exception string.
-- * Unlike 'JSVal's returned by 'eval', 'JSVal's returned by 'export' are not
--   garbage collected, since we don't know when a function is garbage collected
--   on the @node@ side. These 'JSVal's need to be manually freed using
--   'freeJSVal'.
export :: Export f => Session -> f -> IO JSVal
export :: Session -> f -> IO JSVal
export = Bool -> Session -> f -> IO JSVal
forall f. Export f => Bool -> Session -> f -> IO JSVal
exportAsyncOrSync Bool
False

-- | Export a Haskell function as a JavaScript sync function. This is quite
-- heavyweight and in most cases, 'export' is preferrable. 'exportSync' can be
-- useful in certain scenarios when a sync function is desired, e.g. converting
-- a Haskell function to a WebAssembly import.
--
-- Unlike 'export', 'exportSync' has limited reentrancy:
--
-- * The Haskell function may calculate the return value based on the result of
--   calling into JavaScript again, but only synchronous code is supported in
--   this case.
-- * The exported JavaScript sync function must not invoke other exported
--   JavaScript sync functions, either directly or indirectly(Haskell calling
--   into JavaScript again).
exportSync :: Export f => Session -> f -> IO JSVal
exportSync :: Session -> f -> IO JSVal
exportSync = Bool -> Session -> f -> IO JSVal
forall f. Export f => Bool -> Session -> f -> IO JSVal
exportAsyncOrSync Bool
True