jsaddle 0.9.2.1 → 0.9.3.0
raw patch · 8 files changed
+103/−58 lines, 8 filesdep +randomdep −uuiddep −uuid-types
Dependencies added: random
Dependencies removed: uuid, uuid-types
Files
- jsaddle.cabal +3/−3
- src-ghc/GHCJS/Concurrent.hs +22/−0
- src/Language/Javascript/JSaddle/Debug.hs +4/−4
- src/Language/Javascript/JSaddle/Null.hs +1/−1
- src/Language/Javascript/JSaddle/Object.hs +5/−5
- src/Language/Javascript/JSaddle/Run.hs +35/−27
- src/Language/Javascript/JSaddle/Run/Files.hs +20/−6
- src/Language/Javascript/JSaddle/Types.hs +13/−12
jsaddle.cabal view
@@ -1,5 +1,5 @@ name: jsaddle-version: 0.9.2.1+version: 0.9.3.0 cabal-version: >=1.10 build-type: Simple license: MIT@@ -42,13 +42,12 @@ ghc-prim, http-types >=0.8.6 && <0.10, process >=1.2.3.0 && <1.5,+ random >= 1.1 && < 1.2, ref-tf >=0.4.0.1 && <0.5, scientific >=0.3 && <0.4, stm >=2.4.4 && <2.5, time >=1.5.0.1 && <1.8, unordered-containers >=0.2 && <0.3,- uuid >=1.3.13 && <1.4,- uuid-types >=1.0.3 && <1.1, vector >=0.10 && <0.13 exposed-modules: Data.JSString@@ -63,6 +62,7 @@ GHCJS.Prim GHCJS.Prim.Internal GHCJS.Types+ GHCJS.Concurrent GHCJS.Foreign GHCJS.Foreign.Internal GHCJS.Internal.Types
+ src-ghc/GHCJS/Concurrent.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveDataTypeable #-}++module GHCJS.Concurrent ( OnBlocked(..)+ , WouldBlockException(..)+ ) where++import GHCJS.Prim++import Data.Data++{- |+ The runtime tries to run synchronous threads to completion. Sometimes it's+ not possible to continue running a thread, for example when the thread+ tries to take an empty 'MVar'. The runtime can then either throw a+ 'WouldBlockException', aborting the blocking action, or continue the+ thread asynchronously.+ -}++data OnBlocked = ContinueAsync -- ^ continue the thread asynchronously if blocked+ | ThrowWouldBlock -- ^ throw 'WouldBlockException' if blocked+ deriving (Data, Typeable, Enum, Show, Eq, Ord)+
src/Language/Javascript/JSaddle/Debug.hs view
@@ -26,7 +26,7 @@ import System.IO.Unsafe (unsafePerformIO) import Data.Monoid ((<>)) import Control.Monad.IO.Class (MonadIO(..))-import Data.UUID (UUID)+import Data.Int (Int64) contexts :: IORef [JSContextRef] contexts = unsafePerformIO $ newIORef []@@ -37,9 +37,9 @@ ctx <- askJSM liftIO $ atomicModifyIORef' contexts $ \c -> (c <> [ctx], ()) -removeContext :: MonadIO m => UUID -> m ()-removeContext uuid =- liftIO $ atomicModifyIORef' contexts $ \c -> (filter ((/= uuid) . contextId) c, ())+removeContext :: MonadIO m => Int64 -> m ()+removeContext cid =+ liftIO $ atomicModifyIORef' contexts $ \c -> (filter ((/= cid) . contextId) c, ()) runOnAll :: MonadIO m => JSM a -> m [a] runOnAll f = liftIO (readIORef contexts) >>= mapM (runJSM f)
src/Language/Javascript/JSaddle/Null.hs view
@@ -37,7 +37,7 @@ _ <- forkIO $ forever $ readChan batches >>= \case Batch commands _ batchNumber ->- processResult $ BatchResults batchNumber . Success $ mapMaybe (\case+ processResult $ BatchResults batchNumber . Success [] $ mapMaybe (\case Left _ -> Nothing Right command -> Just $ case command of
src/Language/Javascript/JSaddle/Object.hs view
@@ -119,9 +119,10 @@ (newAsyncCallback, newSyncCallback, callAsFunction, callAsConstructor) import Language.Javascript.JSaddle.Monad (askJSM, JSM) import Language.Javascript.JSaddle.Types- (JSString, Object(..), SomeJSArray(..),- JSVal(..), JSCallAsFunction, JSContextRef(..))+ (JSValueForSend(..), AsyncCommand(..), JSString, Object(..),+ SomeJSArray(..), JSVal(..), JSCallAsFunction, JSContextRef(..)) import JavaScript.Object.Internal (create, listProps)+import Language.Javascript.JSaddle.Run (sendAsyncCommand) #endif import JavaScript.Array.Internal (fromListIO) import Language.Javascript.JSaddle.Value (valToObject)@@ -481,9 +482,8 @@ freeFunction (Function callback _) = liftIO $ releaseCallback callback #else-freeFunction (Function object) = do- free <- freeCallback <$> askJSM- liftIO $ free object+freeFunction (Function (Object (JSVal objectRef))) =+ sendAsyncCommand (FreeCallback (JSValueForSend objectRef)) #endif instance ToJSVal Function where
src/Language/Javascript/JSaddle/Run.hs view
@@ -56,6 +56,7 @@ import System.IO.Unsafe (unsafeInterleaveIO) import System.Mem.Weak (addFinalizer)+import System.Random import GHC.Base (IO(..), mkWeak#) import GHC.Conc (ThreadId(..))@@ -63,7 +64,6 @@ 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.UUID.V4 (nextRandom) import Data.Time.Clock (getCurrentTime,diffUTCTime) import Data.IORef (newIORef, atomicWriteIORef, readIORef) @@ -73,6 +73,7 @@ import Language.Javascript.JSaddle.Exception (JSException(..)) import Control.DeepSeq (deepseq) import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))+import Data.Foldable (forM_) #endif -- | Enable (or disable) JSaddle logging@@ -154,7 +155,7 @@ runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ()) runJavaScript sendBatch entryPoint = do- contextId' <- nextRandom+ contextId' <- randomIO startTime' <- getCurrentTime recvMVar <- newEmptyMVar lastAsyncBatch <- newEmptyMVar@@ -162,25 +163,26 @@ callbacks <- newTVarIO M.empty nextRef' <- newTVarIO 0 finalizerThreads' <- newMVar S.empty+ animationFrameHandlers' <- newMVar [] loggingEnabled <- newIORef False let ctx = JSContextRef {- contextId = contextId'- , startTime = startTime'- , doSendCommand = \cmd -> cmd `deepseq` do- result <- newEmptyMVar- atomically $ writeTChan commandChan (Right (cmd, result))- unsafeInterleaveIO $- takeMVar result >>= \case- (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)- r -> return r- , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)- , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb)- , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val)- , nextRef = nextRef'- , doEnableLogging = atomicWriteIORef loggingEnabled- , finalizerThreads = finalizerThreads'- }- let processResults :: Bool -> Results -> IO ()+ contextId = contextId'+ , startTime = startTime'+ , doSendCommand = \cmd -> cmd `deepseq` do+ result <- newEmptyMVar+ atomically $ writeTChan commandChan (Right (cmd, result))+ unsafeInterleaveIO $+ takeMVar result >>= \case+ (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)+ r -> return r+ , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)+ , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb)+ , nextRef = nextRef'+ , doEnableLogging = atomicWriteIORef loggingEnabled+ , finalizerThreads = finalizerThreads'+ , animationFrameHandlers = animationFrameHandlers'+ }+ processResults :: Bool -> Results -> IO () processResults syncCallbacks = \case (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err (Callback n br (JSValueReceived fNumber) f this a) -> do@@ -224,14 +226,20 @@ putMVar lastAsyncBatch batch sendBatch batch 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)+ (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"+ (_, Success callbacksToFree results)+ | length results /= length resultMVars -> error "Unexpected number of jsaddle results"+ | otherwise -> do+ zipWithM_ putMVar resultMVars results+ forM_ callbacksToFree $ \(JSValueReceived val) ->+ atomically (modifyTVar' callbacks (M.delete val))+ (_, Failure callbacksToFree 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)+ forM_ callbacksToFree $ \(JSValueReceived val) ->+ atomically (modifyTVar' callbacks (M.delete val)) return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx) where numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()
src/Language/Javascript/JSaddle/Run/Files.hs view
@@ -47,6 +47,7 @@ \ var expectedBatch = 1;\n\ \ var lastResults = [0, {}];\n\ \ var inCallback = 0;\n\+ \ var asyncBatch = null;\n\ \" runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString@@ -54,6 +55,7 @@ \ var runBatch = function(firstBatch, initialSyncDepth) {\n\ \ var processBatch = function(timestamp) {\n\ \ var batch = firstBatch;\n\+ \ var callbacksToFree = [];\n\ \ var results = [];\n\ \ inCallback++;\n\ \ try {\n\@@ -155,6 +157,9 @@ \ jsaddle_values.set(nFunction, func);\n\ \ })();\n\ \ break;\n\+ \ case \"FreeCallback\":\n\+ \ callbacksToFree.push(d.contents);\n\+ \ break;\n\ \ case \"CallAsFunction\":\n\ \ var n = d.contents[3];\n\ \ jsaddle_values.set(n,\n\@@ -268,17 +273,18 @@ \ }\n\ \ }\n\ \ if(syncDepth <= 0) {\n\- \ lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\+ \ lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, 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\+ " lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}];\n\ \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\- \ results = [];\n"+ \ results = [];\n\+ \ callbacksToFree = [];\n" Nothing ->- " " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Success\", \"contents\": results}]}" <> "\n\+ " " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Success\", \"contents\": [callbacksToFree, results]}]}" <> "\n\ \ break;\n" ) <> " }\n\@@ -293,7 +299,8 @@ \ } else {\n\ \ batch = " <> s "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> ";\n\ \ }\n\- \ results = [];\n"+ \ results = [];\n\+ \ callbacksToFree = [];\n" Nothing -> " " <> send "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> "\n\ \ break;\n"@@ -305,7 +312,14 @@ \ 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\+ \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Failure\", \"contents\": [callbacksToFree, results, n]}]}" <> "\n\+ \ }\n\+ \ if(inCallback == 1) {\n\+ \ while(asyncBatch !== null) {\n\+ \ var b = asyncBatch;\n\+ \ asyncBatch = null;\n\+ \ if(b[2] == expectedBatch) runBatch(b);\n\+ \ }\n\ \ }\n\ \ inCallback--;\n\ \ };\n\
src/Language/Javascript/JSaddle/Types.hs view
@@ -107,9 +107,9 @@ import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..)) import Control.Concurrent.STM.TVar (TVar) import Control.Concurrent.MVar (MVar)+import Data.Int (Int64) import Data.Set (Set) import Data.Text (Text)-import Data.UUID (UUID) import Data.Time.Clock (UTCTime(..)) import Data.Typeable (Typeable) import Data.Coerce (coerce, Coercible)@@ -132,15 +132,15 @@ type JSContextRef = () #else data JSContextRef = JSContextRef {- contextId :: UUID- , startTime :: UTCTime- , doSendCommand :: Command -> IO Result- , doSendAsyncCommand :: AsyncCommand -> IO ()- , addCallback :: Object -> JSCallAsFunction -> IO ()- , freeCallback :: Object -> IO ()- , nextRef :: TVar JSValueRef- , doEnableLogging :: Bool -> IO ()- , finalizerThreads :: MVar (Set Text)+ contextId :: Int64+ , startTime :: UTCTime+ , doSendCommand :: Command -> IO Result+ , doSendAsyncCommand :: AsyncCommand -> IO ()+ , addCallback :: Object -> JSCallAsFunction -> IO ()+ , nextRef :: TVar JSValueRef+ , doEnableLogging :: Bool -> IO ()+ , finalizerThreads :: MVar (Set Text)+ , animationFrameHandlers :: MVar [Double -> JSM ()] } #endif @@ -377,6 +377,7 @@ | NewEmptyObject JSValueForSend | NewAsyncCallback JSValueForSend | NewSyncCallback JSValueForSend+ | FreeCallback JSValueForSend | NewArray [JSValueForSend] JSValueForSend | EvaluateScript JSStringForSend JSValueForSend | SyncWithAnimationFrame JSValueForSend@@ -445,8 +446,8 @@ instance FromJSON Result -data BatchResults = Success [Result]- | Failure [Result] JSValueReceived+data BatchResults = Success [JSValueReceived] [Result]+ | Failure [JSValueReceived] [Result] JSValueReceived deriving (Show, Generic) instance ToJSON BatchResults where