b2e9abb · jsaddle · git.iko.soy

git.iko.soy/jsaddle

on master help sign in

syncAfter in MonadCatch JSM and MonadMask JSM

b2e9abbHamish Mackenzie9 years ago

jsaddle/jsaddle.cabal+2−2

compare with master

unifiedsplit

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

48 stm >=2.4.4 && <2.5,

49 time >=1.5.0.1 && <1.9,

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

51− vector >=0.10 && <0.13,

51+ vector >=0.10 && <0.13

52− exceptions >=0.8 && <0.9

53 exposed-modules:

52 exposed-modules:

54 Data.JSString

53 Data.JSString

55 Data.JSString.Internal

54 Data.JSString.Internal

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

111 base <5,

110 base <5,

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

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

113 bytestring >=0.10.6.0 && <0.11,

112 bytestring >=0.10.6.0 && <0.11,

113+ exceptions >=0.8 && <0.9,

114 lens >=3.8.5 && <4.16,

115 primitive >=0.6.1.0 && <0.7,

116 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 (

38 , bracket

39) where

41−import Prelude hiding (read)

42#ifndef ghcjs_HOST_OS

41#ifndef ghcjs_HOST_OS

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

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

44#endif

43#endif

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

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

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

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

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

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

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

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

50-- | Gets the JavaScript context from the monad

49-- | Gets the JavaScript context from the monad

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

66-- | Alternative version of 'runJSM'

65-- | Alternative version of 'runJSM'

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

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

68runJSaddle = flip runJSM

67runJSaddle = 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

71import Language.Javascript.JSaddle.Types

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

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

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

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

75import Control.DeepSeq (force, deepseq)

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

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

87 liftIO $ f v

88#endif

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−

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

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

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

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

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

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

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

133 syncAfter (f t)

112 syncAfter (f t)

134

113

135#ifndef ghcjs_HOST_OS

114#ifndef ghcjs_HOST_OS

136−sendCommand :: Command -> JSM Result

137−sendCommand cmd = do

138− s <- doSendCommand <$> JSM ask

139− liftIO $ s cmd

140−

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

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

142sendLazyCommand cmd = do

116sendLazyCommand cmd = do

143 nextRefTVar <- nextRef <$> JSM ask

117 nextRefTVar <- nextRef <$> JSM ask

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

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

58 -- * Debugging

59 , JSadddleHasCallStack

61− -- * JavaScript Context Commands

61+ -- * Sync JSM

62+ , syncPoint

63+ , syncAfter

64+

62#ifndef ghcjs_HOST_OS

65#ifndef ghcjs_HOST_OS

66+ , sendCommand

67+

68+ -- * JavaScript Context Commands

63 , MutabilityType(..)

69 , MutabilityType(..)

64 , Mutable

70 , Mutable

65 , Immutable

71 , Immutable

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

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

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

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

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

91import Control.DeepSeq (NFData(..))

97import Control.DeepSeq (NFData(..))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

158type JSM = IO

164type JSM = IO

159#else

165#else

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

166newtype 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 ()

162#endif

190#endif

163

191

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

164

209

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

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

166-- live in JSM when using jsaddle.

211-- live in JSM when using jsaddle.