{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
module Language.Javascript.JSaddle.Run (
syncPoint
, syncAfter
, waitForAnimationFrame
, nextAnimationFrame
, enableLogging
#ifndef ghcjs_HOST_OS
, 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
enableLogging :: Bool -> JSM ()
#ifdef ghcjs_HOST_OS
enableLogging _ = return ()
#else
enableLogging :: Bool -> JSM ()
enableLogging Bool
v = do
Bool -> IO ()
f <- JSContextRef -> Bool -> IO ()
doEnableLogging forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ReaderT JSContextRef IO a -> JSM a
JSM forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Bool -> IO ()
f Bool
v
#endif
waitForAnimationFrame :: JSM Double
#ifdef ghcjs_HOST_OS
waitForAnimationFrame = GHCJS.waitForAnimationFrame
#else
waitForAnimationFrame :: JSM Double
waitForAnimationFrame = do
UTCTime
start <- JSContextRef -> UTCTime
startTime forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ReaderT JSContextRef IO a -> JSM a
JSM forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
UTCTime
now <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ (JSValueForSend -> AsyncCommand) -> JSM JSVal
sendLazyCommand JSValueForSend -> AsyncCommand
SyncWithAnimationFrame
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Real a, Fractional b) => a -> b
realToFrac (UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
now UTCTime
start)
#endif
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
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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ReaderT JSContextRef IO a -> JSM a
JSM forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
JSValueRef
n <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
JSValueRef
n <- forall a. Num a => a -> a -> a
subtract JSValueRef
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar JSValueRef
nextRefTVar
forall a. TVar a -> a -> STM ()
writeTVar TVar JSValueRef
nextRefTVar forall a b. (a -> b) -> a -> b
$! JSValueRef
n
forall (m :: * -> *) a. Monad m => a -> m a
return JSValueRef
n
AsyncCommand -> IO ()
s <- JSContextRef -> AsyncCommand -> IO ()
doSendAsyncCommand forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ReaderT JSContextRef IO a -> JSM a
JSM forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ AsyncCommand -> IO ()
s (JSValueForSend -> AsyncCommand
cmd 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. ReaderT JSContextRef IO a -> JSM a
JSM forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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' <- forall a (m :: * -> *). (Random a, MonadIO m) => m a
randomIO
UTCTime
startTime' <- IO UTCTime
getCurrentTime
MVar (Int, BatchResults)
recvMVar <- forall a. IO (MVar a)
newEmptyMVar
MVar Batch
lastAsyncBatch <- forall a. IO (MVar a)
newEmptyMVar
TChan (Either AsyncCommand (Command, MVar Result))
commandChan <- forall a. IO (TChan a)
newTChanIO
TVar (Map JSValueRef JSCallAsFunction)
callbacks <- forall a. a -> IO (TVar a)
newTVarIO forall k a. Map k a
M.empty
TVar JSValueRef
nextRef' <- forall a. a -> IO (TVar a)
newTVarIO JSValueRef
0
MVar (Set Text)
finalizerThreads' <- forall a. a -> IO (MVar a)
newMVar forall a. Set a
S.empty
MVar [Double -> JSM ()]
animationFrameHandlers' <- forall a. a -> IO (MVar a)
newMVar []
IORef Bool
loggingEnabled <- forall a. a -> IO (IORef a)
newIORef Bool
False
MVar (Set JSValueRef)
liveRefs' <- forall a. a -> IO (MVar a)
newMVar 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 forall a b. NFData a => a -> b -> b
`deepseq` do
MVar Result
result <- forall a. IO (MVar a)
newEmptyMVar
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> a -> STM ()
writeTChan TChan (Either AsyncCommand (Command, MVar Result))
commandChan (forall a b. b -> Either a b
Right (Command
cmd, MVar Result
result))
forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$
forall a. MVar a -> IO a
takeMVar MVar Result
result 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
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ JSVal -> JSException
JSException JSVal
jsval
Result
r -> forall (m :: * -> *) a. Monad m => a -> m a
return Result
r
, doSendAsyncCommand :: AsyncCommand -> IO ()
doSendAsyncCommand = \AsyncCommand
cmd -> AsyncCommand
cmd forall a b. NFData a => a -> b -> b
`deepseq` forall a. STM a -> IO a
atomically (forall a. TChan a -> a -> STM ()
writeTChan TChan (Either AsyncCommand (Command, MVar Result))
commandChan forall a b. (a -> b) -> a -> b
$ 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 <- forall a. IORef a -> IO a
readIORef IORef JSValueRef
ioref
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map JSValueRef JSCallAsFunction)
callbacks (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 = 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) -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Protocol error : " 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
forall a. MVar a -> a -> IO ()
putMVar MVar (Int, BatchResults)
recvMVar (Int
n, BatchResults
br)
JSVal
f' <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. JSM a -> ReaderT JSContextRef IO a
unJSM forall a b. (a -> b) -> a -> b
$ JSValueReceived -> JSM JSVal
wrapJSVal JSValueReceived
f) JSContextRef
ctx
JSVal
this' <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. JSM a -> ReaderT JSContextRef IO a
unJSM forall a b. (a -> b) -> a -> b
$ JSValueReceived -> JSM JSVal
wrapJSVal JSValueReceived
this) JSContextRef
ctx
[JSVal]
args <- forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. JSM a -> ReaderT JSContextRef IO a
unJSM forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM JSValueReceived -> JSM JSVal
wrapJSVal [JSValueReceived]
a) JSContextRef
ctx
([Char] -> [Char]) -> IO ()
logInfo (([Char]
"Call " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show JSValueRef
fNumber forall a. Semigroup a => a -> a -> a
<> [Char]
" ") forall a. Semigroup a => a -> a -> a
<>)
(forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup JSValueRef
fNumber forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. TVar a -> IO a
readTVarIO TVar (Map JSValueRef JSCallAsFunction)
callbacks)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe JSCallAsFunction
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Callback called after it was freed"
Just JSCallAsFunction
cb -> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ do
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall a. JSM a -> ReaderT JSContextRef IO a
unJSM forall a b. (a -> b) -> a -> b
$ JSCallAsFunction
cb JSVal
f' JSVal
this' [JSVal]
args) JSContextRef
ctx
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
syncCallbacks forall a b. (a -> b) -> a -> b
$
JSContextRef -> AsyncCommand -> IO ()
doSendAsyncCommand JSContextRef
ctx AsyncCommand
EndSyncBlock
Duplicate Int
nBatch Int
nExpected -> do
[Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Error : Unexpected Duplicate. syncCallbacks=" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Bool
syncCallbacks forall a. Semigroup a => a -> a -> a
<>
[Char]
" nBatch=" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
nBatch forall a. Semigroup a => a -> a -> a
<> [Char]
" nExpected=" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
nExpected
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ JSContextRef -> Command -> IO Result
doSendCommand JSContextRef
ctx Command
Sync
BatchResults Int
n BatchResults
br -> forall a. MVar a -> a -> IO ()
putMVar MVar (Int, BatchResults)
recvMVar (Int
n, BatchResults
br)
asyncResults :: Results -> IO ()
asyncResults :: Results -> IO ()
asyncResults Results
results =
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO 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
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Bool -> Results -> IO ()
processResults Bool
True Results
results
forall a. MVar a -> IO a
readMVar MVar Batch
lastAsyncBatch
logInfo :: ([Char] -> [Char]) -> IO ()
logInfo [Char] -> [Char]
s =
forall a. IORef a -> IO a
readIORef IORef Bool
loggingEnabled forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> do
[Char]
currentBytesUsedStr <- IO Bool
getRTSStatsEnabled forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
True -> forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. RTSStats -> Word64
currentBytesUsed forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO RTSStats
getRTSStats
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return [Char]
"??"
Int
cbCount <- forall k a. Map k a -> Int
M.size forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> IO a
readTVarIO TVar (Map JSValueRef JSCallAsFunction)
callbacks
[Char] -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
s forall a b. (a -> b) -> a -> b
$ [Char]
"M " forall a. Semigroup a => a -> a -> a
<> [Char]
currentBytesUsedStr forall a. Semigroup a => a -> a -> a
<> [Char]
" CB " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
cbCount forall a. Semigroup a => a -> a -> a
<> [Char]
" "
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
ThreadId
_ <- IO () -> IO ThreadId
forkIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) n a.
(Monad m, Enum n) =>
n -> (n -> m a) -> m ()
numberForeverFromM_ Int
1 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 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 " forall a. Semigroup a => a -> a -> a
<> [Char]
x forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Either AsyncCommand Command]
cmds, forall a. [a] -> a
last [Either AsyncCommand Command]
cmds))
Maybe Batch
_ <- forall a. MVar a -> IO (Maybe a)
tryTakeMVar MVar Batch
lastAsyncBatch
forall a. MVar a -> a -> IO ()
putMVar MVar Batch
lastAsyncBatch Batch
batch
Batch -> IO ()
sendBatch Batch
batch
forall {t} {b}. Ord t => MVar (t, b) -> t -> IO (t, b)
takeResult MVar (Int, BatchResults)
recvMVar Int
nBatch forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
(Int
n, BatchResults
_) | Int
n forall a. Eq a => a -> a -> Bool
/= Int
nBatch -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected jsaddle results (expected batch " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
nBatch forall a. Semigroup a => a -> a -> a
<> [Char]
", got batch " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Int
n forall a. Semigroup a => a -> a -> a
<> [Char]
")"
(Int
_, Success [JSValueReceived]
callbacksToFree [Result]
results)
| forall (t :: * -> *) a. Foldable t => t a -> Int
length [Result]
results forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length [MVar Result]
resultMVars -> forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected number of jsaddle results"
| Bool
otherwise -> do
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ forall a. MVar a -> a -> IO ()
putMVar [MVar Result]
resultMVars [Result]
results
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [JSValueReceived]
callbacksToFree forall a b. (a -> b) -> a -> b
$ \(JSValueReceived JSValueRef
val) ->
forall a. STM a -> IO a
atomically (forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map JSValueRef JSCallAsFunction)
callbacks (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
[Char] -> IO ()
putStrLn [Char]
"A JavaScript exception was thrown! (may not reach Haskell code)"
[Char] -> IO ()
putStrLn [Char]
err
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ forall a. MVar a -> a -> IO ()
putMVar [MVar Result]
resultMVars forall a b. (a -> b) -> a -> b
$ [Result]
results forall a. Semigroup a => a -> a -> a
<> forall a. a -> [a]
repeat (JSValueReceived -> Result
ThrowJSValue JSValueReceived
exception)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [JSValueReceived]
callbacksToFree forall a b. (a -> b) -> a -> b
$ \(JSValueReceived JSValueRef
val) ->
forall a. STM a -> IO a
atomically (forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar (Map JSValueRef JSCallAsFunction)
callbacks (forall k a. Ord k => k -> Map k a -> Map k a
M.delete JSValueRef
val))
forall (m :: * -> *) a. Monad m => a -> m a
return (Results -> IO ()
asyncResults, Results -> IO Batch
syncResults, forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (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
forall (m :: * -> *) n a.
(Monad m, Enum n) =>
n -> (n -> m a) -> m ()
numberForeverFromM_ (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 =
forall a. MVar a -> IO a
takeMVar MVar (t, b)
recvMVar forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
(t
n, b
_) | t
n 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 -> 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 <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TChan a -> STM a
readTChan TChan (Either AsyncCommand (Command, MVar Result))
chan
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) =
forall a. STM a -> IO a
atomically (forall a. TChan a -> STM a
readTChan TChan (Either AsyncCommand (Command, MVar Result))
chan) 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 (forall a b. a -> Either a b
Left AsyncCommand
asyncCmdforall 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 = forall a b. b -> Either a b
Right Command
syncCmdforall a. a -> [a] -> [a]
:[Either AsyncCommand Command]
cmds'
resultMVars :: [MVar Result]
resultMVars = MVar Result
resultMVarforall a. a -> [a] -> [a]
:[MVar Result]
resultMVars'
forall a. STM a -> IO a
atomically (forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan (Either AsyncCommand (Command, MVar Result))
chan) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Either AsyncCommand (Command, MVar Result))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Either AsyncCommand Command] -> Bool -> Int -> Batch
Batch (forall a. [a] -> [a]
reverse [Either AsyncCommand Command]
cmds) Bool
False Int
nBatch, 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 = forall a b. a -> Either a b
Left AsyncCommand
asyncCmdforall a. a -> [a] -> [a]
:[Either AsyncCommand Command]
cmds'
forall a. STM a -> IO a
atomically (forall a. TChan a -> STM (Maybe a)
tryReadTChan TChan (Either AsyncCommand (Command, MVar Result))
chan) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Either AsyncCommand (Command, MVar Result))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ([Either AsyncCommand Command] -> Bool -> Int -> Batch
Batch (forall a. [a] -> [a]
reverse [Either AsyncCommand Command]
cmds) Bool
False Int
nBatch, 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)
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) =
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either AsyncCommand Command] -> Bool -> Int -> Batch
Batch (forall a. [a] -> [a]
reverse (forall a b. b -> Either a b
Right Command
Syncforall a. a -> [a] -> [a]
:[Either AsyncCommand Command]
cmds)) Bool
True Int
nBatch, forall a. [a] -> [a]
reverse (MVar Result
resultMVarforall a. a -> [a] -> [a]
:[MVar Result]
resultMVars))
loopAnimation (Right (Command
syncCmd, MVar Result
resultMVar)) ([Either AsyncCommand Command]
cmds, [MVar Result]
resultMVars) =
forall a. STM a -> IO a
atomically (forall a. TChan a -> STM a
readTChan TChan (Either AsyncCommand (Command, MVar Result))
chan) 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 (forall a b. b -> Either a b
Right Command
syncCmdforall a. a -> [a] -> [a]
:[Either AsyncCommand Command]
cmds, MVar Result
resultMVarforall a. a -> [a] -> [a]
:[MVar Result]
resultMVars)
loopAnimation (Left AsyncCommand
asyncCmd) ([Either AsyncCommand Command]
cmds, [MVar Result]
resultMVars) =
forall a. STM a -> IO a
atomically (forall a. TChan a -> STM a
readTChan TChan (Either AsyncCommand (Command, MVar Result))
chan) 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 (forall a b. a -> Either a b
Left AsyncCommand
asyncCmdforall 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 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) =
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> case mkWeak# :: 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 <- forall a. ReaderT JSContextRef IO a -> JSM a
JSM forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef JSValueRef
n
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (JSValueRef
n forall a. Ord a => a -> a -> Bool
>= JSValueRef
5 Bool -> Bool -> Bool
|| JSValueRef
n forall a. Ord a => a -> a -> Bool
< JSValueRef
0) 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
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IORef a -> IO () -> IO (Weak (IORef a))
mkWeakIORef IORef JSValueRef
ref forall a b. (a -> b) -> a -> b
$ do
Set Text
ft <- forall a. MVar a -> IO a
takeMVar 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 forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show ThreadId
t
JSContextRef -> AsyncCommand -> IO ()
doSendAsyncCommand JSContextRef
ctx forall a b. (a -> b) -> a -> b
$ Text -> JSValueForSend -> AsyncCommand
FreeRef Text
tname forall a b. (a -> b) -> a -> b
$ JSValueRef -> JSValueForSend
JSValueForSend JSValueRef
n
if Text
tname forall a. Ord a => a -> Set a -> Bool
`S.member` Set Text
ft
then 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 forall a b. (a -> b) -> a -> b
$ do
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar (JSContextRef -> MVar (Set Text)
finalizerThreads JSContextRef
ctx) forall a b. (a -> b) -> a -> b
$ \Set Text
s -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Ord a => a -> Set a -> Set a
S.delete Text
tname Set Text
s, ())
JSContextRef -> AsyncCommand -> IO ()
doSendAsyncCommand JSContextRef
ctx forall a b. (a -> b) -> a -> b
$ Text -> AsyncCommand
FreeRefs Text
tname
forall a. MVar a -> a -> IO ()
putMVar (JSContextRef -> MVar (Set Text)
finalizerThreads JSContextRef
ctx) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. a -> IO a
evaluate (forall a. Ord a => a -> Set a -> Set a
S.insert Text
tname Set Text
ft)
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef JSValueRef -> JSVal
JSVal IORef JSValueRef
ref)
#endif