{-# 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 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

-- | 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 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

-- | 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
    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
                        -- 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
                        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 -- 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) =
            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)
        -- 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) =
            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