jsaddle 0.9.4.0 → 0.9.5.0
raw patch · 6 files changed
+85/−66 lines, 6 filesdep +exceptionsdep +unliftio-coredep ~http-typesdep ~lens
Dependencies added: exceptions, unliftio-core
Dependency ranges changed: http-types, lens
Files
- jsaddle.cabal +6/−4
- src-ghc/Data/JSString/Internal/Type.hs +2/−1
- src/Language/Javascript/JSaddle/Monad.hs +3/−26
- src/Language/Javascript/JSaddle/Run.hs +17/−30
- src/Language/Javascript/JSaddle/Run/Files.hs +6/−2
- src/Language/Javascript/JSaddle/Types.hs +51/−3
jsaddle.cabal view
@@ -1,5 +1,5 @@ name: jsaddle-version: 0.9.4.0+version: 0.9.5.0 cabal-version: >=1.10 build-type: Simple license: MIT@@ -40,7 +40,7 @@ deepseq >=1.3 && < 1.5, filepath >=1.4.0.0 && <1.5, ghc-prim,- http-types >=0.8.6 && <0.10,+ http-types >=0.8.6 && <0.13, process >=1.2.3.0 && <1.7, random >= 1.1 && < 1.2, ref-tf >=0.4.0.1 && <0.5,@@ -48,7 +48,8 @@ stm >=2.4.4 && <2.5, time >=1.5.0.1 && <1.9, unordered-containers >=0.2 && <0.3,- vector >=0.10 && <0.13+ vector >=0.10 && <0.13,+ unliftio-core >=0.1 && < 0.2 exposed-modules: Data.JSString Data.JSString.Internal@@ -110,7 +111,8 @@ base <5, base64-bytestring >=1.0.0.1 && <1.1, bytestring >=0.10.6.0 && <0.11,- lens >=3.8.5 && <4.16,+ exceptions >=0.8 && <0.9,+ lens >=3.8.5 && <4.17, primitive >=0.6.1.0 && <0.7, text >=1.2.1.3 && <1.3, transformers >=0.4.2.0 && <0.6
src-ghc/Data/JSString/Internal/Type.hs view
@@ -38,10 +38,11 @@ import Data.Data (Data) -- import Data.Text.Internal.Unsafe.Char (ord) import Data.Typeable (Typeable)+import Data.Semigroup (Semigroup) import GHC.Exts (Char(..), ord#, andI#, (/=#), isTrue#) -- | A wrapper around a JavaScript string-newtype JSString = JSString Text deriving(Show, Read, IsString, Monoid, Ord, Eq, Data, ToJSON, FromJSON, Typeable)+newtype JSString = JSString Text deriving(Show, Read, IsString, Semigroup, Monoid, Ord, Eq, Data, ToJSON, FromJSON, Typeable) instance NFData JSString where rnf !_ = ()
src/Language/Javascript/JSaddle/Monad.hs view
@@ -38,13 +38,12 @@ , bracket ) where -import Prelude hiding (read) #ifndef ghcjs_HOST_OS-import Control.Monad.Trans.Reader (runReaderT, ask, ReaderT(..))+import Control.Monad.Trans.Reader (runReaderT, ask) #endif import Control.Monad.IO.Class (MonadIO(..))-import qualified Control.Exception as E (Exception, catch, bracket)-import Language.Javascript.JSaddle.Types (JSM(..), MonadJSM, liftJSM, JSContextRef(..))+import Control.Monad.Catch (catch, bracket)+import Language.Javascript.JSaddle.Types (JSM(..), MonadJSM, liftJSM, JSContextRef) import Language.Javascript.JSaddle.Run (syncPoint, syncAfter, waitForAnimationFrame, nextAnimationFrame) -- | Gets the JavaScript context from the monad@@ -66,25 +65,3 @@ -- | Alternative version of 'runJSM' runJSaddle :: MonadIO m => JSContextRef -> JSM a -> m a runJSaddle = flip runJSM----- | Wrapped version of 'E.catch' that runs in a MonadIO that works--- a bit better with 'JSM'-catch :: E.Exception e- => JSM b- -> (e -> JSM b)- -> JSM b-t `catch` c = do- r <- askJSM- liftIO (runJSM (syncAfter t) r `E.catch` \e -> runJSM (c e) r)---- | Wrapped version of 'E.bracket' that runs in a MonadIO that works--- a bit better with 'JSM'-bracket :: JSM a -> (a -> JSM b) -> (a -> JSM c) -> JSM c-bracket aquire release f = do- r <- askJSM- liftIO $ E.bracket- (runJSM (syncAfter aquire) r)- (\x -> runJSM (syncAfter $ release x) r)- (\x -> runJSM (syncAfter $ f x) r)-
src/Language/Javascript/JSaddle/Run.hs view
@@ -37,7 +37,7 @@ ) where #ifdef ghcjs_HOST_OS-import Language.Javascript.JSaddle.Types (JSM)+import Language.Javascript.JSaddle.Types (JSM, syncPoint, syncAfter) import qualified JavaScript.Web.AnimationFrame as GHCJS (waitForAnimationFrame) #else@@ -70,13 +70,26 @@ import Language.Javascript.JSaddle.Types (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),- Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand) import Language.Javascript.JSaddle.Exception (JSException(..)) import Control.DeepSeq (force, deepseq)+#if MIN_VERSION_base(4,11,0)+import GHC.Stats (getRTSStatsEnabled, getRTSStats, RTSStats(..), gcdetails_live_bytes, gc)+#else import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))+#endif import Data.Foldable (forM_) #endif +#ifndef ghcjs_HOST_OS+#if MIN_VERSION_base(4,11,0)+currentBytesUsed = gcdetails_live_bytes . gc+#else+getRTSStatsEnabled = getGCStatsEnabled+getRTSStats = getGCStats+#endif+#endif+ -- | Enable (or disable) JSaddle logging enableLogging :: Bool -> JSM () #ifdef ghcjs_HOST_OS@@ -87,27 +100,6 @@ liftIO $ f v #endif --- | Forces execution of pending asyncronous code-syncPoint :: JSM ()-#ifdef ghcjs_HOST_OS-syncPoint = return ()-#else-syncPoint = do- SyncResult <- sendCommand Sync- return ()-#endif---- | Forces execution of pending asyncronous code after performing `f`-syncAfter :: JSM a -> JSM a-#ifdef ghcjs_HOST_OS-syncAfter = id-#else-syncAfter f = do- result <- f- syncPoint- return result-#endif- -- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'. -- On GHC it will delay the execution of the current batch of asynchronous -- command when they are sent to JavaScript. It will not delay the Haskell@@ -133,11 +125,6 @@ syncAfter (f t) #ifndef ghcjs_HOST_OS-sendCommand :: Command -> JSM Result-sendCommand cmd = do- s <- doSendCommand <$> JSM ask- liftIO $ s cmd- sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal sendLazyCommand cmd = do nextRefTVar <- nextRef <$> JSM ask@@ -219,8 +206,8 @@ logInfo s = readIORef loggingEnabled >>= \case True -> do- currentBytesUsedStr <- getGCStatsEnabled >>= \case- True -> show . currentBytesUsed <$> getGCStats+ currentBytesUsedStr <- getRTSStatsEnabled >>= \case+ True -> show . currentBytesUsed <$> getRTSStats False -> return "??" cbCount <- M.size <$> readTVarIO callbacks putStrLn . s $ "M " <> currentBytesUsedStr <> " CB " <> show cbCount <> " "
src/Language/Javascript/JSaddle/Run/Files.hs view
@@ -31,7 +31,7 @@ \</head>\n\ \<body>\n\ \</body>\n\- \<script src=\"jsaddle.js\"></script>\n\+ \<script src=\"/jsaddle.js\"></script>\n\ \</html>" initState :: ByteString@@ -45,7 +45,7 @@ \ jsaddle_values.set(4, window);\n\ \ var jsaddle_index = 100;\n\ \ var expectedBatch = 1;\n\- \ var lastResults = [0, {}];\n\+ \ var lastResults = [0, {\"tag\": \"Success\", \"contents\": [[], []]}];\n\ \ var inCallback = 0;\n\ \ var asyncBatch = null;\n\ \"@@ -91,6 +91,10 @@ \ jsaddle_values.set(n, eval(d.contents[0]));\n\ \ break;\n\ \ case \"StringToValue\":\n\+ \ var n = d.contents[1];\n\+ \ jsaddle_values.set(n, d.contents[0]);\n\+ \ break;\n\+ \ case \"JSONValueToValue\":\n\ \ var n = d.contents[1];\n\ \ jsaddle_values.set(n, d.contents[0]);\n\ \ break;\n\
src/Language/Javascript/JSaddle/Types.hs view
@@ -58,8 +58,14 @@ -- * Debugging , JSadddleHasCallStack - -- * JavaScript Context Commands+ -- * Sync JSM+ , syncPoint+ , syncAfter+ #ifndef ghcjs_HOST_OS+ , sendCommand++ -- * JavaScript Context Commands , MutabilityType(..) , Mutable , Immutable@@ -89,13 +95,14 @@ import GHCJS.Prim.Internal (JSVal(..), JSValueRef) import Data.JSString.Internal.Type (JSString(..)) import Control.DeepSeq (NFData(..))+import Control.Monad.Catch (MonadThrow, MonadCatch(..), MonadMask(..)) import Control.Monad.Trans.Cont (ContT(..)) import Control.Monad.Trans.Error (Error(..), ErrorT(..)) import Control.Monad.Trans.Except (ExceptT(..)) import Control.Monad.Trans.Identity (IdentityT(..)) import Control.Monad.Trans.List (ListT(..)) import Control.Monad.Trans.Maybe (MaybeT(..))-import Control.Monad.Trans.Reader (ReaderT(..))+import Control.Monad.Trans.Reader (ReaderT(..), ask) import Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..)) import Control.Monad.Trans.RWS.Strict as Strict (RWST(..)) import Control.Monad.Trans.State.Lazy as Lazy (StateT(..))@@ -116,6 +123,7 @@ import Data.Aeson (defaultOptions, genericToEncoding, ToJSON(..), FromJSON(..), Value) import GHC.Generics (Generic)+import Control.Monad.IO.Unlift (MonadUnliftIO) #endif #if MIN_VERSION_base(4,9,0) && defined(CHECK_UNCHECKED)@@ -157,9 +165,49 @@ type JSM = IO #else newtype JSM a = JSM { unJSM :: ReaderT JSContextRef IO a }- deriving (Functor, Applicative, Monad, MonadIO, MonadFix)+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadThrow, MonadUnliftIO)++instance MonadCatch JSM where+ t `catch` c = JSM (unJSM (syncAfter t) `catch` \e -> unJSM (c e))++instance MonadMask JSM where+ mask a = JSM $ mask $ \unmask -> unJSM (a $ q unmask)+ where q :: (ReaderT JSContextRef IO a -> ReaderT JSContextRef IO a) -> JSM a -> JSM a+ q unmask (JSM b) = syncAfter . JSM $ unmask b+ uninterruptibleMask a =+ JSM $ uninterruptibleMask $ \unmask -> unJSM (a $ q unmask)+ where q :: (ReaderT JSContextRef IO a -> ReaderT JSContextRef IO a) -> JSM a -> JSM a+ q unmask (JSM b) = syncAfter . JSM $ unmask b+ #endif +-- | Forces execution of pending asyncronous code+syncPoint :: JSM ()+#ifdef ghcjs_HOST_OS+syncPoint = return ()+#else+syncPoint = do+ SyncResult <- sendCommand Sync+ return ()+#endif++-- | Forces execution of pending asyncronous code after performing `f`+syncAfter :: JSM a -> JSM a+#ifdef ghcjs_HOST_OS+syncAfter = id+#else+syncAfter f = do+ result <- f+ syncPoint+ return result+#endif++#ifndef ghcjs_HOST_OS+sendCommand :: Command -> JSM Result+sendCommand cmd = do+ s <- doSendCommand <$> JSM ask+ liftIO $ s cmd+#endif -- | Type we can give to functions that are pure when using ghcjs, but -- live in JSM when using jsaddle.