{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
-----------------------------------------------------------------------------
--
-- Module      :  Language.Javascript.JSaddle.Run
-- Copyright   :  (c) Hamish Mackenzie
-- License     :  MIT
--
-- Maintainer  :  Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>
--
-- |
--
-----------------------------------------------------------------------------

module Language.Javascript.JSaddle.Run (
  -- * Running JSM
    syncPoint
  , syncAfter
  , waitForAnimationFrame
  , nextAnimationFrame
  , enableLogging
#ifndef ghcjs_HOST_OS
  -- * Functions used to implement JSaddle using JSON messaging
  , runJavaScript
  , AsyncCommand(..)
  , Command(..)
  , Result(..)
  , sendCommand
  , sendLazyCommand
  , sendAsyncCommand
  , wrapJSVal
#endif
) where

import Prelude ()
import Prelude.Compat

#ifdef ghcjs_HOST_OS
import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter)
import qualified JavaScript.Web.AnimationFrame as GHCJS
       (waitForAnimationFrame)
#else
import Control.Exception (throwIO, evaluate)
import Control.Monad (void, when, zipWithM_)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans.Reader (ask, runReaderT)
import Control.Monad.STM (atomically)
import Control.Concurrent (forkIO, myThreadId)
import Control.Concurrent.STM.TChan
       (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO)
import Control.Concurrent.STM.TVar
       (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
import Control.Concurrent.MVar
       (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)

import System.IO.Unsafe (unsafeInterleaveIO)
import System.Random

import GHC.Base (IO(..), mkWeak#)
import GHC.Conc (ThreadId(..))
import qualified Data.Text as T (unpack, pack)
import qualified Data.Map as M (lookup, delete, insert, empty, size)
import qualified Data.Set as S (empty, member, insert, delete)
import Data.Time.Clock (getCurrentTime,diffUTCTime)
import Data.IORef
       (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)

import Language.Javascript.JSaddle.Types
       (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
        Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)
import Language.Javascript.JSaddle.Exception (JSException(..))
import Control.DeepSeq (deepseq)
#if MIN_VERSION_base(4,11,0)
import GHC.Stats (getRTSStatsEnabled, getRTSStats, RTSStats(..), gcdetails_live_bytes, gc)
#else
import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))
#endif
import Data.Foldable (forM_)
#endif

-- | Enable (or disable) JSaddle logging
enableLogging :: Bool -> JSM ()
#ifdef ghcjs_HOST_OS
enableLogging _ = return ()
#else
enableLogging :: Bool -> JSM ()
enableLogging Bool
v = do
    f <- JSContextRef -> Bool -> IO ()
