{-# 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
    Bool -> IO ()
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
    IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ Bool -> IO ()
f Bool
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
    UTCTime
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
    UTCTime
now <- IO UTCTime -> JSM UTCTime
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    JSM JSVal -> JSM ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (JSM JSVal -> JSM ()) -> JSM JSVal -> JSM ()
forall a b. (a -> b) -> a -> b
$ (JSValueForSend -> AsyncCommand) -> JSM JSVal
sendLazyCommand JSValueForSend -> AsyncCommand
SyncWithAnimationFrame
    Double -> JSM Double
forall a. a -> JSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> JSM Double) -> Double -> JSM Double
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
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
    Double
t <- JSM Double
waitForAnimationFrame
    JSM a -> JSM a
forall a. JSM a -> JSM a
syncAfter (Double -> JSM a
f Double
t)

#ifndef ghcjs_HOST_OS
sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal
sendLazyCommand JSValueForSend -> AsyncCommand
cmd = do
    TVar JSValueRef
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
    JSValueRef
n <- IO JSValueRef -> JSM JSValueRef
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSValueRef -> JSM JSValueRef)
-> (STM JSValueRef -> IO JSValueRef)
-> STM JSValueRef
-> JSM JSValueRef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM JSValueRef -> IO JSValueRef
forall a. STM a -> IO a
atomically (STM JSValueRef -> JSM JSValueRef)
-> STM JSValueRef -> JSM JSValueRef
forall a b. (a -> b) -> a -> b
$ do
        JSValueRef
n <- JSValueRef -> JSValueRef -> JSValueRef
forall a. Num a => a -> a -> a
subtract JSValueRef
1 (JSValueRef -> JSValueRef) -> STM JSValueRef -> STM JSValueRef
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar JSValueRef -> STM JSValueRef
forall a. TVar a -> STM a
readTVar TVar JSValueRef
nextRefTVar
        TVar JSValueRef -> JSValueRef -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar JSValueRef
nextRefTVar (JSValueRef -> STM ()) -> JSValueRef -> STM ()
forall a b. (a -> b) -> a -> b
$! JSValueRef
n
        JSValueRef -> STM JSValueRef
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return JSValueRef
n
    AsyncCommand -> IO ()
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
    IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ AsyncCommand -> IO ()
s (JSValueForSend -> AsyncCommand
cmd (JSValueForSend -> AsyncCommand) -> JSValueForSend -> AsyncCommand
forall a b. (a -> b) -> a -> b
$ JSValueRef -> JSValueForSend
JSValueForSend JSValueRef
n)
    JSValueReceived -> JSM JSVal
wrapJSVal (JSValueRef -> JSValueReceived
JSValueReceived JSValueRef
n)

sendAsyncCommand :: AsyncCommand -> JSM ()
sendAsyncCommand :: AsyncCommand -> JSM ()
sendAsyncCommand AsyncCommand
cmd = do
    AsyncCommand -> IO ()
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
    IO () -> JSM ()
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> JSM ()) -> IO () -> JSM ()
forall a b. (a -> b) -> a -> b
$ AsyncCommand -> IO ()
s AsyncCommand
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
    JSValueRef
contextId' <- IO JSValueRef
forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
    UTCTime
startTime' <- IO UTCTime
getCurrentTime
    MVar (Int, BatchResults)
recvMVar <- IO (MVar (Int, BatchResults))
forall a. IO (MVar a)
newEmptyMVar
    MVar Batch
lastAsyncBatch <- IO (MVar Batch)
forall a. IO (MVar a)
newEmptyMVar
    TChan (Either AsyncCommand (Command, MVar Result))
commandChan <- IO (TChan (Either AsyncCommand (Command, MVar Result)))
forall a. IO (TChan a)
newTChanIO
    TVar (Map JSValueRef JSCallAsFunction)
callbacks <- Map JSValueRef JSCallAsFunction
-> IO (TVar (Map JSValueRef JSCallAsFunction))
forall a. a -> IO (TVar a)
newTVarIO Map JSValueRef JSCallAsFunction
forall k a. Map k a
M.empty
    TVar JSValueRef
nextRef' <- JSValueRef -> IO (TVar JSValueRef)
forall a. a -> IO (TVar a)
newTVarIO JSValueRef
0
    MVar (Set Text)
finalizerThreads' <- Set Text -> IO (MVar (Set Text))
forall a. a -> IO (MVar a)
newMVar Set Text
forall a. Set a
S.empty
    MVar [Double -> JSM ()]
