jsaddle 0.9.3.0 → 0.9.4.0

raw patch · 10 files changed

+118/−65 lines, 10 filesdep ~basedep ~processdep ~timePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base, process, time

API changes (from Hackage documentation)

Files

• jsaddle.cabal +3/−3
• src-ghc/GHCJS/Foreign/Internal.hs +12/−10
• src-ghc/GHCJS/Prim/Internal.hs +5/−3
• src-ghc/GHCJS/Types.hs +5/−3
• src/Language/Javascript/JSaddle/Native/Internal.hs +39/−24
• src/Language/Javascript/JSaddle/Object.hs +14/−4
• src/Language/Javascript/JSaddle/Run.hs +31/−12
• src/Language/Javascript/JSaddle/Run/Files.hs +1/−1
• src/Language/Javascript/JSaddle/Types.hs +3/−2
• src/Language/Javascript/JSaddle/Value.hs +5/−3

@@ -1,5 +1,5 @@ name: jsaddle-version: 0.9.3.0+version: 0.9.4.0 cabal-version: >=1.10 build-type: Simple license: MIT@@ -41,12 +41,12 @@             filepath >=1.4.0.0 && <1.5,             ghc-prim,             http-types >=0.8.6 && <0.10,-            process >=1.2.3.0 && <1.5,+            process >=1.2.3.0 && <1.7,             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,+            time >=1.5.0.1 && <1.9,             unordered-containers >=0.2 && <0.3,             vector >=0.10 && <0.13         exposed-modules:

