jsaddle 0.9.9.4 → 0.9.10.0
raw patch · 7 files changed
+307/−16 lines, 7 filesdep ~aesondep ~ghcjs-base
Dependency ranges changed: aeson, ghcjs-base
Files
- ChangeLog.md +18/−0
- jsaddle.cabal +7/−4
- src-ghc/GHCJS/Int53.hs +168/−0
- src-ghc/GHCJS/Marshal/Internal.hs +53/−0
- src/Language/Javascript/JSaddle/Int53.hs +16/−0
- src/Language/Javascript/JSaddle/Run.hs +43/−10
- src/Language/Javascript/JSaddle/Value.hs +2/−2
+ ChangeLog.md view
@@ -0,0 +1,18 @@+# Revision history for jsaddle++## 0.9.10.0++* `Language.Javascript.JSaddle.Int53` (`GHCJS.Int53` on native GHC, from+ ghcjs-base on the JavaScript backend): `Int53` and `Word53`, integers a+ JavaScript Number holds exactly, used by jsaddle-dom 0.10 for Web IDL's+ `long long` / `unsigned long long`. No `Num` instance on purpose.+* `PToJSVal`, `PFromJSVal`, `ToJSVal` and `FromJSVal` instances for+ `Object` and `SomeJSArray` (`JSArray`, `MutableJSArray`), defined with+ the classes so they are not orphans; `fromJSVal` is `Nothing` for `null`+ and `undefined`. The orphan `ToJSVal Object` instance in+ `Language.Javascript.JSaddle.Value` is gone. Packages with their own+ orphan instances for these types need to drop them.+* Requires ghcjs-base >= 0.8.1 on the JavaScript backend.+* `runJavaScriptWithSerializer`: opt-in per-runner batch serialisation.+* Batch results are queued instead of passed through a one-slot `MVar`.+* aeson < 2.4.
jsaddle.cabal view
@@ -1,9 +1,10 @@ name: jsaddle-version: 0.9.9.4+version: 0.9.10.0 cabal-version: >=1.10 build-type: Simple license: MIT license-file: LICENSE+extra-source-files: ChangeLog.md maintainer: Hamish Mackenzie <Hamish.K.Mackenzie@googlemail.com> synopsis: Interface for JavaScript that works with GHCJS and GHC description:@@ -13,7 +14,7 @@ drive a small JavaScript helper. category: Web, Javascript author: Hamish Mackenzie-tested-with: GHC==9.12.2, GHC==9.10.1, GHC==9.8.4, GHC==9.6.7, GHC==9.4.8, GHC==9.2.8, GHC==9.0.2, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4+tested-with: GHC==9.14.1, GHC==9.12.4, GHC==9.10.3, GHC==9.8.4, GHC==9.6.7 source-repository head type: git@@ -32,7 +33,7 @@ if impl(ghcjs -any) || arch(javascript) build-depends:- ghcjs-base -any+ ghcjs-base >=0.8.1.0 -- GHC includes GHC.JS.Prim in base if impl(ghcjs -any) build-depends:@@ -70,6 +71,7 @@ GHCJS.Concurrent GHCJS.Foreign GHCJS.Foreign.Internal+ GHCJS.Int53 GHCJS.Internal.Types GHCJS.Marshal GHCJS.Marshal.Internal@@ -101,6 +103,7 @@ Language.Javascript.JSaddle.Evaluate Language.Javascript.JSaddle.Exception Language.Javascript.JSaddle.Helper+ Language.Javascript.JSaddle.Int53 Language.Javascript.JSaddle.Marshal.String Language.Javascript.JSaddle.Monad Language.Javascript.JSaddle.Object@@ -111,7 +114,7 @@ Language.Javascript.JSaddle.Value Language.Javascript.JSaddle.Types build-depends:- aeson >=0.11.3.0 && <2.3,+ aeson >=0.11.3.0 && <2.4, base >=4.9 && <5, base-compat >=0.9.0 && <0.16, base64-bytestring >=1.0.0.1 && <1.3,
+ src-ghc/GHCJS/Int53.hs view
@@ -0,0 +1,168 @@+-----------------------------------------------------------------------------+--+-- Module : GHCJS.Int53 (native GHC; ghcjs-base has the JavaScript backend version)+-- License : MIT+--+-- | Integers that a JavaScript Number holds exactly.+--+-- A JavaScript Number is a double, so it represents every integer of+-- magnitude up to @2^53 - 1@ (@Number.MAX_SAFE_INTEGER@) exactly and loses+-- precision beyond that. Web IDL's @long long@ and @unsigned long long@+-- are such Numbers (its editors have proposed renaming them @int53@ /+-- @uint53@, <https://github.com/whatwg/webidl/issues/33>), and without+-- @[EnforceRange]@ a browser silently reduces an out of range argument+-- modulo @2^64@.+--+-- 'Int53' and 'Word53' make that range part of the type. They have no+-- 'Num' instance on purpose: do arithmetic in 'Int64', 'Integer', 'Double'+-- or any other numeric type and convert back with a checked conversion,+-- so the place where a value could go out of range is explicit.+--+-- Using them with the DOM bindings (jsaddle-dom / ghcjs-dom 0.10, where+-- every @long long@ is an 'Int53' and every @unsigned long long@ a+-- 'Word53'):+--+-- > size <- Blob.getSize blob -- Word53+-- > let half = fromWord53 size `div` (2 :: Integer)+-- > -- (toInt53 gives Maybe Int53: Nothing when out of range)+-- > part <- Blob.slice blob (Just (int53 0)) (toInt53 half) (Nothing :: Maybe Text)+--+-- Small literals go through 'int53' / 'word53' (every 'Int32' / 'Word32'+-- fits); computed values through 'toInt53' / 'toWord53' (or 'clampInt53'+-- / 'clampWord53' to saturate instead).+--+-- Values read from JavaScript are always in range in practice (a Number+-- holding an integer is within the safe range or is not exactly an+-- integer to begin with).+--+-----------------------------------------------------------------------------+module GHCJS.Int53 (+ -- * Signed+ Int53+ , int53+ , toInt53+ , clampInt53+ , fromInt53+ , minInt53+ , maxInt53+ -- * Unsigned+ , Word53+ , word53+ , toWord53+ , clampWord53+ , fromWord53+ , maxWord53+) where++import Data.Int (Int32, Int64)+import Data.Word (Word32, Word64)++import Language.Javascript.JSaddle.Classes (ToJSVal(..), FromJSVal(..))+-- instances for Double+import GHCJS.Marshal ()+import Language.Javascript.JSaddle.Value ()++-- | An integer in the range @[-(2^53 - 1), 2^53 - 1]@.+newtype Int53 = Int53 Int64 deriving (Eq, Ord)++-- | An integer in the range @[0, 2^53 - 1]@.+newtype Word53 = Word53 Word64 deriving (Eq, Ord)++-- | @2^53 - 1@ (@Number.MAX_SAFE_INTEGER@)+safeMax :: Integer+safeMax = 2 ^ (53 :: Int) - 1++minInt53, maxInt53 :: Int53+minInt53 = Int53 (fromInteger (negate safeMax))+maxInt53 = Int53 (fromInteger safeMax)++maxWord53 :: Word53+maxWord53 = Word53 (fromInteger safeMax)++instance Bounded Int53 where+ minBound = minInt53+ maxBound = maxInt53++instance Bounded Word53 where+ minBound = Word53 0+ maxBound = maxWord53++-- | Shown (and read) as a plain number.+instance Show Int53 where+ showsPrec p (Int53 i) = showsPrec p i++instance Show Word53 where+ showsPrec p (Word53 w) = showsPrec p w++instance Read Int53 where+ readsPrec p s = [ (x, rest) | (i, rest) <- readsPrec p s, Just x <- [toInt53 (i :: Integer)] ]++instance Read Word53 where+ readsPrec p s = [ (x, rest) | (i, rest) <- readsPrec p s, Just x <- [toWord53 (i :: Integer)] ]++-- | Every 'Int32' fits (use it for literals: @int53 0@).+int53 :: Int32 -> Int53+int53 = Int53 . fromIntegral++-- | Every 'Word32' fits (use it for literals: @word53 0@).+word53 :: Word32 -> Word53+word53 = Word53 . fromIntegral++-- | 'Nothing' when out of range.+toInt53 :: Integral a => a -> Maybe Int53+toInt53 a+ | abs i <= safeMax = Just (Int53 (fromInteger i))+ | otherwise = Nothing+ where i = toInteger a++-- | 'Nothing' when out of range.+toWord53 :: Integral a => a -> Maybe Word53+toWord53 a+ | i >= 0 && i <= safeMax = Just (Word53 (fromInteger i))+ | otherwise = Nothing+ where i = toInteger a++-- | Saturating conversion (like Web IDL's @[Clamp]@, without rounding).+clampInt53 :: Integral a => a -> Int53+clampInt53 a = Int53 (fromInteger (max (negate safeMax) (min safeMax (toInteger a))))++-- | Saturating conversion (like Web IDL's @[Clamp]@, without rounding).+clampWord53 :: Integral a => a -> Word53+clampWord53 a = Word53 (fromInteger (max 0 (min safeMax (toInteger a))))++-- | Always exact for 'Int64', 'Integer' and 'Double' (and for any type+-- wide enough for the value).+fromInt53 :: Num b => Int53 -> b+fromInt53 (Int53 i) = fromIntegral i++-- | Always exact for 'Word64', 'Int64', 'Integer' and 'Double' (and for any+-- type wide enough for the value).+fromWord53 :: Num b => Word53 -> b+fromWord53 (Word53 w) = fromIntegral w++-- | A JavaScript Number (exact).+instance ToJSVal Int53 where+ toJSVal (Int53 i) = toJSVal (fromIntegral i :: Double)+ {-# INLINE toJSVal #-}++-- | A JavaScript Number (exact).+instance ToJSVal Word53 where+ toJSVal (Word53 w) = toJSVal (fromIntegral w :: Double)+ {-# INLINE toJSVal #-}++-- | 'Nothing' unless the value is a Number holding an integer in range.+instance FromJSVal Int53 where+ fromJSVal v = (>>= fromDouble toInt53) <$> fromJSVal v+ fromJSValUnchecked v = fromJSVal v >>= maybe (fail "fromJSValUnchecked: not an Int53") return++-- | 'Nothing' unless the value is a Number holding an integer in range.+instance FromJSVal Word53 where+ fromJSVal v = (>>= fromDouble toWord53) <$> fromJSVal v+ fromJSValUnchecked v = fromJSVal v >>= maybe (fail "fromJSValUnchecked: not a Word53") return++fromDouble :: (Integer -> Maybe a) -> Double -> Maybe a+fromDouble f d+ | isNaN d || isInfinite d = Nothing+ | fromInteger i == d = f i+ | otherwise = Nothing+ where i = truncate d
src-ghc/GHCJS/Marshal/Internal.hs view
@@ -280,3 +280,56 @@ packJSS :: String -> JSString packJSS = textToStr . T.pack++-- -----------------------------------------------------------------------------+-- Instances for the JSVal newtypes, matching the ones ghcjs-base (>= 0.8.1)+-- defines for the JavaScript backend.++instance PToJSVal OI.Object where+ pToJSVal (OI.Object v) = v+ {-# INLINE pToJSVal #-}++-- | Unchecked: wraps any value.+instance PFromJSVal OI.Object where+ pFromJSVal = OI.Object+ {-# INLINE pFromJSVal #-}++instance ToJSVal OI.Object where+ toJSVal (OI.Object v) = return v+ {-# INLINE toJSVal #-}++-- | 'Nothing' for @null@ and @undefined@ (as for the jsaddle-dom types);+-- 'fromJSValUnchecked' wraps any value.+instance FromJSVal OI.Object where+ fromJSVal v = nullOrUndefined v >>= \case+ True -> return Nothing+ False -> return (Just (OI.Object v))+ {-# INLINE fromJSVal #-}+ fromJSValUnchecked = return . OI.Object+ {-# INLINE fromJSValUnchecked #-}++instance PToJSVal (AI.SomeJSArray m) where+ pToJSVal (AI.SomeJSArray v) = v+ {-# INLINE pToJSVal #-}++-- | Unchecked: wraps any value.+instance PFromJSVal (AI.SomeJSArray m) where+ pFromJSVal = AI.SomeJSArray+ {-# INLINE pFromJSVal #-}++instance ToJSVal (AI.SomeJSArray m) where+ toJSVal (AI.SomeJSArray v) = return v+ {-# INLINE toJSVal #-}++-- | 'Nothing' for @null@ and @undefined@; 'fromJSValUnchecked' wraps any+-- value (no @Array.isArray@ check, like the other JSVal newtypes).+instance FromJSVal (AI.SomeJSArray m) where+ fromJSVal v = nullOrUndefined v >>= \case+ True -> return Nothing+ False -> return (Just (AI.SomeJSArray v))+ {-# INLINE fromJSVal #-}+ fromJSValUnchecked = return . AI.SomeJSArray+ {-# INLINE fromJSValUnchecked #-}++nullOrUndefined :: JSVal -> JSM Bool+nullOrUndefined v = (||) <$> ghcjsPure (F.isNull v) <*> ghcjsPure (F.isUndefined v)
+ src/Language/Javascript/JSaddle/Int53.hs view
@@ -0,0 +1,16 @@+-----------------------------------------------------------------------------+--+-- Module : Language.Javascript.JSaddle.Int53+-- License : MIT+--+-- | Integers that a JavaScript Number holds exactly ('Int53' and 'Word53',+-- with no 'Num' instance on purpose). See "GHCJS.Int53": ghcjs-base+-- defines it for the JavaScript backend and jsaddle for native GHC, so the+-- types are the same whichever backend is used.+--+-----------------------------------------------------------------------------+module Language.Javascript.JSaddle.Int53 (+ module GHCJS.Int53+) where++import GHCJS.Int53
src/Language/Javascript/JSaddle/Run.hs view
@@ -26,6 +26,7 @@ #ifndef ghcjs_HOST_OS -- * Functions used to implement JSaddle using JSON messaging , runJavaScript+ , runJavaScriptWithSerializer , AsyncCommand(..) , Command(..) , Result(..)@@ -55,7 +56,7 @@ import Control.Concurrent.STM.TVar (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO) import Control.Concurrent.MVar- (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar)+ (tryTakeMVar, MVar, putMVar, takeMVar, newMVar, newEmptyMVar, readMVar, modifyMVar, withMVar) import System.IO.Unsafe (unsafeInterleaveIO) import System.Random@@ -134,10 +135,41 @@ liftIO $ s cmd runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())-runJavaScript sendBatch entryPoint = do+runJavaScript = runJavaScriptWithSerializer Nothing++-- | Like 'runJavaScript', but with an optional serialiser that brackets each+-- batch round-trip (@sendBatch@..@takeResult@).+--+-- Pass @Nothing@ (as plain 'runJavaScript' does) for the default: contexts run+-- fully independently, which is what transports with per-context transports want+-- — e.g. jsaddle-warp, where each browser client is its own context on its own+-- WebSocket and serialising across them would let one slow client stall the+-- rest.+--+-- Pass @Just lock@ — one 'MVar' shared across all the contexts that share a+-- single transport thread — when concurrent contexts on that thread can wedge+-- each other. This is the case for the native GUI runners (several WKWebView /+-- WebKitGTK / WebView2 windows dispatching onto the one Cocoa\/GTK\/UI main+-- thread, where a synchronous @window.prompt@ round-trip blocks that thread):+-- holding the lock means at most one context occupies the transport at a time.+-- It is safe against jsaddle's sync-callback protocol — a prompt's handler+-- returns the pre-set 'lastAsyncBatch' without needing the batch thread, so+-- blocking the batch thread here never stalls an in-flight synchronous+-- round-trip.+runJavaScriptWithSerializer :: Maybe (MVar ()) -> (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results -> IO Batch, IO ())+runJavaScriptWithSerializer mSerializer sendBatch entryPoint = do contextId' <- randomIO startTime' <- getCurrentTime- recvMVar <- newEmptyMVar+ -- Results QUEUE, not a single-slot MVar. A delivery must never block: the+ -- transports fork a thread per incoming batch of results, so any delivery+ -- with no batch thread waiting for it (a context whose pump has gone, or+ -- more results than batches sent) left that thread blocked in 'putMVar'+ -- FOREVER. With a busy page that is a runaway: ~5000 blocked threads per+ -- second, half a million threads and 12GB of RSS in one measured session+ -- (72GB in a longer one). A TChan makes the deliverer's side non-blocking,+ -- so those threads finish and can be collected; 'takeResult' still skips+ -- results for earlier batches exactly as before.+ recvChan <- newTChanIO lastAsyncBatch <- newEmptyMVar commandChan <- newTChanIO callbacks <- newTVarIO M.empty@@ -146,6 +178,8 @@ animationFrameHandlers' <- newMVar [] loggingEnabled <- newIORef False liveRefs' <- newMVar S.empty+ let withSerializer :: IO a -> IO a+ withSerializer act = maybe act (\lock -> withMVar lock (const act)) mSerializer let ctx = JSContextRef { contextId = contextId' , startTime = startTime'@@ -172,7 +206,7 @@ processResults syncCallbacks = \case (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err (Callback n br (JSValueReceived fNumber) f this a) -> do- putMVar recvMVar (n, br)+ atomically $ writeTChan recvChan (n, br) f' <- runReaderT (unJSM $ wrapJSVal f) ctx this' <- runReaderT (unJSM $ wrapJSVal this) ctx args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx@@ -187,7 +221,7 @@ putStrLn $ "Error : Unexpected Duplicate. syncCallbacks=" <> show syncCallbacks <> " nBatch=" <> show nBatch <> " nExpected=" <> show nExpected void $ doSendCommand ctx Sync- BatchResults n br -> putMVar recvMVar (n, br)+ BatchResults n br -> atomically $ writeTChan recvChan (n, br) asyncResults :: Results -> IO () asyncResults results = void . forkIO $ processResults False results@@ -210,8 +244,7 @@ logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds)) _ <- tryTakeMVar lastAsyncBatch putMVar lastAsyncBatch batch- sendBatch batch- takeResult recvMVar nBatch >>= \case+ withSerializer (sendBatch batch >> takeResult recvChan nBatch) >>= \case (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"@@ -233,9 +266,9 @@ numberForeverFromM_ !n f = do _ <- f n numberForeverFromM_ (succ n) f- takeResult recvMVar nBatch =- takeMVar recvMVar >>= \case- (n, _) | n < nBatch -> takeResult recvMVar nBatch+ takeResult recvChan nBatch =+ atomically (readTChan recvChan) >>= \case+ (n, _) | n < nBatch -> takeResult recvChan nBatch r -> return r readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result]) readBatch nBatch chan = do
src/Language/Javascript/JSaddle/Value.hs view
@@ -315,8 +315,8 @@ instance MakeObject JSVal where makeObject = return . Object -instance ToJSVal Object where- toJSVal (Object r) = return r+-- ToJSVal / FromJSVal Object are defined with the classes: in GHCJS.Marshal.Internal+-- (jsaddle's src-ghc for native GHC, ghcjs-base >= 0.8.1 for the JS backend). -- | Convert to a JavaScript value (just an alias for 'toJSVal') val :: ToJSVal value