b2e9abb · jsaddle · git.iko.soy

git.iko.soy/jsaddle

syncAfter in MonadCatch JSM and MonadMask JSM

commitb2e9abb79336eb387fbfa5874b302b7a33cd43d0 authorHamish Mackenzie <Hamish.K.Mackenzie@googlemail.com> dateSun 8 Oct 2017, 20:50 (9 years ago) parent3b95a17

4 files changed+55−59

compare with master

unifiedsplit

jsaddle/jsaddle.cabal+2−2 jsaddle/src/Language/Javascript/JSaddle/Monad.hs+3−26 jsaddle/src/Language/Javascript/JSaddle/Run.hs+1−27 jsaddle/src/Language/Javascript/JSaddle/Types.hs+49−4

jsaddle/jsaddle.cabal+2−2

@@ -48,8 +48,7 @@ library

4848 stm >=2.4.4 && <2.5,

4949 time >=1.5.0.1 && <1.9,

5050 unordered-containers >=0.2 && <0.3,

51− vector >=0.10 && <0.13,

52− exceptions >=0.8 && <0.9

51+ vector >=0.10 && <0.13

5352 exposed-modules:

5453 Data.JSString

5554 Data.JSString.Internal

@@ -111,6 +110,7 @@ library

111110 base <5,

112111 base64-bytestring >=1.0.0.1 && <1.1,

113112 bytestring >=0.10.6.0 && <0.11,

113+ exceptions >=0.8 && <0.9,

114114 lens >=3.8.5 && <4.16,

115115 primitive >=0.6.1.0 && <0.7,

116116 text >=1.2.1.3 && <1.3,

jsaddle/src/Language/Javascript/JSaddle/Monad.hs+3−26

@@ -38,13 +38,12 @@ module Language.Javascript.JSaddle.Monad (

3838 , bracket

3939) where

4040

41−import Prelude hiding (read)

4241#ifndef ghcjs_HOST_OS

43−import Control.Monad.Trans.Reader (runReaderT, ask, ReaderT(..))

42+import Control.Monad.Trans.Reader (runReaderT, ask)

4443#endif

4544import Control.Monad.IO.Class (MonadIO(..))

46−import qualified Control.Exception as E (Exception, catch, bracket)

47−import Language.Javascript.JSaddle.Types (JSM(..), MonadJSM, liftJSM, JSContextRef(..))

45+import Control.Monad.Catch (catch, bracket)

46+import Language.Javascript.JSaddle.Types (JSM(..), MonadJSM, liftJSM, JSContextRef)

4847import Language.Javascript.JSaddle.Run (syncPoint, syncAfter, waitForAnimationFrame, nextAnimationFrame)

4948

5049-- | Gets the JavaScript context from the monad

@@ -66,25 +65,3 @@ runJSM f = liftIO . runReaderT (unJSM f)

6665-- | Alternative version of 'runJSM'

6766runJSaddle :: MonadIO m => JSContextRef -> JSM a -> m a

6867runJSaddle = flip runJSM

69−

70−

71−-- | Wrapped version of 'E.catch' that runs in a MonadIO that works

72−-- a bit better with 'JSM'

73−catch :: E.Exception e

74− => JSM b

75− -> (e -> JSM b)

76− -> JSM b

77−t `catch` c = do

78− r <- askJSM

79− liftIO (runJSM (syncAfter t) r `E.catch` \e -> runJSM (c e) r)

80−

81−-- | Wrapped version of 'E.bracket' that runs in a MonadIO that works

82−-- a bit better with 'JSM'

83−bracket :: JSM a -> (a -> JSM b) -> (a -> JSM c) -> JSM c

84−bracket aquire release f = do

85− r <- askJSM

86− liftIO $ E.bracket

87− (runJSM (syncAfter aquire) r)

88− (\x -> runJSM (syncAfter $ release x) r)

89− (\x -> runJSM (syncAfter $ f x) r)

90−

jsaddle/src/Language/Javascript/JSaddle/Run.hs+1−27

@@ -70,7 +70,7 @@ import Data.IORef

7070

7171import Language.Javascript.JSaddle.Types

7272 (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),

73− Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))

73+ Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..), syncPoint, syncAfter, sendCommand)

7474import Language.Javascript.JSaddle.Exception (JSException(..))

7575import Control.DeepSeq (force, deepseq)

7676import GHC.Stats (getGCStatsEnabled, getGCStats, GCStats(..))

@@ -87,27 +87,6 @@ enableLogging v = do

8787 liftIO $ f v

8888#endif

8989

90−-- | Forces execution of pending asyncronous code

91−syncPoint :: JSM ()

92−#ifdef ghcjs_HOST_OS

93−syncPoint = return ()

94−#else

95−syncPoint = do

96− SyncResult <- sendCommand Sync

97− return ()

98−#endif

99−

100−-- | Forces execution of pending asyncronous code after performing `f`

101−syncAfter :: JSM a -> JSM a