doEnableLogging (JSContextRef -> Bool -> IO ())
-> JSM JSContextRef -> JSM (Bool -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT JSContextRef IO JSContextRef -> JSM JSContextRef
forall a. ReaderT JSContextRef IO a -> JSM a
JSM ReaderT JSContextRef IO JSContextRef
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    liftIO $ f v
#endif

-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.
--   On GHC it will delay the execution of the current batch of asynchronous
--   command when they are sent to JavaScript.  It will not delay the Haskell
--   code execution.  The time returned will be based on the Haskell clock
--   (not the JavaScript clock).
waitForAnimationFrame :: JSM Double
#ifdef ghcjs_HOST_OS
waitForAnimationFrame = GHCJS.waitForAnimationFrame
#else
waitForAnimationFrame :: JSM Double
waitForAnimationFrame = do
    -- We can't get the timestamp from requestAnimationFrame so this will have to do
    start <- JSContextRef -> UTCTime
startTime (JSContextRef -> UTCTime) -> JSM JSContextRef -> JSM UTCTime
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT JSContextRef IO JSContextRef -> JSM JSContextRef
forall a. ReaderT JSContextRef IO a -> JSM a
JSM ReaderT JSContextRef IO JSContextRef
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    now <- liftIO getCurrentTime
    void $ sendLazyCommand SyncWithAnimationFrame
    return $ realToFrac (diffUTCTime now start)
#endif

-- | Tries to executes the given code in the next animation frame callback.
--   Avoid synchronous opperations where possible.
nextAnimationFrame :: (Double -> JSM a) -> JSM a
nextAnimationFrame :: forall a. (Double -> JSM a) -> JSM a
nextAnimationFrame Double -> JSM a
f = do
    t <- JSM Double
waitForAnimationFrame
    syncAfter (f t)

#ifndef ghcjs_HOST_OS
sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
sendLazyCommand JSValueForSend -> AsyncCommand
cmd = do
    nextRefTVar <- JSContextRef -> TVar JSValueRef
nextRef (JSContextRef -> TVar JSValueRef)
-> JSM JSContextRef -> JSM (TVar JSValueRef)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT JSContextRef IO JSContextRef -> JSM JSContextRef
forall a. ReaderT JSContextRef IO a -> JSM a
JSM ReaderT JSContextRef IO JSContextRef
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    n <- liftIO . atomically $ do
        n <- subtract 1 <$> readTVar nextRefTVar
        writeTVar nextRefTVar $! n
        return n
    s <- doSendAsyncCommand <$> JSM ask
    liftIO $ s (cmd $ JSValueForSend n)
    wrapJSVal (JSValueReceived n)

sendAsyncCommand :: AsyncCommand -> JSM ()
sendAsyncCommand :: AsyncCommand -> JSM ()
sendAsyncCommand AsyncCommand
cmd = do
    s <- JSContextRef -> AsyncCommand -> IO ()
doSendAsyncCommand (JSContextRef -> AsyncCommand -> IO ())
-> JSM JSContextRef -> JSM (AsyncCommand -> IO ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT JSContextRef IO JSContextRef -> JSM JSContextRef
forall a. ReaderT JSContextRef IO a -> JSM a
JSM ReaderT JSContextRef IO JSContextRef
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    liftIO $ s cmd

runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
runJavaScript :: (Batch -> IO ())
-> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())
runJavaScript Batch -> IO ()
sendBatch JSM ()
entryPoint = do
    contextId' <- IO JSValueRef
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
    startTime' <- getCurrentTime
    recvMVar <- newEmptyMVar
    lastAsyncBatch <- newEmptyMVar
    commandChan <- newTChanIO
    callbacks <- newTVarIO M.empty
    nextRef' <- newTVarIO 0
    finalizerThreads' <- newMVar S.empty
    animationFrameHandlers' <- newMVar []
    loggingEnabled <- newIORef False
    liveRefs' <- newMVar S.empty
    let ctx = JSContextRef {
            contextId :: JSValueRef
contextId = JSValueRef
contextId'
          , startTime :: UTCTime
startTime = UTCTime
startTime'
          , doSendCommand :: Command -> IO Result
doSendCommand = \Command
cmd -> Command
cmd Command -> IO Result -> IO Result
forall a b. NFData a => a -> b -> b
`deepseq` do
                result <- IO (MVar Result)
forall a. IO (MVar a)
newEmptyMVar
                atomically $ writeTChan commandChan (Right (cmd, result))
                unsafeInterleaveIO $
                    takeMVar result >>= \case
                        (ThrowJSValue JSValueReceived
v) -> do
                            jsval <- JSContextRef -> JSValueReceived -> IO JSVal
wrapJSVal' JSContextRef
ctx JSValueReceived
v
                            throwIO $ JSException jsval
                        Result
r -> Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
          , doSendAsyncCommand :: AsyncCommand -> IO ()
doSendAsyncCommand = \AsyncCommand
cmd -> AsyncCommand
cmd AsyncCommand -> IO () -> IO ()
forall a b. NFData a => a -> b -> b
`deepseq` STM () -> IO ()
forall a. STM a -> IO a
atomically (TChan (Either AsyncCommand (Command, MVar Result))
-> Either AsyncCommand (Command, MVar Result) -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan (Either AsyncCommand (Command, MVar Result))
commandChan (Either AsyncCommand (Command, MVar Result) -> STM ())
-> Either AsyncCommand (Command, MVar Result) -> STM ()
forall a b. (a -> b) -> a -> b
$ AsyncCommand -> Either AsyncCommand (Command, MVar Result)
forall a b. a -> Either a b
Left AsyncCommand
cmd)
          , addCallback :: Object -> JSCallAsFunction -> IO ()
addCallback = \(Object (JSVal IORef JSValueRef
ioref)) JSCallAsFunction
cb -> do
                val <- IORef JSValueRef -> IO JSValueRef
forall a. IORef a -> IO a
readIORef IORef JSValueRef
ioref
                atomically $ modifyTVar' callbacks (M.insert val cb)
          , nextRef :: TVar JSValueRef
nextRef = TVar JSValueRef
nextRef'
          , doEnableLogging :: Bool -> IO ()
doEnableLogging = IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef Bool
loggingEnabled
          , finalizerThreads :: MVar (Set Text)
finalizerThreads = MVar (Set Text)
finalizerThreads'
          , animationFrameHandlers :: MVar [Double -> JSM ()]
animationFrameHandlers = MVar [Double -> JSM ()]
animationFrameHandlers'
          , liveRefs :: MVar (Set JSValueRef)
liveRefs = MVar (Set JSValueRef)
liveRefs'
          }
        processResults :: Bool -> Results -> IO ()
        processResults Bool
syncCallbacks = \case
            (ProtocolError Text
err) -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Protocol error : " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
err
            (Callback Int
n BatchResults
br (JSValueReceived JSValueRef
fNumber) JSValueReceived
f JSValueReceived
this [JSValueReceived]
a) -> do
                MVar (Int, BatchResults) -> (Int, BatchResults) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, BatchResults)
