jsaddle 0.8.0.1 → 0.8.3.0

raw patch · 4 files changed

+92/−16 lines, 4 filesdep ~aesondep ~timePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: aeson, time

API changes (from Hackage documentation)

Files

• jsaddle.cabal +16/−3
• src-ghc/GHCJS/Marshal/Internal.hs +21/−2
• src/Language/Javascript/JSaddle/Run.hs +36/−9
• src/Language/Javascript/JSaddle/Types.hs +19/−2

@@ -1,5 +1,5 @@ name: jsaddle-version: 0.8.0.1+version: 0.8.3.0 cabal-version: >=1.10 build-type: Simple license: MIT@@ -17,7 +17,16 @@ source-repository head     type: git     location: https://github.com/ghcjs/jsaddle+    subdir: jsaddle +flag call-stacks+  description: Include HasCallStack constraint on calls unchecked calls+  default: False++flag check-unchecked+  description: Fail unchecked calls when they are called (rather than when the result is evaluated)+  default: False+ library      if impl(ghcjs -any)@@ -36,7 +45,7 @@             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.7,+            time >=1.5.0.1 && <1.8,             unordered-containers >=0.2 && <0.3,             vector >=0.10 && <0.12         exposed-modules:@@ -93,7 +102,7 @@         Language.Javascript.JSaddle.Value         Language.Javascript.JSaddle.Types     build-depends:-        aeson >=0.8.0.2 && <1.1,+        aeson >=0.8.0.2 && <1.2,         base <5,         base64-bytestring >=1.0.0.1 && <1.1,         bytestring >=0.10.6.0 && <0.11,@@ -104,5 +113,9 @@     default-language: Haskell2010     hs-source-dirs: src     ghc-options: -ferror-spans -Wall+    if flag(check-unchecked)+        cpp-options: -DCHECK_UNCHECKED+    if flag(call-stacks) || flag(check-unchecked)+        cpp-options: -DJSADDLE_HAS_CALL_STACK  

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, DefaultSignatures,+{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, DefaultSignatures,              TypeOperators, TupleSections, FlexibleContexts, FlexibleInstances,              LambdaCase   #-}@@ -34,7 +34,7 @@ import qualified JavaScript.Object.Internal as OI (Object(..), create, setProp, getProp) import qualified JavaScript.Array.Internal as AI (SomeJSArray(..), create, push, read, fromListIO, toListIO) -import           Language.Javascript.JSaddle.Types (JSM, MutableJSArray, GHCJSPure(..), ghcjsPure, ghcjsPureMap)+import           Language.Javascript.JSaddle.Types (JSM, MutableJSArray, GHCJSPure(..), ghcjsPure, ghcjsPureMap, JSadddleHasCallStack) import           Language.Javascript.JSaddle.String (textToStr)  data Purity = PureShared    -- ^ conversion is pure even if the original value is shared@@ -61,17 +61,36 @@   default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> JSM JSVal   toJSVal = toJSVal_generic id +fromJustWithStack :: JSadddleHasCallStack => Maybe a -> a+fromJustWithStack Nothing = error "fromJSValUnchecked: fromJSVal result was Nothing"+fromJustWithStack (Just x) = x+ class FromJSVal a where   fromJSVal :: JSVal -> JSM (Maybe a) +#if MIN_VERSION_base(4,9,0) && defined(JSADDLE_HAS_CALL_STACK)+  fromJSValUnchecked :: JSadddleHasCallStack => JSVal -> JSM a+#ifdef CHECK_UNCHECKED+  fromJSValUnchecked v = fromJSVal v >>= \case+                             Nothing -> error "fromJSValUnchecked: fromJSVal result was Nothing"+                             Just x  -> return x+#else+  fromJSValUnchecked = fmap fromJustWithStack . fromJSVal+#endif+#else   fromJSValUnchecked :: JSVal -> JSM a   fromJSValUnchecked = fmap fromJust . fromJSVal+#endif   {-# INLINE fromJSValUnchecked #-}    fromJSValListOf :: JSVal -> JSM (Maybe [a])   fromJSValListOf = fmap sequence . (mapM fromJSVal <=< AI.toListIO . coerce) -- fixme should check that it's an array +#if MIN_VERSION_base(4,9,0) && defined(JSADDLE_HAS_CALL_STACK)+  fromJSValUncheckedListOf :: JSadddleHasCallStack => JSVal -> JSM [a]+#else   fromJSValUncheckedListOf :: JSVal -> JSM [a]+#endif   fromJSValUncheckedListOf = mapM fromJSValUnchecked <=< AI.toListIO . coerce    -- default fromJSVal :: PFromJSVal a => JSVal a -> JSM (Maybe a)

@@ -19,6 +19,7 @@   , syncAfter   , waitForAnimationFrame   , nextAnimationFrame+  , enableLogging #ifndef ghcjs_HOST_OS   -- * Functions used to implement JSaddle using JSON messaging   , runJavaScript@@ -46,7 +47,7 @@ import Control.Concurrent.STM.TChan        (tryReadTChan, TChan, readTChan, writeTChan, newTChanIO) import Control.Concurrent.STM.TVar-       (writeTVar, readTVar, readTVarIO, modifyTVar, newTVarIO)+       (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO) import Control.Concurrent.MVar        (MVar, MVar, putMVar, takeMVar, newEmptyMVar) @@ -55,8 +56,9 @@  import Data.Monoid ((<>)) import qualified Data.Text as T (unpack)-import qualified Data.Map as M (lookup, delete, insert, empty)+import qualified Data.Map as M (lookup, delete, insert, empty, size) import Data.Time.Clock (getCurrentTime,diffUTCTime)+import Data.IORef (newIORef, atomicWriteIORef, readIORef)  import Language.Javascript.JSaddle.Types        (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),@@ -64,8 +66,19 @@ import Language.Javascript.JSaddle.Exception (JSException(..)) -- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal) import Control.DeepSeq (deepseq)+import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..)) #endif +-- | Enable (or disable) JSaddle logging+enableLogging :: Bool -> JSM ()+#ifdef ghcjs_HOST_OS+enableLogging _ = return ()+#else+enableLogging v = do+    f <- doEnableLogging <$> JSM ask+    liftIO $ f v+#endif+ -- | Forces execution of pending asyncronous code syncPoint :: JSM () #ifdef ghcjs_HOST_OS@@ -136,10 +149,11 @@ runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), IO ()) runJavaScript sendBatch entryPoint = do     startTime' <- getCurrentTime-    recvChan <- newTChanIO+    recvMVar <- newEmptyMVar     commandChan <- newTChanIO     callbacks <- newTVarIO M.empty     nextRef' <- newTVarIO 0+    loggingEnabled <- newIORef False     let ctx = JSContextRef {         startTime = startTime'       , doSendCommand = \cmd -> cmd `deepseq` do@@ -150,25 +164,38 @@                     (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)+      , 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       }     let processResults = \case             (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err             (Callback f this a) -> do+                logInfo ("Call " <>)                 f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx                 this' <- runReaderT  (unJSM $ wrapJSVal this) ctx                 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx                 (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                   -> atomically $ writeTChan recvChan m+            m                   -> putMVar recvMVar m+        logInfo s =+            readIORef loggingEnabled >>= \case+                True -> do+                    currentBytesUsedStr <- getGCStatsEnabled >>= \case+                        True  -> show . currentBytesUsed <$> getGCStats+                        False -> return "??"+                    cbCount <- M.size <$> readTVarIO callbacks+                    putStrLn . s $ "M " <> currentBytesUsedStr <> "CB " <> show cbCount+                False -> return ()     _ <- forkIO . forever $ readBatch commandChan >>= \case-            (batch, resultMVars) -> do+            (batch@(Batch cmds _), resultMVars) -> do+                logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))                 sendBatch batch-                atomically (readTChan recvChan) >>= \case-                    Success results -> zipWithM_ putMVar resultMVars results+                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.

@@ -1,6 +1,5 @@ {-# LANGUAGE CPP                        #-} #ifdef ghcjs_HOST_OS-{-# LANGUAGE ConstraintKinds            #-} {-# OPTIONS_GHC -Wno-dodgy-exports      #-} #else {-# LANGUAGE TypeFamilies               #-}@@ -8,11 +7,13 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE KindSignatures             #-} {-# LANGUAGE PolyKinds                  #-} {-# LANGUAGE FlexibleContexts           #-} {-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE ImplicitParams             #-} #endif+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE KindSignatures             #-} ----------------------------------------------------------------------------- -- -- Module      :  Language.Javascript.JSaddle.Types@@ -53,6 +54,9 @@   , Nullable(..)   , JSCallAsFunction +  -- * Debugging+  , JSadddleHasCallStack+   -- * JavaScript Context Commands #ifndef ghcjs_HOST_OS   , MutabilityType(..)@@ -100,6 +104,12 @@ import GHC.Generics (Generic) #endif +#if MIN_VERSION_base(4,9,0) && defined(CHECK_UNCHECKED)+import GHC.Stack (HasCallStack)+#else+import GHC.Exts (Constraint)+#endif+ -- | Identifies a JavaScript execution context. --   When using GHCJS this is just '()' since their is only one context. --   When using GHC it includes the functions JSaddle needs to communicate@@ -114,6 +124,7 @@   , addCallback        :: Object -> JSCallAsFunction -> IO ()   , freeCallback       :: Object -> IO ()   , nextRef            :: TVar JSValueRef+  , doEnableLogging    :: Bool -> IO () } #endif @@ -383,5 +394,11 @@ instance FromJSON Results #endif +-- | Like HasCallStack, but only when jsaddle cabal flag check-unchecked is set+#if MIN_VERSION_base(4,9,0) && defined(CHECK_UNCHECKED)+type JSadddleHasCallStack = HasCallStack+#else+type JSadddleHasCallStack = (() :: Constraint)+#endif