@@ -27,26 +27,28 @@        (valueToBool) import Data.Typeable (Typeable) import GHCJS.Prim (isNull, isUndefined)+import System.IO.Unsafe (unsafePerformIO)+import Data.IORef (newIORef)  jsTrue :: JSVal-jsTrue = JSVal 3-{-# INLINE jsTrue #-}+jsTrue = JSVal . unsafePerformIO $ newIORef 3+{-# NOINLINE jsTrue #-}  jsFalse :: JSVal-jsFalse = JSVal 2-{-# INLINE jsFalse #-}+jsFalse = JSVal . unsafePerformIO $ newIORef 2+{-# NOINLINE jsFalse #-}  jsNull :: JSVal-jsNull = JSVal 0-{-# INLINE jsNull #-}+jsNull = JSVal . unsafePerformIO $ newIORef 0+{-# NOINLINE jsNull #-}  toJSBool :: Bool -> JSVal-toJSBool b = JSVal $ if b then 3 else 2-{-# INLINE toJSBool #-}+toJSBool b = JSVal . unsafePerformIO . newIORef $ if b then 3 else 2+{-# NOINLINE toJSBool #-}  jsUndefined :: JSVal-jsUndefined = JSVal 1-{-# INLINE jsUndefined #-}+jsUndefined = JSVal . unsafePerformIO $ newIORef 1+{-# NOINLINE jsUndefined #-}  isTruthy :: JSVal -> GHCJSPure Bool isTruthy = GHCJSPure . valueToBool

@@ -17,6 +17,8 @@ import           Data.Aeson (ToJSON(..), FromJSON(..))  import qualified GHC.Exception as Ex+import Data.IORef (newIORef, IORef)+import System.IO.Unsafe (unsafePerformIO)  -- A reference to a particular JavaScript value inside the JavaScript context type JSValueRef = Int64@@ -25,7 +27,7 @@   JSVal is a boxed type that can be used as FFI   argument or result. -}-newtype JSVal = JSVal JSValueRef deriving(Show, ToJSON, FromJSON)+newtype JSVal = JSVal (IORef JSValueRef)  instance NFData JSVal where   rnf x = x `seq` ()@@ -49,8 +51,8 @@   return (JSException (unsafeCoerce ref) "")  jsNull :: JSVal-jsNull = JSVal 0-{-# INLINE jsNull #-}+jsNull = JSVal . unsafePerformIO $ newIORef 0+{-# NOINLINE jsNull #-}  {- | If a synchronous thread tries to do something that can only      be done asynchronously, and the thread is set up to not

@@ -27,19 +27,21 @@ import GHC.Types import GHC.Prim import GHC.Ptr+import GHC.IORef+import GHC.IO.Unsafe (unsafePerformIO)  import Control.DeepSeq import Unsafe.Coerce -type Ref# = Int64+type Ref# = IORef Int64  mkRef :: Ref# -> JSVal mkRef = JSVal {-# INLINE mkRef #-}  nullRef :: JSVal-nullRef = JSVal 0-{-# INLINE nullRef #-}+nullRef = JSVal . unsafePerformIO $ newIORef 0+{-# NOINLINE nullRef #-}  --toPtr :: JSVal -> Ptr a --toPtr (JSVal x) = unsafeCoerce (Ptr' x 0#)

@@ -1,3 +1,6 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-} ----------------------------------------------------------------------------- -- -- Module      :  Language.Javascript.JSaddle.Native@@ -45,7 +48,6 @@ ) where  import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad.Primitive (touch)  import Data.Aeson (Value) @@ -57,30 +59,34 @@ import Language.Javascript.JSaddle.Run        (Command(..), Result(..), sendCommand,         sendAsyncCommand, sendLazyCommand, wrapJSVal)+import GHC.IORef (IORef(..), readIORef)+import GHC.STRef (STRef(..))+import GHC.IO (IO(..))+import GHC.Base (touch#)  wrapJSString :: MonadIO m => JSStringReceived -> m JSString wrapJSString (JSStringReceived ref) = return $ JSString ref +touchIORef :: IORef a -> IO ()+touchIORef (IORef (STRef r#)) = IO $ \s -> case touch# r# s of s' -> (# s', () #)+ withJSVal :: MonadIO m => JSVal -> (JSValueForSend -> m a) -> m a withJSVal (JSVal ref) f = do-    result <- f (JSValueForSend ref)-    liftIO $ touch ref+    result <- (f . JSValueForSend) =<< liftIO (readIORef ref)+    liftIO $ touchIORef ref     return result  withJSVals :: MonadIO m => [JSVal] -> ([JSValueForSend] -> m a) -> m a withJSVals v f =- do result <- f (map (\(JSVal ref) -> JSValueForSend ref) v)-    liftIO $ mapM_ touch v+ do result <- f =<< mapM (\(JSVal ref) -> liftIO $ JSValueForSend <$> readIORef ref) v+    liftIO $ mapM_ (\(JSVal ref) -> touchIORef ref) v     return result  withObject :: MonadIO m => Object -> (JSObjectForSend -> m a) -> m a withObject (Object o) f = withJSVal o (f . JSObjectForSend)  withJSString :: MonadIO m => JSString -> (JSStringForSend -> m a) -> m a-withJSString v@(JSString ref) f =- do result <- f (JSStringForSend ref)-    liftIO $ touch v-    return result+withJSString (JSString ref) f = f (JSStringForSend ref)  setPropertyByName :: JSString -> JSVal -> Object -> JSM () setPropertyByName name val this =@@ -166,13 +172,14 @@ {-# INLINE deRefVal #-}  valueToBool :: JSVal -> JSM Bool-valueToBool (JSVal 0) = return False -- null-valueToBool (JSVal 1) = return False -- undefined-valueToBool (JSVal 2) = return False -- false-valueToBool (JSVal 3) = return True  -- true-valueToBool v = withJSVal v $ \rval -> do-    ~(ValueToBoolResult result) <- sendCommand (ValueToBool rval)-    return result+valueToBool v@(JSVal ref) = liftIO (readIORef ref) >>= \case+    0 -> return False -- null+    1 -> return False -- undefined+    2 -> return False -- false+    3 -> return True  -- true+    _ -> withJSVal v $ \rval -> do+        ~(ValueToBoolResult result) <- sendCommand (ValueToBool rval)+        return result {-# INLINE valueToBool #-}  valueToNumber :: JSVal -> JSM Double@@ -201,17 +208,25 @@ {-# INLINE valueToJSONValue #-}  isNull :: JSVal -> JSM Bool-isNull (JSVal 0) = return True-isNull v = withJSVal v $ \rval -> do-    ~(IsNullResult result) <- sendCommand $ IsNull rval-    return result+isNull v@(JSVal ref) = liftIO (readIORef ref) >>= \case+    0 -> return True  -- null+    1 -> return False -- undefined+    2 -> return False -- false+    3 -> return False -- true+    _ -> withJSVal v $ \rval -> do+        ~(IsNullResult result) <- sendCommand $ IsNull rval+        return result {-# INLINE isNull #-}  isUndefined :: JSVal -> JSM Bool-isUndefined (JSVal 1) = return True-isUndefined v = withJSVal v $ \rval -> do-    ~(IsUndefinedResult result) <- sendCommand $ IsUndefined rval-    return result+isUndefined v@(JSVal ref) = liftIO (readIORef ref) >>= \case+    0 -> return False -- null+    1 -> return True  -- undefined+    2 -> return False -- false+    3 -> return False -- true+    _ -> withJSVal v $ \rval -> do+        ~(IsUndefinedResult result) <- sendCommand $ IsUndefined rval+        return result {-# INLINE isUndefined #-}  strictEqual :: JSVal -> JSVal -> JSM Bool

@@ -132,6 +132,8 @@ import Control.Monad.IO.Class (MonadIO(..)) import Language.Javascript.JSaddle.Properties import Control.Lens (IndexPreservingGetter, to)+import Data.IORef (newIORef, readIORef)+import System.IO.Unsafe (unsafePerformIO)  -- $setup -- >>> import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar)@@ -482,8 +484,16 @@ freeFunction (Function callback _) = liftIO $     releaseCallback callback #else-freeFunction (Function (Object (JSVal objectRef))) =-    sendAsyncCommand (FreeCallback (JSValueForSend objectRef))+freeFunction (Function (Object (JSVal objectRef))) = do+    -- By now the callback should ideally have been removed from whatever+    -- events it was added to.+    -- In case a call to the callback is still pending (perhaps just being sent+    -- on the JS side) we use FreeCallback to queue the callback to be freed when+    -- the next batch of results comes back fro JS.+    -- We are not using withJSVal to keep JS value "alive" because FreeCallback+    -- does not use the it.+    n <- liftIO $ readIORef objectRef+    sendAsyncCommand (FreeCallback (JSValueForSend n)) #endif  instance ToJSVal Function where@@ -522,7 +532,7 @@ foreign import javascript unsafe "$r = window"     js_window :: Object #else-global = Object (JSVal 4)+global = Object . JSVal . unsafePerformIO $ newIORef 4 #endif  -- | Get a list containing the property names present on a given object@@ -603,5 +613,5 @@ #ifdef ghcjs_HOST_OS nullObject = Object nullRef #else-nullObject = Object (JSVal 0)+nullObject = Object . JSVal . unsafePerformIO $ newIORef 0 #endif

