diff --git a/jsaddle.cabal b/jsaddle.cabal --- a/jsaddle.cabal +++ b/jsaddle.cabal @@ -1,5 +1,5 @@ name: jsaddle -version: 0.9.9.3 +version: 0.9.9.4 cabal-version: >=1.10 build-type: Simple license: MIT @@ -50,7 +50,7 @@ ref-tf >=0.4.0.1 && <0.6, scientific >=0.3 && <0.4, stm >=2.4.4 && <2.6, - time >=1.5.0.1 && <1.15, + time >=1.5.0.1 && <1.16, unordered-containers >=0.2 && <0.3, vector >=0.10 && <0.14, unliftio-core >=0.1 && < 0.3 @@ -113,10 +113,11 @@ build-depends: aeson >=0.11.3.0 && <2.3, base >=4.9 && <5, - base-compat >=0.9.0 && <0.15, + base-compat >=0.9.0 && <0.16, base64-bytestring >=1.0.0.1 && <1.3, bytestring >=0.10.6.0 && <0.13, exceptions >=0.8 && <0.11, + kan-extensions >= 5 && < 6, lens >=3.8.5 && <5.4, primitive >=0.6.1.0 && <0.10, text >=1.2.1.3 && <1.3 || >= 2.0 && < 2.2, diff --git a/src-ghc/GHCJS/Marshal/Internal.hs b/src-ghc/GHCJS/Marshal/Internal.hs --- a/src-ghc/GHCJS/Marshal/Internal.hs +++ b/src-ghc/GHCJS/Marshal/Internal.hs @@ -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, JSadddleHasCallStack) +import Language.Javascript.JSaddle.Types (JSM, MutableJSArray, GHCJSPure(..), ghcjsPure, ghcjsPureMap, JSaddleHasCallStack) import Language.Javascript.JSaddle.String (textToStr) data Purity = PureShared -- ^ conversion is pure even if the original value is shared @@ -61,7 +61,7 @@ default toJSVal :: (Generic a, GToJSVal (Rep a ())) => a -> JSM JSVal toJSVal = toJSVal_generic id -fromJustWithStack :: JSadddleHasCallStack => Maybe a -> a +fromJustWithStack :: JSaddleHasCallStack => Maybe a -> a fromJustWithStack Nothing = error "fromJSValUnchecked: fromJSVal result was Nothing" fromJustWithStack (Just x) = x @@ -69,7 +69,7 @@ fromJSVal :: JSVal -> JSM (Maybe a) #if MIN_VERSION_base(4,9,0) && defined(JSADDLE_HAS_CALL_STACK) - fromJSValUnchecked :: JSadddleHasCallStack => JSVal -> JSM a + fromJSValUnchecked :: JSaddleHasCallStack => JSVal -> JSM a #ifdef CHECK_UNCHECKED fromJSValUnchecked v = fromJSVal v >>= \case Nothing -> error "fromJSValUnchecked: fromJSVal result was Nothing" @@ -87,7 +87,7 @@ 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] + fromJSValUncheckedListOf :: JSaddleHasCallStack => JSVal -> JSM [a] #else fromJSValUncheckedListOf :: JSVal -> JSM [a] #endif 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 @@ -600,14 +600,14 @@ #if __GLASGOW_HASKELL__ >= 900 "(($1,$2) => {\ switch($2.length) {\ - case 0 : $r = new $1(); break;\ - case 1 : $r = new $1($2[0]); break;\ - case 2 : $r = new $1($2[0],$2[1]); break;\ - case 3 : $r = new $1($2[0],$2[1],$2[2]); break;\ - case 4 : $r = new $1($2[0],$2[1],$2[2],$2[3]); break;\ - case 5 : $r = new $1($2[0],$2[1],$2[2],$2[3],$2[4]); break;\ - case 6 : $r = new $1($2[0],$2[1],$2[2],$2[3],$2[4],$2[5]); break;\ - case 7 : $r = new $1($2[0],$2[1],$2[2],$2[3],$2[4],$2[5],$2[6]); break;\ + case 0 : return new $1();\ + case 1 : return new $1($2[0]);\ + case 2 : return new $1($2[0],$2[1]);\ + case 3 : return new $1($2[0],$2[1],$2[2]);\ + case 4 : return new $1($2[0],$2[1],$2[2],$2[3]);\ + case 5 : return new $1($2[0],$2[1],$2[2],$2[3],$2[4]);\ + case 6 : return new $1($2[0],$2[1],$2[2],$2[3],$2[4],$2[5]);\ + case 7 : return new $1($2[0],$2[1],$2[2],$2[3],$2[4],$2[5],$2[6]);\ default:\ var temp = function() {\ ret = $1.apply(this, $2);\ @@ -615,13 +615,12 @@ temp.prototype = $1.prototype;\ var i = new temp();\ if(ret instanceof Object) {\ - $r = ret;\ + return ret;\ } else {\ i.constructor = $1;\ - $r = i;\ + return i;\ }\ }\ - return $r;\ })" #else "switch($2.length) {\ 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 @@ -53,7 +53,7 @@ runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString runBatch send sendSync = "\ - \ var runBatch = function(firstBatch, initialSyncDepth) {\n\ + \ var runBatch = function(firstBatch) {\n\ \ var processBatch = function(timestamp) {\n\ \ var batch = firstBatch;\n\ \ var callbacksToFree = [];\n\ @@ -153,7 +153,8 @@ " if(inCallback > 0) {\n\ \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n\ \ } else {\n\ - \ runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> ", 1);\n\ + \ initialSyncDepth = 1;\n\ + \ runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> ");\n\ \ }\n" Nothing -> " " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nFunctionInFunc, nThis, args]}" <> "\n" @@ -336,6 +337,7 @@ \ processBatch(globalThis.performance ? globalThis.performance.now() : null);\n\ \ }\n\ \ };\n\ + \ initialSyncDepth = 0;\n\ \ runBatch(batch);\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 @@ -57,7 +57,7 @@ , JSCallAsFunction -- * Debugging - , JSadddleHasCallStack + , JSaddleHasCallStack -- * Sync JSM , syncPoint @@ -97,6 +97,7 @@ import Data.JSString.Internal.Type (JSString(..)) import Control.DeepSeq (NFData(..)) import Control.Monad.Catch (MonadThrow, MonadCatch(..), MonadMask(..)) +import Control.Monad.Codensity (Codensity(..)) import Control.Monad.Trans.Cont (ContT(..)) import Control.Monad.Trans.Except (ExceptT(..)) import Control.Monad.Trans.Identity (IdentityT(..)) @@ -117,10 +118,12 @@ import Data.Set (Set) import Data.Text (Text) import Data.Time.Clock (UTCTime(..)) +import Data.Type.Equality (type (~~)) import Data.Typeable (Typeable) import Data.Coerce (coerce, Coercible) import Data.Aeson (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value) +import GHC.Exts (TYPE) import GHC.Generics (Generic) import Control.Monad.IO.Unlift (MonadUnliftIO) import qualified Control.Monad.Fail as Fail @@ -316,6 +319,9 @@ liftJSM' = lift . liftJSM' {-# INLINE liftJSM' #-} +instance (m ~~ m', MonadJSM m') => MonadJSM (Codensity (m :: k -> TYPE rep)) where + liftJSM' = lift . liftJSM' + instance MonadRef JSM where type Ref JSM = Ref IO newRef = liftIO . newRef @@ -517,9 +523,9 @@ -- | 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 +type JSaddleHasCallStack = HasCallStack #else -type JSadddleHasCallStack = (() :: Constraint) +type JSaddleHasCallStack = (() :: Constraint) #endif