102−#ifdef ghcjs_HOST_OS

103−syncAfter = id

104−#else

105−syncAfter f = do

106− result <- f

107− syncPoint

108− return result

109−#endif

110−

11190-- | On GHCJS this is 'JavaScript.Web.AnimationFrame.waitForAnimationFrame'.

11291-- On GHC it will delay the execution of the current batch of asynchronous

11392-- command when they are sent to JavaScript. It will not delay the Haskell

@@ -133,11 +112,6 @@ nextAnimationFrame f = do

133112 syncAfter (f t)

134113

135114#ifndef ghcjs_HOST_OS

136−sendCommand :: Command -> JSM Result

137−sendCommand cmd = do

138− s <- doSendCommand <$> JSM ask

139− liftIO $ s cmd

140−

141115sendLazyCommand :: (JSValueForSend -> AsyncCommand) -> JSM JSVal

142116sendLazyCommand cmd = do

143117 nextRefTVar <- nextRef <$> JSM ask

jsaddle/src/Language/Javascript/JSaddle/Types.hs+49−4

@@ -58,8 +58,14 @@ module Language.Javascript.JSaddle.Types (

5858 -- * Debugging

5959 , JSadddleHasCallStack

6060

61− -- * JavaScript Context Commands

61+ -- * Sync JSM

62+ , syncPoint

63+ , syncAfter

64+

6265#ifndef ghcjs_HOST_OS

66+ , sendCommand

67+

68+ -- * JavaScript Context Commands

6369 , MutabilityType(..)

6470 , Mutable

6571 , Immutable

@@ -89,14 +95,14 @@ import GHCJS.Nullable (Nullable(..))

8995import GHCJS.Prim.Internal (JSVal(..), JSValueRef)

9096import Data.JSString.Internal.Type (JSString(..))

9197import Control.DeepSeq (NFData(..))

92−import Control.Monad.Catch (MonadThrow, MonadCatch, MonadMask)

98+import Control.Monad.Catch (MonadThrow, MonadCatch(..), MonadMask(..))

9399import Control.Monad.Trans.Cont (ContT(..))

94100import Control.Monad.Trans.Error (Error(..), ErrorT(..))

95101import Control.Monad.Trans.Except (ExceptT(..))

96102import Control.Monad.Trans.Identity (IdentityT(..))

97103import Control.Monad.Trans.List (ListT(..))

98104import Control.Monad.Trans.Maybe (MaybeT(..))

99−import Control.Monad.Trans.Reader (ReaderT(..))

105+import Control.Monad.Trans.Reader (ReaderT(..), ask)

100106import Control.Monad.Trans.RWS.Lazy as Lazy (RWST(..))

101107import Control.Monad.Trans.RWS.Strict as Strict (RWST(..))

102108import Control.Monad.Trans.State.Lazy as Lazy (StateT(..))

@@ -158,9 +164,48 @@ data JSContextRef = JSContextRef {

158164type JSM = IO

159165#else

160166newtype JSM a = JSM { unJSM :: ReaderT JSContextRef IO a }

161− deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadCatch, MonadThrow, MonadMask)

167+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadThrow)

168+

169+instance MonadCatch JSM where

170+ t `catch` c = JSM (unJSM (syncAfter t) `catch` \e -> unJSM (c e))

171+

172+instance MonadMask JSM where

173+ mask a = JSM $ mask $ \unmask -> unJSM (a $ q unmask)

174+ where q :: (ReaderT JSContextRef IO a -> ReaderT JSContextRef IO a) -> JSM a -> JSM a

175+ q unmask (JSM b) = syncAfter . JSM $ unmask b

176+ uninterruptibleMask a =

177+ JSM $ uninterruptibleMask $ \unmask -> unJSM (a $ q unmask)

178+ where q :: (ReaderT JSContextRef IO a -> ReaderT JSContextRef IO a) -> JSM a -> JSM a

179+ q unmask (JSM b) = syncAfter . JSM $ unmask b

180+#endif

181+

182+-- | Forces execution of pending asyncronous code

183+syncPoint :: JSM ()

184+#ifdef ghcjs_HOST_OS

185+syncPoint = return ()

186+#else

187+syncPoint = do

188+ SyncResult <- sendCommand Sync

189+ return ()

162190#endif

163191

192+-- | Forces execution of pending asyncronous code after performing `f`

193+syncAfter :: JSM a -> JSM a

194+#ifdef ghcjs_HOST_OS

195+syncAfter = id

196+#else

197+syncAfter f = do

198+ result <- f

199+ syncPoint

200+ return result

201+#endif

202+

203+#ifndef ghcjs_HOST_OS

204+sendCommand :: Command -> JSM Result

205+sendCommand cmd = do

206+ s <- doSendCommand <$> JSM ask

207+ liftIO $ s cmd

208+#endif

164209

165210-- | Type we can give to functions that are pure when using ghcjs, but

166211-- live in JSM when using jsaddle.