@@ -65,13 +65,14 @@ 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 (newIORef, atomicWriteIORef, readIORef)+import Data.IORef+       (mkWeakIORef, newIORef, atomicWriteIORef, readIORef)  import Language.Javascript.JSaddle.Types        (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),         Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..)) import Language.Javascript.JSaddle.Exception (JSException(..))-import Control.DeepSeq (deepseq)+import Control.DeepSeq (force, deepseq) import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..)) import Data.Foldable (forM_) #endif@@ -165,6 +166,7 @@     finalizerThreads' <- newMVar S.empty     animationFrameHandlers' <- newMVar []     loggingEnabled <- newIORef False+    liveRefs' <- newMVar S.empty     let ctx = JSContextRef {             contextId = contextId'           , startTime = startTime'@@ -173,14 +175,19 @@                 atomically $ writeTChan commandChan (Right (cmd, result))                 unsafeInterleaveIO $                     takeMVar result >>= \case-                        (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)+                        (ThrowJSValue v) -> do+                            jsval <- wrapJSVal' ctx v+                            throwIO $ JSException jsval                         r -> return r           , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)-          , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb)+          , addCallback = \(Object (JSVal ioref)) cb -> do+                val <- readIORef ioref+                atomically $ modifyTVar' callbacks (M.insert val cb)           , nextRef = nextRef'           , doEnableLogging = atomicWriteIORef loggingEnabled           , finalizerThreads = finalizerThreads'           , animationFrameHandlers = animationFrameHandlers'+          , liveRefs = liveRefs'           }         processResults :: Bool -> Results -> IO ()         processResults syncCallbacks = \case@@ -282,17 +289,29 @@ addThreadFinalizer t@(ThreadId t#) (IO finalizer) =     IO $ \s -> case mkWeak# t# t finalizer s of { (# s1, _ #) -> (# s1, () #) } + wrapJSVal :: JSValueReceived -> JSM JSVal-wrapJSVal (JSValueReceived ref) = do-    -- TODO make sure this ref has not already been wrapped (perhaps only in debug version)-    let result = JSVal ref-    when (ref >= 5 || ref < 0) $ do-        ctx <- JSM ask-        liftIO . addFinalizer ref $ do+wrapJSVal v = do+    ctx <- JSM ask+    liftIO $ wrapJSVal' ctx v++wrapJSVal' :: JSContextRef -> JSValueReceived -> IO JSVal+wrapJSVal' ctx (JSValueReceived n) = do+    ref <- liftIO $ newIORef n+    when (n >= 5 || n < 0) $+#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+        void . mkWeakIORef ref $ do             ft <- takeMVar $ finalizerThreads ctx             t <- myThreadId             let tname = T.pack $ show t-            doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend ref+            doSendAsyncCommand ctx $ FreeRef tname $ JSValueForSend n             if tname `S.member` ft                 then putMVar (finalizerThreads ctx) ft                 else do@@ -300,5 +319,5 @@                         modifyMVar (finalizerThreads ctx) $ \s -> return (S.delete tname s, ())                         doSendAsyncCommand ctx $ FreeRefs tname                     putMVar (finalizerThreads ctx) =<< evaluate (S.insert tname ft)-    return result+    return (JSVal ref) #endif