recvMVar (Int
n, BatchResults
br)
                f' <- ReaderT JSContextRef IO JSVal -> JSContextRef -> IO JSVal
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (JSM JSVal -> ReaderT JSContextRef IO JSVal
forall a. JSM a -> ReaderT JSContextRef IO a
unJSM (JSM JSVal -> ReaderT JSContextRef IO JSVal)
-> JSM JSVal -> ReaderT JSContextRef IO JSVal
forall a b. (a -> b) -> a -> b
$ JSValueReceived -> JSM JSVal
wrapJSVal JSValueReceived
f) JSContextRef
ctx
                this' <- runReaderT  (unJSM $ wrapJSVal this) ctx
                args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
                logInfo (("Call " <> show fNumber <> " ") <>)
                (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case
                    Maybe JSCallAsFunction
Nothing -> IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Callback called after it was freed"
                    Just JSCallAsFunction
cb -> IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                        ReaderT JSContextRef IO () -> JSContextRef -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (JSM () -> ReaderT JSContextRef IO ()
forall a. JSM a -> ReaderT JSContextRef IO a
unJSM (JSM () -> ReaderT JSContextRef IO ())
-> JSM () -> ReaderT JSContextRef IO ()
forall a b. (a -> b) -> a -> b
$ JSCallAsFunction
cb JSVal
f' JSVal
this' [JSVal]
args) JSContextRef
ctx
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
syncCallbacks (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                            JSContextRef -> AsyncCommand -> IO ()
doSendAsyncCommand JSContextRef
ctx AsyncCommand
EndSyncBlock
            Duplicate Int
nBatch Int
nExpected -> do
                [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Error : Unexpected Duplicate. syncCallbacks=" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Bool -> [Char]
forall a. Show a => a -> [Char]
show Bool
syncCallbacks [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>
                    [Char]
" nBatch=" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
nBatch [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" nExpected=" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
nExpected
                IO Result -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Result -> IO ()) -> IO Result -> IO ()
forall a b. (a -> b) -> a -> b
$ JSContextRef -> Command -> IO Result
doSendCommand JSContextRef
ctx Command
Sync
            BatchResults Int
n BatchResults
br -> MVar (Int, BatchResults) -> (Int, BatchResults) -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, BatchResults)
recvMVar (Int
n, BatchResults
br)
        asyncResults :: Results -> IO ()
        asyncResults Results
results =
            IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Results -> IO ()
processResults Bool
False Results
results
        syncResults :: Results -> IO Batch
        syncResults Results
results = do
            IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (IO () -> IO ThreadId) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Results -> IO ()
processResults Bool
True Results
results
            MVar Batch -> IO Batch
forall a. MVar a -> IO a
readMVar MVar Batch
lastAsyncBatch
        logInfo [Char] -> [Char]
s =
            IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
loggingEnabled IO Bool -> (Bool -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Bool
True -> do
                    currentBytesUsedStr <- IO Bool
getRTSStatsEnabled IO Bool -> (Bool -> IO [Char]) -> IO [Char]
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                        Bool
True  -> Word64 -> [Char]
forall a. Show a => a -> [Char]
show (Word64 -> [Char]) -> (RTSStats -> Word64) -> RTSStats -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTSStats -> Word64
currentBytesUsed (RTSStats -> [Char]) -> IO RTSStats -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO RTSStats
getRTSStats
                        Bool
False -> [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"??"
                    cbCount <- M.size <$> readTVarIO callbacks
                    putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
                Bool
False -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    _ <- forkIO . numberForeverFromM_ 1 $ \Int
nBatch ->
        Int
-> TChan (Either AsyncCommand (Command, MVar Result))
-> IO (Batch, [MVar Result])
readBatch Int
nBatch TChan (Either AsyncCommand (Command, MVar Result))
commandChan IO (Batch, [MVar Result])
-> ((Batch, [MVar Result]) -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            (batch :: Batch
batch@(Batch [Either AsyncCommand Command]
cmds Bool
_ Int
_), [MVar Result]
resultMVars) -> do
                ([Char] -> [Char]) -> IO ()
logInfo (\[Char]
x -> [Char]
"Sync " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
x [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> (Int, Either AsyncCommand Command) -> [Char]
forall a. Show a => a -> [Char]
show ([Either AsyncCommand Command] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either AsyncCommand Command]
cmds, [Either AsyncCommand Command] -> Either AsyncCommand Command
forall a. HasCallStack => [a] -> a
last [Either AsyncCommand Command]
cmds))
                _ <- MVar Batch -> IO (Maybe Batch)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar Batch
lastAsyncBatch
                putMVar lastAsyncBatch batch
                sendBatch batch
                takeResult recvMVar nBatch >>= \case
                    (Int
n, BatchResults
_) | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
nBatch -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected jsaddle results (expected batch " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
nBatch [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
", got batch " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
")"
                    (Int
_, Success [JSValueReceived]
callbacksToFree [Result]
results)
                           | [Result] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Result]
results Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [MVar Result] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [MVar Result]
resultMVars -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected number of jsaddle results"
                           | Bool
otherwise -> do
                        (MVar Result -> Result -> IO ())
-> [MVar Result] -> [Result] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ MVar Result -> Result -> IO ()
forall a. MVar a -> a -> IO ()
putMVar [MVar Result]
resultMVars [Result]
results
                        [JSValueReceived] -> (JSValueReceived -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [JSValueReceived]
callbacksToFree ((JSValueReceived -> IO ()) -> IO ())
-> (JSValueReceived -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(JSValueReceived JSValueRef
val) ->
                            STM () -> IO ()
forall a. STM a -> IO a
atomically (TVar (Map JSValueRef JSCallAsFunction)
-> (Map JSValueRef JSCallAsFunction
    -> Map JSValueRef JSCallAsFunction)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map JSValueRef JSCallAsFunction)
callbacks (JSValueRef
-> Map JSValueRef JSCallAsFunction
-> Map JSValueRef JSCallAsFunction
forall k a. Ord k => k -> Map k a -> Map k a
M.delete JSValueRef
val))
                    (Int
_, Failure [JSValueReceived]
callbacksToFree [Result]
results JSValueReceived
exception [Char]
err) -> do
                        -- The exception will only be rethrown in Haskell if/when one of the
                        -- missing results (if any) is evaluated.
                        [Char] -> IO ()
putStrLn [Char]
"A JavaScript exception was thrown! (may not reach Haskell code)"
                        [Char] -> IO ()
putStrLn [Char]
err
                        (MVar Result -> Result -> IO ())
-> [MVar Result] -> [Result] -> IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ MVar Result -> Result -> IO ()
forall a. MVar a -> a -> IO ()
putMVar [MVar Result]
resultMVars ([Result] -> IO ()) -> [Result] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Result]
results [Result] -> [Result] -> [Result]
forall a. Semigroup a => a -> a -> a
<> Result -> [Result]
forall a. a -> [a]
repeat (JSValueReceived -> Result
ThrowJSValue JSValueReceived
exception)
                        [JSValueReceived] -> (JSValueReceived -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [JSValueReceived]
callbacksToFree ((JSValueReceived -> IO ()) -> IO ())
-> (JSValueReceived -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(JSValueReceived JSValueRef
val) ->
                            STM () -> IO ()
forall a. STM a -> IO a
atomically (TVar (Map JSValueRef JSCallAsFunction)
-> (Map JSValueRef JSCallAsFunction
    -> Map JSValueRef JSCallAsFunction)
-> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map JSValueRef JSCallAsFunction)
callbacks (JSValueRef
-> Map JSValueRef JSCallAsFunction
-> Map JSValueRef JSCallAsFunction
forall k a. Ord k => k -> Map k a -> Map k a
M.delete JSValueRef
val))
    return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)
  where
    numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()
    numberForeverFromM_ :: forall (m :: * -> *) n a.
(Monad m, Enum n) =>
n -> (n -> m a) -> m ()
numberForeverFromM_ !n
n n -> m a
f = do
      _ <- n -> m a
f n
n
      numberForeverFromM_ (succ n) f
    takeResult :: MVar (t, b) -> t -> IO (t, b)
takeResult MVar (t, b)
recvMVar t
nBatch =
        MVar (t, b) -> IO (t, b)
forall a. MVar a -> IO a
takeMVar MVar (t, b)
recvMVar IO (t, b) -> ((t, b) -> IO (t, b)) -> IO (t, b)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            (t
n, b
_) | t
n t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
nBatch -> MVar (t, b) -> t -> IO (t, b)
takeResult MVar (t, b)
recvMVar t
nBatch
            (t, b)
r -> (t, b) -> IO (t, b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (t, b)
r
    readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
    readBatch :: Int
-> TChan (Either AsyncCommand (Command, MVar Result))
-> IO (Batch, [MVar Result])
readBatch Int
nBatch TChan (Either AsyncCommand (Command, MVar Result))
chan = do
        first <- STM (Either AsyncCommand (Command, MVar Result))
-> IO (Either AsyncCommand (Command, MVar Result))
forall a. STM a -> IO a
atomically (STM (Either AsyncCommand (Command, MVar Result))
 -> IO (Either AsyncCommand (Command, MVar Result)))
-> STM (Either AsyncCommand (Command, MVar Result))
-> IO (Either AsyncCommand (Command, MVar Result))
forall a b. (a -> b) -> a -> b
$ TChan (Either AsyncCommand (Command, MVar Result))
-> STM (Either AsyncCommand (Command, MVar Result))
forall a. TChan a -> STM a
readTChan TChan (Either AsyncCommand (Command, MVar Result))
chan -- We want at least one command to send
        loop first ([], [])
      where
        loop :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
        loop :: Either AsyncCommand (Command, MVar Result)
-> ([Either AsyncCommand Command], [MVar Result])
-> IO (Batch, [MVar Result])
loop (Left asyncCmd :: AsyncCommand
asyncCmd@(SyncWithAnimationFrame JSValueForSend
_)) ([Either AsyncCommand Command]
cmds, [MVar Result]
resultMVars) =
            STM (Either AsyncCommand (Command, MVar Result))
-> IO (Either AsyncCommand (Command, MVar Result))
forall a. STM a -> IO a
atomically (TChan (Either AsyncCommand (Command, MVar Result))
-> STM (Either AsyncCommand (Command, MVar Result))
forall a. TChan a -> STM a
readTChan TChan (Either AsyncCommand (Command, MVar Result))
chan) IO (Either AsyncCommand (Command, MVar Result))
-> (Either AsyncCommand (Command, MVar Result)
    -> IO (Batch, [MVar Result]))
-> IO (Batch, [MVar Result])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either AsyncCommand (Command, MVar Result)
cmd -> Either AsyncCommand (Command, MVar Result)
-> ([Either AsyncCommand Command], [MVar Result])
-> IO (Batch, [MVar Result])
loopAnimation Either AsyncCommand (Command, MVar Result)
cmd (AsyncCommand -> Either AsyncCommand Command
forall a b. a -> Either a b
Left AsyncCommand
asyncCmdEither AsyncCommand Command
-> [Either AsyncCommand Command] -> [Either AsyncCommand Command]
forall a. a -> [a] -> [a]
:[Either AsyncCommand Command]
cmds, [MVar Result]
resultMVars)
        loop (Right (Command
syncCmd, MVar Result
resultMVar)) ([Either AsyncCommand Command]
cmds', [MVar Result]
resultMVars') = do
            let cmds :: [Either AsyncCommand Command]
cmds = Command -> Either AsyncCommand Command
forall a b. b -> Either a b
Right Command
syncCmdEither AsyncCommand Command
-> [Either AsyncCommand Command] -> [Either AsyncCommand Command]
forall a. a -> [a] -> [a]
:[Either AsyncCommand Command]
cmds'
                resultMVars :: [MVar Result]
resultMVars = MVar Result
resultMVarMVar Result -> [MVar Result] -> [MVar Result]
forall a. a -> [a] -> [a]
:[MVar Result]
resultMVars'
            STM (Maybe (Either AsyncCommand (Command, MVar Result)))
-> IO (Maybe (Either AsyncCommand (Command, MVar Result)))
forall a. STM a -> IO a
atomically (TChan (Either AsyncCommand (Command, MVar Result))
-> STM (Maybe (Either AsyncCommand (Command, MVar Result)))
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan (Either AsyncCommand (Command, MVar Result))
chan) IO (Maybe (Either AsyncCommand (Command, MVar Result)))
-> (Maybe (Either AsyncCommand (Command, MVar Result))
    -> IO (Batch, [MVar Result]))
-> IO (Batch, [MVar Result])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe (Either AsyncCommand (Command, MVar Result))
Nothing -> (Batch, [MVar Result]) -> IO (Batch, [MVar Result])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either AsyncCommand Command] -> Bool -> Int -> Batch
Batch ([Either AsyncCommand Command] -> [Either AsyncCommand Command]
forall a. [a] -> [a]
reverse [Either AsyncCommand Command]
cmds) Bool
False Int
nBatch, [MVar Result] -> [MVar Result]
forall a. [a] -> [a]
reverse [MVar Result]
resultMVars)
                Just Either AsyncCommand (Command, MVar Result)
cmd -> Either AsyncCommand (Command, MVar Result)
-> ([Either AsyncCommand Command], [MVar Result])
-> IO (Batch, [MVar Result])
loop Either AsyncCommand (Command, MVar Result)
cmd ([Either AsyncCommand Command]
cmds, [MVar Result]
resultMVars)
        loop (Left AsyncCommand
asyncCmd) ([Either AsyncCommand Command]
cmds', [MVar Result]
resultMVars) = do
            let cmds :: [Either AsyncCommand Command]
cmds = AsyncCommand -> Either AsyncCommand Command
forall a b. a -> Either a b
Left AsyncCommand
asyncCmdEither AsyncCommand Command
-> [Either AsyncCommand Command] -> [Either AsyncCommand Command]
forall a. a -> [a] -> [a]
:[Either AsyncCommand Command]
cmds'
            STM (Maybe (Either AsyncCommand (Command, MVar Result)))
-> IO (Maybe (Either AsyncCommand (Command, MVar Result)))
forall a. STM a -> IO a
atomically (TChan (Either AsyncCommand (Command, MVar Result))
-> STM (Maybe (Either AsyncCommand (Command, MVar Result)))
forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan (Either AsyncCommand (Command, MVar Result))
chan) IO (Maybe (Either AsyncCommand (Command, MVar Result)))
-> (Maybe (Either AsyncCommand (Command, MVar Result))
    -> IO (Batch, [MVar Result]))
-> IO (Batch, [MVar Result])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe (Either AsyncCommand (Command, MVar Result))
Nothing -> (Batch, [MVar Result]) -> IO (Batch, [MVar Result])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either AsyncCommand Command] -> Bool -> Int -> Batch
Batch ([Either AsyncCommand Command] -> [Either AsyncCommand Command]
forall a. [a] -> [a]
reverse [Either AsyncCommand Command]
cmds) Bool
False Int
nBatch, [MVar Result] -> [MVar Result]
forall a. [a] -> [a]
reverse [MVar Result]
resultMVars)
                Just Either AsyncCommand (Command, MVar Result)
cmd -> Either AsyncCommand (Command, MVar Result)
-> ([Either AsyncCommand Command], [MVar Result])
-> IO (Batch, [MVar Result])
loop Either AsyncCommand (Command, MVar Result)
cmd ([Either AsyncCommand Command]
cmds, [MVar Result]
resultMVars)
        -- When we have seen a SyncWithAnimationFrame command only a synchronous command should end the batch
        loopAnimation :: Either AsyncCommand (Command, MVar Result) -> ([Either AsyncCommand Command], [MVar Result]) -> IO (Batch, [MVar Result])
        loopAnimation :: Either AsyncCommand (Command, MVar Result)
-> ([Either AsyncCommand Command], [MVar Result])
-> IO (Batch, [MVar Result])
loopAnimation (Right (Command
Sync, MVar Result
resultMVar)) ([Either AsyncCommand Command]
cmds, [MVar Result]
resultMVars) =
            (Batch, [MVar Result]) -> IO (Batch, [MVar Result])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either AsyncCommand Command] -> Bool -> Int -> Batch
Batch ([Either AsyncCommand Command] -> [Either AsyncCommand Command]
forall a. [a] -> [a]
reverse (Command -> Either AsyncCommand Command
forall a b. b -> Either a b
Right Command
SyncEither AsyncCommand Command
-> [Either AsyncCommand Command] -> [Either AsyncCommand Command]
forall a. a -> [a] -> [a]
:[Either AsyncCommand Command]
cmds)) Bool
True Int
nBatch, [MVar Result] -> [MVar Result]
forall a. [a] -> [a]
reverse (MVar Result
resultMVarMVar Result -> [MVar Result] -> [MVar Result]
forall a. a -> [a] -> [a]
:[MVar Result]
resultMVars))
        loopAnimation (Right (Command
syncCmd, MVar Result
resultMVar)) ([Either AsyncCommand Command]
cmds, [MVar Result]
resultMVars) =
            STM (Either AsyncCommand (Command, MVar Result))
-> IO (Either AsyncCommand (Command, MVar Result))
forall a. STM a -> IO a
atomically (TChan (Either AsyncCommand (Command, MVar Result))
-> STM (Either AsyncCommand (Command, MVar Result))
forall a. TChan a -> STM a
readTChan TChan (Either AsyncCommand (Command, MVar Result))
chan) IO (Either AsyncCommand (Command, MVar Result))
-> (Either AsyncCommand (Command, MVar Result)
    -> IO (Batch, [MVar Result]))
-> IO (Batch, [MVar Result])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either AsyncCommand (Command, MVar Result)
cmd -> Either AsyncCommand (Command, MVar Result)
-> ([Either AsyncCommand Command], [MVar Result])
-> IO (Batch, [MVar Result])
loopAnimation Either AsyncCommand (Command, MVar Result)
cmd (Command -> Either AsyncCommand Command
forall a b. b -> Either a b
Right Command
syncCmdEither AsyncCommand Command
-> [Either AsyncCommand Command] -> [Either AsyncCommand Command]
forall a. a -> [a] -> [a]
:[Either AsyncCommand Command]
cmds, MVar Result
resultMVarMVar Result -> [MVar Result] -> [MVar Result]
forall a. a -> [a] -> [a]
:[MVar Result]
resultMVars)
        loopAnimation (Left AsyncCommand
asyncCmd) ([Either AsyncCommand Command]
cmds, [MVar Result]
resultMVars) =
            STM (Either AsyncCommand (Command, MVar Result))
-> IO (Either AsyncCommand (Command, MVar Result))
forall a. STM a -> IO a
atomically (TChan (Either AsyncCommand (Command, MVar Result))
-> STM (Either AsyncCommand (Command, MVar Result))
forall a. TChan a -> STM a
readTChan TChan (Either AsyncCommand (Command, MVar Result))
chan) IO (Either AsyncCommand (Command, MVar Result))
-> (Either AsyncCommand (Command, MVar Result)
    -> IO (Batch, [MVar Result]))
-> IO (Batch, [MVar Result])
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Either AsyncCommand (Command, MVar Result)
cmd -> Either AsyncCommand (Command, MVar Result)
-> ([Either AsyncCommand Command], [MVar Result])
-> IO (Batch, [MVar Result])
loopAnimation Either AsyncCommand (Command, MVar Result)
cmd (AsyncCommand -> Either AsyncCommand Command
forall a b. a -> Either a b
Left AsyncCommand
asyncCmdEither AsyncCommand Command
-> [Either AsyncCommand Command] -> [Either AsyncCommand Command]
forall a. a -> [a] -> [a]
:[Either AsyncCommand Command]
cmds, [MVar Result]
resultMVars)
#ifndef ghcjs_HOST_OS
#if MIN_VERSION_base(4,11,0)
    currentBytesUsed :: RTSStats -> Word64
currentBytesUsed = GCDetails -> Word64
gcdetails_live_bytes (GCDetails -> Word64)
-> (RTSStats -> GCDetails) -> RTSStats -> Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTSStats -> GCDetails
gc
#else
    getRTSStatsEnabled = getGCStatsEnabled
    getRTSStats = getGCStats
#endif
#endif


addThreadFinalizer :: ThreadId -> IO () -> IO ()
addThreadFinalizer :: ThreadId -> IO () -> IO ()
addThreadFinalizer t :: ThreadId
t@(ThreadId ThreadId#
t#) (IO State# RealWorld -> (# State# RealWorld, () #)
finalizer) =
    (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, () #)) -> IO ())
-> (State# RealWorld -> (# State# RealWorld, () #)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case ThreadId#
-> ThreadId
-> (State# RealWorld -> (# State# RealWorld, () #))
-> State# RealWorld
-> (# State# RealWorld, Weak# ThreadId #)
forall a b c.
a
-> b
-> (State# RealWorld -> (# State# RealWorld, c #))
-> State# RealWorld
-> (# State# RealWorld, Weak# b #)
mkWeak# ThreadId#
t# ThreadId
t State# RealWorld -> (# State# RealWorld, () #)
finalizer State# RealWorld
s of { (# State# RealWorld
s1, Weak# ThreadId
_ #) -> (# State# RealWorld
s1, () #) }


wrapJSVal :: JSValueReceived -> JSM JSVal
wrapJSVal :: JSValueReceived -> JSM JSVal
wrapJSVal JSValueReceived
v = do
    ctx <- ReaderT JSContextRef IO JSContextRef -> JSM JSContextRef
forall a. ReaderT JSContextRef IO a -> JSM a
JSM ReaderT JSContextRef IO JSContextRef
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
    liftIO $ wrapJSVal' ctx v

wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal
wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal
wrapJSVal' JSContextRef
ctx (JSValueReceived JSValueRef
n) = do
    ref <- IO (IORef JSValueRef) -> IO (IORef JSValueRef)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef JSValueRef) -> IO (IORef JSValueRef))
-> IO (IORef JSValueRef) -> IO (IORef JSValueRef)
forall a b. (a -> b) -> a -> b
$ JSValueRef -> IO (IORef JSValueRef)
forall a. a -> IO (IORef a)
newIORef JSValueRef
n
    when (n >= 5 || n < 0) $
#ifdef JSADDLE_CHECK_WRAPJSVAL
     do lr <- takeMVar $ liveRefs ctx
        if n `S.member` lr
            then do
                putStrLn $ "JS Value Ref " <> show n <> " already wrapped"
                putMVar (liveRefs ctx) lr
            else putMVar (liveRefs ctx) =<< evaluate (S.insert n lr)
#endif
        void . mkWeakIORef ref $ do
            ft <- takeMVar $ finalizerThreads ctx
            t <- myThreadId
            let tname = [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ ThreadId -> [Char]
forall a. Show a => a -> [Char]
show ThreadId
t
            doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend n
            if tname `S.member` ft
                then putMVar (finalizerThreads ctx) ft
                else do
                    addThreadFinalizer t $ do
                        modifyMVar (finalizerThreads ctx) $ \Set Text
s -> (Set Text, ()) -> IO (Set Text, ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
S.delete Text
tname Set Text
s, ())
                        doSendAsyncCommand ctx $ FreeRefs tname
                    putMVar (finalizerThreads ctx) =<< evaluate (S.insert tname ft)
    return (JSVal ref)
#endif