jsaddle 0.9.0.0 → 0.9.2.0

raw patch · 5 files changed

+168/−19 lines, 5 filesdep +uuiddep +uuid-typesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: uuid, uuid-types

API changes (from Hackage documentation)

Files

• jsaddle.cabal +5/−1
• src/Language/Javascript/JSaddle/Debug.hs +48/−0
• src/Language/Javascript/JSaddle/Null.hs +56/−0
• src/Language/Javascript/JSaddle/Run.hs +5/−4
• src/Language/Javascript/JSaddle/Types.hs +54/−14

@@ -1,5 +1,5 @@ name: jsaddle-version: 0.9.0.0+version: 0.9.2.0 cabal-version: >=1.10 build-type: Simple license: MIT@@ -47,6 +47,8 @@             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@@ -81,8 +83,10 @@             JavaScript.Array.Internal             JavaScript.Object             JavaScript.Object.Internal+            Language.Javascript.JSaddle.Debug             Language.Javascript.JSaddle.Native             Language.Javascript.JSaddle.Native.Internal+            Language.Javascript.JSaddle.Null         hs-source-dirs: src-ghc     exposed-modules:         Language.Javascript.JSaddle

@@ -0,0 +1,48 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+--+-- Module      :  Language.Javascript.JSaddle.WebSockets+-- Copyright   :  (c) Hamish Mackenzie+-- License     :  MIT+--+-- Maintainer  :  Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>+--+-- |+--+-----------------------------------------------------------------------------++module Language.Javascript.JSaddle.Debug (+    contexts+  , addContext+  , removeContext+  , runOnAll+  , runOnAll_+) where++import Language.Javascript.JSaddle+       (runJSM, askJSM, JSM, JSContextRef(..))+import Data.IORef (readIORef, atomicModifyIORef', newIORef, IORef)+import System.IO.Unsafe (unsafePerformIO)+import Data.Monoid ((<>))+import Control.Monad.IO.Class (MonadIO(..))+import Data.UUID (UUID)++contexts :: IORef [JSContextRef]+contexts = unsafePerformIO $ newIORef []+{-# NOINLINE contexts #-}++addContext :: JSM ()+addContext = do+    ctx <- askJSM+    liftIO $ atomicModifyIORef' contexts $ \c -> (c <> [ctx], ())++removeContext :: MonadIO m => UUID -> m ()+removeContext uuid =+    liftIO $ atomicModifyIORef' contexts $ \c -> (filter ((/= uuid) . contextId) c, ())++runOnAll :: MonadIO m => JSM a -> m [a]+runOnAll f = liftIO (readIORef contexts) >>= mapM (runJSM f)++runOnAll_ :: MonadIO m => JSM a -> m ()+runOnAll_ f = liftIO (readIORef contexts) >>= mapM_ (runJSM f)

@@ -0,0 +1,56 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+--+-- Module      :  Language.Javascript.JSaddle.WebSockets+-- Copyright   :  (c) Hamish Mackenzie+-- License     :  MIT+--+-- Maintainer  :  Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com>+--+-- |+--+-----------------------------------------------------------------------------++module Language.Javascript.JSaddle.Null (+    run+) where++import Language.Javascript.JSaddle.Types+       (BatchResults(..), JSM, JSStringReceived(..), Batch(..),+        Results(..), Result(..), Command(..))+import Control.Concurrent.Chan (readChan, writeChan, newChan)+import Language.Javascript.JSaddle.Run (runJavaScript)+import Control.Concurrent (forkIO)+import Control.Monad (forever)+import Data.Aeson (Value(..))+import Data.Maybe (mapMaybe)++-- | This is for performance testing JSaddle code that does not need to+-- to read anything back from the JavaScript context.+-- Anthing that does try to read will get JS null, 0 or "" back (depending+-- on how the value is read).+run :: JSM () -> IO ()+run f = do+    batches <- newChan+    (processResult, _processSyncResult, start) <- runJavaScript (writeChan batches) f+    _ <- forkIO $ forever $+        readChan batches >>= \case+            Batch commands _ batchNumber ->+                processResult $ BatchResults batchNumber . Success $ mapMaybe (\case+                        Left _ -> Nothing+                        Right command -> Just $+                            case command of+                                DeRefVal _ -> DeRefValResult 0 ""+                                ValueToBool _ -> ValueToBoolResult False+                                ValueToNumber _ -> ValueToNumberResult 0+                                ValueToString _ -> ValueToStringResult (JSStringReceived "")+                                ValueToJSON _ -> ValueToJSONResult (JSStringReceived "null")+                                ValueToJSONValue _ -> ValueToJSONValueResult Null+                                IsNull _ -> IsNullResult True+                                IsUndefined _ -> IsUndefinedResult False+                                StrictEqual _ _ -> StrictEqualResult False+                                InstanceOf _ _ -> InstanceOfResult False+                                PropertyNames _ -> PropertyNamesResult []+                                Sync -> SyncResult) commands+    start

@@ -40,7 +40,7 @@        (waitForAnimationFrame) #else import Control.Exception (throwIO)-import Control.Monad (void, when, forever, zipWithM_)+import Control.Monad (void, when, zipWithM_) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Reader (ask, runReaderT) import Control.Monad.STM (atomically)@@ -58,6 +58,7 @@ import Data.Monoid ((<>)) import qualified Data.Text as T (unpack) import qualified Data.Map as M (lookup, delete, insert, empty, size)+import Data.UUID.V4 (nextRandom) import Data.Time.Clock (getCurrentTime,diffUTCTime) import Data.IORef (newIORef, atomicWriteIORef, readIORef) @@ -68,8 +69,6 @@ -- 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@@ -151,6 +150,7 @@  runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ()) runJavaScript sendBatch entryPoint = do+    contextId' <- nextRandom     startTime' <- getCurrentTime     recvMVar <- newEmptyMVar     lastAsyncBatch <- newEmptyMVar@@ -159,7 +159,8 @@     nextRef' <- newTVarIO 0     loggingEnabled <- newIORef False     let ctx = JSContextRef {-        startTime = startTime'+        contextId = contextId'+      , startTime = startTime'       , doSendCommand = \cmd -> cmd `deepseq` do             result <- newEmptyMVar             atomically $ writeTChan commandChan (Right (cmd, result))

@@ -107,6 +107,7 @@ import Control.Monad.Ref (MonadAtomicRef(..), MonadRef(..)) import Control.Concurrent.STM.TVar (TVar) import Data.Text (Text)+import Data.UUID (UUID) import Data.Time.Clock (UTCTime(..)) import Data.Typeable (Typeable) import Data.Coerce (coerce, Coercible)@@ -129,7 +130,8 @@ type JSContextRef = () #else data JSContextRef = JSContextRef {-    startTime          :: UTCTime+    contextId          :: UUID+  , startTime          :: UTCTime   , doSendCommand      :: Command -> IO Result   , doSendAsyncCommand :: AsyncCommand -> IO ()   , addCallback        :: Object -> JSCallAsFunction -> IO ()@@ -211,19 +213,57 @@     liftJSM' = id     {-# 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 (MonadJSM m) => MonadJSM (ContT r m) where+    liftJSM' = lift . liftJSM'+    {-# INLINE liftJSM' #-}++instance (Error e, MonadJSM m) => MonadJSM (ErrorT e m) where+    liftJSM' = lift . liftJSM'+    {-# INLINE liftJSM' #-}++instance (MonadJSM m) => MonadJSM (ExceptT e m) where+    liftJSM' = lift . liftJSM'+    {-# INLINE liftJSM' #-}++instance (MonadJSM m) => MonadJSM (IdentityT m) where+    liftJSM' = lift . liftJSM'+    {-# INLINE liftJSM' #-}++instance (MonadJSM m) => MonadJSM (ListT m) where+    liftJSM' = lift . liftJSM'+    {-# INLINE liftJSM' #-}++instance (MonadJSM m) => MonadJSM (MaybeT m) where+    liftJSM' = lift . liftJSM'+    {-# INLINE liftJSM' #-}++instance (MonadJSM m) => MonadJSM (ReaderT r m) where+    liftJSM' = lift . liftJSM'+    {-# INLINE liftJSM' #-}++instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.RWST r w s m) where+    liftJSM' = lift . liftJSM'+    {-# INLINE liftJSM' #-}++instance (Monoid w, MonadJSM m) => MonadJSM (Strict.RWST r w s m) where+    liftJSM' = lift . liftJSM'+    {-# INLINE liftJSM' #-}++instance (MonadJSM m) => MonadJSM (Lazy.StateT s m) where+    liftJSM' = lift . liftJSM'+    {-# INLINE liftJSM' #-}++instance (MonadJSM m) => MonadJSM (Strict.StateT s m) where+    liftJSM' = lift . liftJSM'+    {-# INLINE liftJSM' #-}++instance (Monoid w, MonadJSM m) => MonadJSM (Lazy.WriterT w m) where+    liftJSM' = lift . liftJSM'+    {-# INLINE liftJSM' #-}++instance (Monoid w, MonadJSM m) => MonadJSM (Strict.WriterT w m) where+    liftJSM' = lift . liftJSM'+    {-# INLINE liftJSM' #-}  instance MonadRef JSM where     type Ref JSM = Ref IO