@@ -244,7 +244,7 @@     \                                        (v === true           ) ? [3, \"\"] :\n\     \                                        (typeof v === \"number\") ? [-1, v.toString()] :\n\     \                                        (typeof v === \"string\") ? [-2, v]\n\-    \                                                                : [n, \"\"];\n\+    \                                                                : [-3, \"\"];\n\     \                                results.push({\"tag\": \"DeRefValResult\", \"contents\": c});\n\     \                                break;\n\     \                            case \"IsNull\":\n\

@@ -141,6 +141,7 @@   , doEnableLogging        :: Bool -> IO ()   , finalizerThreads       :: MVar (Set Text)   , animationFrameHandlers :: MVar [Double -> JSM ()]+  , liveRefs               :: MVar (Set Int64) } #endif @@ -208,7 +209,7 @@ class (Applicative m, MonadIO m) => MonadJSM m where     liftJSM' :: JSM a -> m a -    default liftJSM' :: (MonadJSM m', MonadTrans t) => JSM a' -> t m' a'+    default liftJSM' :: (MonadJSM m', MonadTrans t, m ~ t m') => JSM a -> m a     liftJSM' = lift . (liftJSM' :: MonadJSM m' => JSM a -> m' a)     {-# INLINE liftJSM' #-} @@ -339,7 +340,7 @@ type STJSArray s    = SomeJSArray (STMutable s)  -- | See 'JavaScript.Object.Internal.Object'-newtype Object = Object JSVal deriving(Show, ToJSON, FromJSON)+newtype Object = Object JSVal  -- | See 'GHCJS.Nullable.Nullable' newtype Nullable a = Nullable a

@@ -618,15 +618,17 @@                                        (typeof $1===\"string\")?4:\                                        (typeof $1===\"object\")?5:-1;" jsrefGetType :: JSVal -> Int #else-deRefVal value = toJSVal value >>= N.deRefVal >>= \result -> return $-    case result of+deRefVal value = do+    v <- toJSVal value+    result <- N.deRefVal v+    return $ case result of         DeRefValResult 0    _ -> ValNull         DeRefValResult 1    _ -> ValUndefined         DeRefValResult 2    _ -> ValBool False         DeRefValResult 3    _ -> ValBool True         DeRefValResult (-1) s -> ValNumber (read (T.unpack s))         DeRefValResult (-2) s -> ValString s-        DeRefValResult ref  _ -> ValObject (Object (JSVal ref))+        DeRefValResult (-3) _ -> ValObject (Object v)         _                     -> error "Unexpected result dereferencing JSaddle value" #endif