diff --git a/jsaddle.cabal b/jsaddle.cabal --- a/jsaddle.cabal +++ b/jsaddle.cabal @@ -1,5 +1,5 @@ name: jsaddle -version: 0.8.3.2 +version: 0.9.0.0 cabal-version: >=1.10 build-type: Simple license: MIT diff --git a/src-ghc/JavaScript/Array/Internal.hs b/src-ghc/JavaScript/Array/Internal.hs --- a/src-ghc/JavaScript/Array/Internal.hs +++ b/src-ghc/JavaScript/Array/Internal.hs @@ -21,8 +21,6 @@ import Language.Javascript.JSaddle.Types (JSM, SomeJSArray(..), JSArray, MutableJSArray, STJSArray, Object(..), GHCJSPure(..)) import Language.Javascript.JSaddle.Native.Internal (newArray, getPropertyByName, getPropertyAtIndex, callAsFunction, valueToNumber) -import Language.Javascript.JSaddle.Run - (Command(..), Result(..), AsyncCommand(..), sendCommand, sendLazyCommand) create :: JSM MutableJSArray create = SomeJSArray <$> newArray [] diff --git a/src/Language/Javascript/JSaddle/Native/Internal.hs b/src/Language/Javascript/JSaddle/Native/Internal.hs --- a/src/Language/Javascript/JSaddle/Native/Internal.hs +++ b/src/Language/Javascript/JSaddle/Native/Internal.hs @@ -27,7 +27,8 @@ , callAsFunction , callAsConstructor , newEmptyObject - , newCallback + , newAsyncCallback + , newSyncCallback , newArray , evaluateScript , deRefVal @@ -54,7 +55,7 @@ JSStringReceived(..), JSStringForSend(..), JSObjectForSend(..)) import Language.Javascript.JSaddle.Monad (askJSM) import Language.Javascript.JSaddle.Run - (Command(..), AsyncCommand(..), Result(..), sendCommand, + (Command(..), Result(..), sendCommand, sendAsyncCommand, sendLazyCommand, wrapJSVal) wrapJSString :: MonadIO m => JSStringReceived -> m JSString @@ -136,13 +137,21 @@ newEmptyObject = Object <$> sendLazyCommand NewEmptyObject {-# INLINE newEmptyObject #-} -newCallback :: JSCallAsFunction -> JSM Object -newCallback f = do - object <- Object <$> sendLazyCommand NewCallback +newAsyncCallback :: JSCallAsFunction -> JSM Object +newAsyncCallback f = do + object <- Object <$> sendLazyCommand NewAsyncCallback add <- addCallback <$> askJSM liftIO $ add object f return object -{-# INLINE newCallback #-} +{-# INLINE newAsyncCallback #-} + +newSyncCallback :: JSCallAsFunction -> JSM Object +newSyncCallback f = do + object <- Object <$> sendLazyCommand NewSyncCallback + add <- addCallback <$> askJSM + liftIO $ add object f + return object +{-# INLINE newSyncCallback #-} newArray :: [JSVal] -> JSM JSVal newArray xs = withJSVals xs $ \xs' -> sendLazyCommand (NewArray xs') diff --git a/src/Language/Javascript/JSaddle/Object.hs b/src/Language/Javascript/JSaddle/Object.hs --- a/src/Language/Javascript/JSaddle/Object.hs +++ b/src/Language/Javascript/JSaddle/Object.hs @@ -66,6 +66,7 @@ -- * Calling Haskell From JavaScript , Function(..) , function + , asyncFunction , freeFunction , fun , JSCallAsFunction @@ -102,7 +103,7 @@ #ifdef ghcjs_HOST_OS import GHCJS.Types (nullRef) import GHCJS.Foreign.Callback - (releaseCallback, syncCallback2, OnBlocked(..), Callback) + (releaseCallback, syncCallback2, asyncCallback2, OnBlocked(..), Callback) import GHCJS.Marshal (ToJSVal(..)) import JavaScript.Array (MutableJSArray) import qualified JavaScript.Array as Array (toListIO, fromListIO) @@ -115,7 +116,7 @@ #else import GHCJS.Marshal.Internal (ToJSVal(..)) import Language.Javascript.JSaddle.Native - (newCallback, callAsFunction, callAsConstructor) + (newAsyncCallback, newSyncCallback, callAsFunction, callAsConstructor) import Language.Javascript.JSaddle.Monad (askJSM, JSM) import Language.Javascript.JSaddle.Types (JSString, Object(..), SomeJSArray(..), @@ -435,9 +436,16 @@ #endif +#ifdef ghcjs_HOST_OS +foreign import javascript unsafe "$r = function () { $1(this, arguments); }" + makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object +#endif + -- ^ Make a JavaScript function object that wraps a Haskell function. +-- Calls made to the function will be synchronous where possible +-- (on GHCJS it uses on `syncCallback2` with `ContinueAsync`). function :: JSCallAsFunction -- ^ Haskell function to call - -> JSM Function -- ^ Returns a JavaScript function object that will + -> JSM Function -- ^ Returns a JavaScript function object that will -- call the Haskell one when it is called #ifdef ghcjs_HOST_OS function f = do @@ -445,11 +453,26 @@ rargs <- Array.toListIO (coerce args) f this this rargs -- TODO pass function object through Function callback <$> makeFunctionWithCallback callback -foreign import javascript unsafe "$r = function () { $1(this, arguments); }" - makeFunctionWithCallback :: Callback (JSVal -> JSVal -> IO ()) -> IO Object #else function f = do - object <- newCallback f + object <- newSyncCallback f + return $ Function object +#endif + +-- ^ Make a JavaScript function object that wraps a Haskell function. +-- Calls made to the function will be Asynchronous. +asyncFunction :: JSCallAsFunction -- ^ Haskell function to call + -> JSM Function -- ^ Returns a JavaScript function object that will + -- call the Haskell one when it is called +#ifdef ghcjs_HOST_OS +asyncFunction f = do + callback <- asyncCallback2 $ \this args -> do + rargs <- Array.toListIO (coerce args) + f this this rargs -- TODO pass function object through + Function callback <$> makeFunctionWithCallback callback +#else +asyncFunction f = do + object <- newAsyncCallback f return $ Function object #endif diff --git a/src/Language/Javascript/JSaddle/Run.hs b/src/Language/Javascript/JSaddle/Run.hs --- a/src/Language/Javascript/JSaddle/Run.hs +++ b/src/Language/Javascript/JSaddle/Run.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} @@ -49,7 +50,7 @@ import Control.Concurrent.STM.TVar (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO) import Control.Concurrent.MVar - (MVar, MVar, putMVar, takeMVar, newEmptyMVar) + (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar, readMVar) import System.IO.Unsafe (unsafeInterleaveIO) import System.Mem.Weak (addFinalizer) @@ -61,12 +62,14 @@ import Data.IORef (newIORef, atomicWriteIORef, readIORef) import Language.Javascript.JSaddle.Types - (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..), + (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..), Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..)) import Language.Javascript.JSaddle.Exception (JSException(..)) -- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal) import Control.DeepSeq (deepseq) import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..)) +import Data.Maybe (isJust) +import Data.Foldable (forM_) #endif -- | Enable (or disable) JSaddle logging @@ -146,10 +149,11 @@ s <- doSendAsyncCommand <$> JSM ask liftIO $ s cmd -runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ()) +runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ()) runJavaScript sendBatch entryPoint = do startTime' <- getCurrentTime recvMVar <- newEmptyMVar + lastAsyncBatch <- newEmptyMVar commandChan <- newTChanIO callbacks <- newTVarIO M.empty nextRef' <- newTVarIO 0 @@ -169,17 +173,33 @@ , nextRef = nextRef' , doEnableLogging = atomicWriteIORef loggingEnabled } - let processResults = \case + let processResults :: Bool -> Results -> IO () + processResults syncCallbacks = \case (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err - (Callback f this a) -> do - logInfo ("Call " <>) + (Callback n br f this a) -> do + putMVar recvMVar (n, br) f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx this' <- runReaderT (unJSM $ wrapJSVal this) ctx args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx + logInfo (("Call " <> show fNumber <> " ") <>) (M.lookup fNumber <$> liftIO (readTVarIO callbacks)) >>= \case Nothing -> liftIO $ putStrLn "Callback called after it was freed" - Just cb -> void . forkIO $ runReaderT (unJSM $ cb f' this' args) ctx - m -> putMVar recvMVar m + Just cb -> void . forkIO $ do + runReaderT (unJSM $ cb f' this' args) ctx + when syncCallbacks $ + doSendAsyncCommand ctx EndSyncBlock + Duplicate nBatch nExpected -> do + putStrLn $ "Error : Unexpected Duplicate. syncCallbacks=" <> show syncCallbacks <> + " nBatch=" <> show nBatch <> " nExpected=" <> show nExpected + void $ doSendCommand ctx Sync + BatchResults n br -> putMVar recvMVar (n, br) + asyncResults :: Results -> IO () + asyncResults results = + void . forkIO $ processResults False results + syncResults :: Results -> IO Batch + syncResults results = do + void . forkIO $ processResults True results + readMVar lastAsyncBatch logInfo s = readIORef loggingEnabled >>= \case True -> do @@ -189,23 +209,34 @@ cbCount <- M.size <$> readTVarIO callbacks putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount False -> return () - _ <- forkIO . forever $ readBatch commandChan >>= \case - (batch@(Batch cmds _), resultMVars) -> do + _ <- forkIO . numberForeverFromM_ 1 $ \nBatch -> + readBatch nBatch commandChan >>= \case + (batch@(Batch cmds _ _), resultMVars) -> do logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds)) + _ <- tryTakeMVar lastAsyncBatch + putMVar lastAsyncBatch batch sendBatch batch - takeMVar recvMVar >>= \case - Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results" - | otherwise -> zipWithM_ putMVar resultMVars results - Failure results exception -> do - -- The exception will only be rethrown in Haskell if/when one of the - -- missing results (if any) is evaluated. - putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)" - zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception) - _ -> error "Unexpected jsaddle results" - return (processResults, runReaderT (unJSM entryPoint) ctx) + takeResult recvMVar nBatch >>= \case + (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")" + (_, Success results) | length results /= length resultMVars -> error "Unexpected number of jsaddle results" + | otherwise -> zipWithM_ putMVar resultMVars results + (_, Failure results exception) -> do + -- The exception will only be rethrown in Haskell if/when one of the + -- missing results (if any) is evaluated. + putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)" + zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception) + return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx) where - readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result]) - readBatch chan = do + numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m () + numberForeverFromM_ !n f = do + f n + numberForeverFromM_ (succ n) f + takeResult recvMVar nBatch = + takeMVar recvMVar >>= \case + (n, _) | n < nBatch -> takeResult recvMVar nBatch + r -> return r + readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result]) + readBatch nBatch chan = do first <- atomically $ readTChan chan -- We want at least one command to send loop first ([], []) where @@ -216,17 +247,17 @@ let cmds = Right syncCmd:cmds' resultMVars = resultMVar:resultMVars' atomically (tryReadTChan chan) >>= \case - Nothing -> return (Batch (reverse cmds) False, reverse resultMVars) + Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars) Just cmd -> loop cmd (cmds, resultMVars) loop (Left asyncCmd) (cmds', resultMVars) = do let cmds = Left asyncCmd:cmds' atomically (tryReadTChan chan) >>= \case - Nothing -> return (Batch (reverse cmds) False, reverse resultMVars) + Nothing -> return (Batch (reverse cmds) False nBatch, reverse resultMVars) Just cmd -> loop cmd (cmds, 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 (Right (Sync, resultMVar)) (cmds, resultMVars) = - return (Batch (reverse (Right Sync:cmds)) True, reverse (resultMVar:resultMVars)) + return (Batch (reverse (Right Sync:cmds)) True nBatch, reverse (resultMVar:resultMVars)) loopAnimation (Right (syncCmd, resultMVar)) (cmds, resultMVars) = atomically (readTChan chan) >>= \cmd -> loopAnimation cmd (Right syncCmd:cmds, resultMVar:resultMVars) loopAnimation (Left asyncCmd) (cmds, resultMVars) = diff --git a/src/Language/Javascript/JSaddle/Run/Files.hs b/src/Language/Javascript/JSaddle/Run/Files.hs --- a/src/Language/Javascript/JSaddle/Run/Files.hs +++ b/src/Language/Javascript/JSaddle/Run/Files.hs @@ -43,13 +43,23 @@ \ jsaddle_values.set(3, true);\n\ \ jsaddle_values.set(4, window);\n\ \ var jsaddle_index = 100;\n\ + \ var expectedBatch = 1;\n\ + \ var lastResults = [0, {}];\n\ + \ var inCallback = 0;\n\ \" -runBatch :: (ByteString -> ByteString) -> ByteString -runBatch send = "\ +runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString +runBatch send sendSync = "\ + \ var runBatch = function(firstBatch, initialSyncDepth) {\n\ \ var processBatch = function(timestamp) {\n\ - \ var results = [];\n\ - \ try {\n\ + \ var batch = firstBatch;\n\ + \ var results = [];\n\ + \ inCallback++;\n\ + \ try {\n\ + \ syncDepth = initialSyncDepth || 0;\n\ + \ for(;;){\n\ + \ if(batch[2] === expectedBatch) {\n\ + \ expectedBatch++;\n\ \ var nCommandsLength = batch[0].length;\n\ \ for (var nCommand = 0; nCommand != nCommandsLength; nCommand++) {\n\ \ var cmd = batch[0][nCommand];\n\ @@ -89,7 +99,7 @@ \ var n = d.contents;\n\ \ jsaddle_values.set(n, {});\n\ \ break;\n\ - \ case \"NewCallback\":\n\ + \ case \"NewAsyncCallback\":\n\ \ (function() {\n\ \ var nFunction = d.contents;\n\ \ jsaddle_values.set(nFunction, function() {\n\ @@ -101,9 +111,33 @@ \ jsaddle_values.set(nArg, arguments[i]);\n\ \ args[i] = nArg;\n\ \ }\n\ - \ " <> send "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> "\n\ + \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n\ \ })})();\n\ \ break;\n\ + \ case \"NewSyncCallback\":\n\ + \ (function() {\n\ + \ var nFunction = d.contents;\n\ + \ jsaddle_values.set(nFunction, function() {\n\ + \ var nThis = ++jsaddle_index;\n\ + \ jsaddle_values.set(nThis, this);\n\ + \ var args = [];\n\ + \ for (var i = 0; i != arguments.length; i++) {\n\ + \ var nArg = ++jsaddle_index;\n\ + \ jsaddle_values.set(nArg, arguments[i]);\n\ + \ args[i] = nArg;\n\ + \ }\n" <> ( + case sendSync of + Just s -> + " if(inCallback > 0) {\n\ + \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n\ + \ } else {\n\ + \ runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> ", 1);\n\ + \ }\n" + Nothing -> + " " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n" + ) <> + " })})();\n\ + \ break;\n\ \ case \"CallAsFunction\":\n\ \ var n = d.contents[3];\n\ \ jsaddle_values.set(n,\n\ @@ -148,6 +182,12 @@ \ var n = d.contents[0];\n\ \ jsaddle_values.set(n, timestamp);\n\ \ break;\n\ + \ case \"StartSyncBlock\":\n\ + \ syncDepth++;\n\ + \ break;\n\ + \ case \"EndSyncBlock\":\n\ + \ syncDepth--;\n\ + \ break;\n\ \ default:\n\ \ " <> send "{\"tag\": \"ProtocolError\", \"contents\": e.data}" <> "\n\ \ return;\n\ @@ -210,20 +250,56 @@ \ }\n\ \ }\n\ \ }\n\ - \ " <> send "{\"tag\": \"Success\", \"contents\": results}" <> "\n\ - \ }\n\ - \ catch (err) {\n\ - \ var n = ++jsaddle_index;\n\ - \ jsaddle_values.set(n, err);\n\ - \ " <> send "{\"tag\": \"Failure\", \"contents\": [results,n]}" <> "\n\ + \ if(syncDepth <= 0) {\n\ + \ lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\ + \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> "\n\ + \ break;\n\ + \ } else {\n" <> ( + case sendSync of + Just s -> + " lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\ + \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\ + \ results = [];\n" + Nothing -> + " " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Success\", \"contents\": results}]}" <> "\n\ + \ break;\n" + ) <> + " }\n\ + \ } else {\n\ + \ if(syncDepth <= 0) {\n\ + \ break;\n\ + \ } else {\n" <> ( + case sendSync of + Just s -> + " if(batch[2] === expectedBatch - 1) {\n\ + \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\ + \ } else {\n\ + \ batch = " <> s "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> ";\n\ + \ }\n\ + \ results = [];\n" + Nothing -> + " " <> send "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> "\n\ + \ break;\n" + ) <> + " }\n\ + \ }\n\ \ }\n\ + \ }\n\ + \ catch (err) {\n\ + \ var n = ++jsaddle_index;\n\ + \ jsaddle_values.set(n, err);\n\ + \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Failure\", \"contents\": [results, n]}]}" <> "\n\ + \ }\n\ + \ inCallback--;\n\ \ };\n\ - \ if(batch[1]) {\n\ + \ if(batch[1] && (initialSyncDepth || 0) === 0) {\n\ \ window.requestAnimationFrame(processBatch);\n\ \ }\n\ \ else {\n\ \ processBatch(window.performance ? window.performance.now() : null);\n\ \ }\n\ + \ };\n\ + \ runBatch(batch);\n\ \" -- Use this to generate this string for embedding @@ -249,7 +325,7 @@ \ ws.onmessage = function(e) {\n\ \ var batch = JSON.parse(e.data);\n\ \\n\ - \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));") <> "\ + \ " <> runBatch (\a -> "ws.send(JSON.stringify(" <> a <> "));") Nothing <> "\ \ };\n\ \ };\n\ \ ws.onerror = function() {\n\ diff --git a/src/Language/Javascript/JSaddle/Types.hs b/src/Language/Javascript/JSaddle/Types.hs --- a/src/Language/Javascript/JSaddle/Types.hs +++ b/src/Language/Javascript/JSaddle/Types.hs @@ -14,6 +14,7 @@ #endif {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE AllowAmbiguousTypes #-} ----------------------------------------------------------------------------- -- -- Module : Language.Javascript.JSaddle.Types @@ -73,6 +74,7 @@ , Command(..) , Batch(..) , Result(..) + , BatchResults(..) , Results(..) #endif ) where @@ -87,10 +89,19 @@ import GHCJS.Prim.Internal (JSVal(..), JSValueRef) import Data.JSString.Internal.Type (JSString(..)) import Control.DeepSeq (NFData(..)) +import Control.Monad.Trans.Cont (ContT(..)) +import Control.Monad.Trans.Error (Error(..), ErrorT(..)) +import Control.Monad.Trans.Except (ExceptT(..)) +import Control.Monad.Trans.Identity (IdentityT(..)) +import Control.Monad.Trans.List (ListT(..)) +import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Reader (ReaderT(..)) -import Control.Monad.Trans.State.Lazy (StateT(..)) -import qualified Control.Monad.Trans.State.Strict as Strict - (StateT(..)) +import Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..)) +import Control.Monad.Trans.RWS.Strict as Strict (RWST(..)) +import Control.Monad.Trans.State.Lazy as Lazy (StateT(..)) +import Control.Monad.Trans.State.Strict as Strict (StateT(..)) +import Control.Monad.Trans.Writer.Lazy as Lazy (WriterT(..)) +import Control.Monad.Trans.Writer.Strict as Strict (WriterT(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.Fix (MonadFix) import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..)) @@ -191,23 +202,28 @@ #else class (Applicative m, MonadIO m) => MonadJSM m where liftJSM' :: JSM a -> m a - {-# MINIMAL liftJSM' #-} -instance MonadJSM JSM where - liftJSM' = id - {-# INLINE liftJSM' #-} - -instance MonadJSM m => MonadJSM (ReaderT e m) where - liftJSM' = lift . liftJSM' + default liftJSM' :: (MonadJSM m', MonadTrans t) => JSM a' -> t m' a' + liftJSM' = lift . (liftJSM' :: MonadJSM m' => JSM a -> m' a) {-# INLINE liftJSM' #-} -instance MonadJSM m => MonadJSM (StateT r m) where - liftJSM' = lift . liftJSM' +instance MonadJSM JSM where + liftJSM' = id {-# INLINE liftJSM' #-} -instance MonadJSM m => MonadJSM (Strict.StateT r m) where - liftJSM' = lift . liftJSM' - {-# INLINE liftJSM' #-} +instance (MonadJSM m) => MonadJSM (ContT r m) +instance (Error e, MonadJSM m) => MonadJSM (ErrorT e m) +instance (MonadJSM m) => MonadJSM (ExceptT e m) +instance (MonadJSM m) => MonadJSM (IdentityT m) +instance (MonadJSM m) => MonadJSM (ListT m) +instance (MonadJSM m) => MonadJSM (MaybeT m) +instance (MonadJSM m) => MonadJSM (ReaderT r m) +instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.RWST r w s m) +instance (Monoid w, MonadJSM m) => MonadJSM (Strict.RWST r w s m) +instance (MonadJSM m) => MonadJSM (Lazy.StateT s m) +instance (MonadJSM m) => MonadJSM (Strict.StateT s m) +instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.WriterT w m) +instance (Monoid w, MonadJSM m) => MonadJSM (Strict.WriterT w m) instance MonadRef JSM where type Ref JSM = Ref IO @@ -315,11 +331,14 @@ | CallAsFunction JSObjectForSend JSObjectForSend [JSValueForSend] JSValueForSend | CallAsConstructor JSObjectForSend [JSValueForSend] JSValueForSend | NewEmptyObject JSValueForSend - | NewCallback JSValueForSend + | NewAsyncCallback JSValueForSend + | NewSyncCallback JSValueForSend | NewArray [JSValueForSend] JSValueForSend | EvaluateScript JSStringForSend JSValueForSend | SyncWithAnimationFrame JSValueForSend - deriving (Show, Generic) + | StartSyncBlock + | EndSyncBlock + deriving (Show, Generic) instance ToJSON AsyncCommand where toEncoding = genericToEncoding defaultOptions @@ -351,7 +370,7 @@ instance NFData Command -- | Batch of commands that can be sent together to the JavaScript context -data Batch = Batch [Either AsyncCommand Command] Bool +data Batch = Batch [Either AsyncCommand Command] Bool Int deriving (Show, Generic) instance ToJSON Batch where @@ -382,9 +401,18 @@ instance FromJSON Result -data Results = Success [Result] - | Failure [Result] JSValueReceived - | Callback JSValueReceived JSValueReceived [JSValueReceived] +data BatchResults = Success [Result] + | Failure [Result] JSValueReceived + deriving (Show, Generic) + +instance ToJSON BatchResults where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON BatchResults + +data Results = BatchResults Int BatchResults + | Duplicate Int Int + | Callback Int BatchResults JSValueReceived JSValueReceived [JSValueReceived] | ProtocolError Text deriving (Show, Generic)