animationFrameHandlers' <- [Double -> JSM ()] -> IO (MVar [Double -> JSM ()])
forall a. a -> IO (MVar a)
newMVar []
    IORef Bool
loggingEnabled <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False
    MVar (Set JSValueRef)
liveRefs' <- Set JSValueRef -> IO (MVar (Set JSValueRef))
forall a. a -> IO (MVar a)
newMVar Set JSValueRef
forall a. Set a
S.empty
    let ctx :: JSContextRef
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
                MVar Result
result <- IO (MVar Result)
forall a. IO (MVar a)
newEmptyMVar
                STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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 ((Command, MVar Result)
-> Either AsyncCommand (Command, MVar Result)
forall a b. b -> Either a b
Right (Command
cmd, MVar Result
result))
                IO Result -> IO Result
forall a. IO a -> IO a
unsafeInterleaveIO (IO Result -> IO Result) -> IO Result -> IO Result
forall a b. (a -> b) -> a -> b
$
                    MVar Result -> IO Result
forall a. MVar a -> IO a
takeMVar MVar Result
result IO Result -> (Result -> IO Result) -> IO 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
                        (ThrowJSValue JSValueReceived
v) -> do
                            JSVal
jsval <- JSContextRef -> JSValueReceived -> IO JSVal
wrapJSVal' JSContextRef
ctx JSValueReceived
v
                            JSException -> IO Result
forall e a. Exception e => e -> IO a
throwIO (JSException -> IO Result) -> JSException -> IO Result
forall a b. (a -> b) -> a -> b
$ JSVal -> JSException
JSException JSVal
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
                JSValueRef
val <- IORef JSValueRef -> IO JSValueRef
forall a. IORef a -> IO a
readIORef IORef JSValueRef
ioref
                STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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
-> JSCallAsFunction
-> Map JSValueRef JSCallAsFunction
-> Map JSValueRef JSCallAsFunction
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert JSValueRef
val JSCallAsFunction
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 -> 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)
                JSVal
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
                JSVal
this' <- 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
this) JSContextRef
ctx
                [JSVal]
args <- 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) -> [JSValueReceived] -> JSM [JSVal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM JSValueReceived -> JSM JSVal
wrapJSVal [JSValueReceived]
a) JSContextRef
ctx
                ([Char] -> [Char]) -> IO ()
logInfo (([Char]
"Call " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> JSValueRef -> [Char]
forall a. Show a => a -> [Char]
show JSValueRef
fNumber [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" ") [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>)
                (JSValueRef
-> Map JSValueRef JSCallAsFunction -> Maybe JSCallAsFunction
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup JSValueRef
fNumber (Map JSValueRef JSCallAsFunction -> Maybe JSCallAsFunction)
-> IO (Map JSValueRef JSCallAsFunction)
-> IO (Maybe JSCallAsFunction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map JSValueRef JSCallAsFunction)
-> IO (Map JSValueRef JSCallAsFunction)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TVar (Map JSValueRef JSCallAsFunction)
-> IO (Map JSValueRef JSCallAsFunction)
forall a. TVar a -> IO a
readTVarIO TVar (Map JSValueRef JSCallAsFunction)
callbacks)) IO (Maybe JSCallAsFunction)
-> (Maybe JSCallAsFunction -> 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
                    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 -> 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 -> 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]) -> IO ()
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
                    [Char]
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]
"??"
                    Int
cbCount <- Map JSValueRef JSCallAsFunction -> Int
forall k a. Map k a -> Int
M.size (Map JSValueRef JSCallAsFunction -> Int)
-> IO (Map JSValueRef JSCallAsFunction) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar (Map JSValueRef JSCallAsFunction)
-> IO (Map JSValueRef JSCallAsFunction)
forall a. TVar a -> IO a
readTVarIO TVar (Map JSValueRef JSCallAsFunction)
callbacks
                    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> ([Char] -> [Char]) -> [Char] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
s ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"M " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
currentBytesUsedStr [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" CB " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall a. Show a => a -> [Char]
show Int
cbCount [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" "
                Bool
False -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId)
-> ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> (Int -> IO ()) -> IO ()
forall (m :: * -> *) n a.
(Monad m, Enum n) =>
n -> (n -> m a) -> m ()
numberForeverFromM_ Int
1 ((Int -> IO ()) -> IO ThreadId) -> (Int -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \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))
                Maybe Batch
_ <- MVar Batch -> IO (Maybe Batch)
forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar Batch
lastAsyncBatch
                MVar Batch -> Batch -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar Batch
lastAsyncBatch Batch
batch
                Batch -> IO ()
sendBatch Batch
batch
                MVar (Int, BatchResults) -> Int -> IO (Int, BatchResults)
forall {t} {b}. Ord t => MVar (t, b) -> t -> IO (t, b)
takeResult MVar (Int, BatchResults)
recvMVar Int
nBatch IO (Int, BatchResults) -> ((Int, BatchResults) -> 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
                    (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))
    (Results -> IO (), Results -> IO Batch, IO ())
-> IO (Results -> IO (), Results -> IO Batch, IO ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Results -> IO ()
asyncResults, Results -> IO Batch
syncResults, 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 ()
entryPoint) JSContextRef
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
      a
_ <- n -> m a
f n
n
      n -> (n -> m a) -> m ()
forall (m :: * -> *) n a.
(Monad m, Enum n) =>
n -> (n -> m a) -> m ()
numberForeverFromM_ (n -> n
forall a. Enum a => a -> a
succ n
n) n -> m a
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
        Either AsyncCommand (Command, MVar Result)
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
        Either AsyncCommand (Command, MVar Result)
-> ([Either AsyncCommand Command], [MVar Result])
-> IO (Batch, [MVar Result])
loop Either AsyncCommand (Command, MVar Result)
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
    JSContextRef
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
    IO JSVal -> JSM JSVal
forall a. IO a -> JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO JSVal -> JSM JSVal) -> IO JSVal -> JSM JSVal
forall a b. (a -> b) -> a -> b
$ JSContextRef -> JSValueReceived -> IO JSVal
wrapJSVal' JSContextRef
ctx JSValueReceived
v

wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal
wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal
wrapJSVal' JSContextRef
ctx (JSValueReceived JSValueRef
n) = do
    IORef JSValueRef
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
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (JSValueRef
n JSValueRef -> JSValueRef -> Bool
forall a. Ord a => a -> a -> Bool
>= JSValueRef
5 Bool -> Bool -> Bool
|| JSValueRef
n JSValueRef -> JSValueRef -> Bool
forall a. Ord a => a -> a -> Bool
< JSValueRef
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
#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
        IO (Weak (IORef JSValueRef)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Weak (IORef JSValueRef)) -> IO ())
-> (IO () -> IO (Weak (IORef JSValueRef))) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef JSValueRef -> IO () -> IO (Weak (IORef JSValueRef))
forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef JSValueRef
ref (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Set Text
ft <- MVar (Set Text) -> IO (Set Text)
forall a. MVar a -> IO a
takeMVar (MVar (Set Text) -> IO (Set Text))
-> MVar (Set Text) -> IO (Set Text)
forall a b. (a -> b) -> a -> b
$ JSContextRef -> MVar (Set Text)
finalizerThreads JSContextRef
ctx
            ThreadId
t <- IO ThreadId
myThreadId
            let tname :: Text
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
            JSContextRef -> AsyncCommand -> IO ()
doSendAsyncCommand JSContextRef
ctx (AsyncCommand -> IO ()) -> AsyncCommand -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> JSValueForSend -> AsyncCommand
FreeRef Text
tname (JSValueForSend -> AsyncCommand) -> JSValueForSend -> AsyncCommand
forall a b. (a -> b) -> a -> b
$ JSValueRef -> JSValueForSend
JSValueForSend JSValueRef
n
            if Text
tname Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Text
ft
                then MVar (Set Text) -> Set Text -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (JSContextRef -> MVar (Set Text)
finalizerThreads JSContextRef
ctx) Set Text
ft
                else do
                    ThreadId -> IO () -> IO ()
addThreadFinalizer ThreadId
t (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                        MVar (Set Text) -> (Set Text -> IO (Set Text, ())) -> IO ()
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (JSContextRef -> MVar (Set Text)
finalizerThreads JSContextRef
ctx) ((Set Text -> IO (Set Text, ())) -> IO ())
-> (Set Text -> IO (Set Text, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \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, ())
                        JSContextRef -> AsyncCommand -> IO ()
doSendAsyncCommand JSContextRef
ctx (AsyncCommand -> IO ()) -> AsyncCommand -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> AsyncCommand
FreeRefs Text
tname
                    MVar (Set Text) -> Set Text -> IO ()
forall a. MVar a -> a -> IO ()
putMVar (JSContextRef -> MVar (Set Text)
finalizerThreads JSContextRef
ctx) (Set Text -> IO ()) -> IO (Set Text) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Set Text -> IO (Set Text)
forall a. a -> IO a
evaluate (Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
S.insert Text
tname Set Text
ft)
    JSVal -> IO JSVal
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef JSValueRef -> JSVal
JSVal IORef JSValueRef
ref)
#endif