bb2aeea · jsaddle · git.iko.soy

git.iko.soy/jsaddle

Add functions for syncing lazy execution

commitbb2aeea5423c90d8cc6bd552affb27d6cbc77162 authorHamish Mackenzie <Hamish.K.Mackenzie@googlemail.com> dateSun 2 Oct 2016, 16:01 (10 years ago) parent48d858b

4 files changed+56−25

compare with master

unifiedsplit

src/Language/Javascript/JSaddle.hs−8 src/Language/Javascript/JSaddle/Monad.hs+28−12 src/Language/Javascript/JSaddle/Types.hs+4 src/Language/Javascript/JSaddle/WebSockets.hs+24−5

src/Language/Javascript/JSaddle.hs−8

@@ -50,7 +50,6 @@ module Language.Javascript.JSaddle (

5050

5151 -- * Modules

5252 module JSaddle

53− , run

5453) where

5554

5655import Language.Javascript.JSaddle.Types as JSaddle

@@ -63,10 +62,3 @@ import Language.Javascript.JSaddle.Properties as JSaddle

6362import Language.Javascript.JSaddle.Object as JSaddle

6463import Language.Javascript.JSaddle.Evaluate as JSaddle

6564import Language.Javascript.JSaddle.String as JSaddle

66−#ifdef ghcjs_HOST_OS

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

68−run :: Int -> JSM () -> IO ()

69−run _port = (`runReaderT` ())

70−#else

71−import Language.Javascript.JSaddle.WebSockets (run)

72−#endif

src/Language/Javascript/JSaddle/Monad.hs+28−12

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE PatternSynonyms #-}

23-----------------------------------------------------------------------------

34--

@@ -18,8 +19,11 @@ module Language.Javascript.JSaddle.Monad (

1819

1920 -- * Running JSaddle given a JSContextRef

2021 , runJSaddle

22+ , run

2123

2224 -- * Exception Handling

25+ , syncPoint

26+ , syncAfter

2327 , catch

2428 , bracket

2529) where

@@ -28,27 +32,41 @@ import Prelude hiding (catch, read)

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

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

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

31−import Language.Javascript.JSaddle.Types (JSM, JSContextRef(..))

35+import Language.Javascript.JSaddle.Types (JSM, runJSaddle, JSContextRef(..))

36+import Control.Monad.Trans.Reader (ReaderT(..))

37+#ifdef ghcjs_HOST_OS

38+import Control.Monad.Trans.Reader (ReaderT(..))

39+run :: Int -> JSM () -> IO ()

40+run _port = (`runReaderT` ())

41+

42+syncPoint :: JSM ()

43+syncPoint = return ()

44+

45+syncAfter :: JSM a -> JSM a

46+syncAfter = id

47+#else

48+import Language.Javascript.JSaddle.WebSockets (run, syncPoint, syncAfter)

49+#endif

3250

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

3452-- a bit better with 'JSM'

35−catch :: (MonadIO m, E.Exception e)

36− => ReaderT r IO b

37− -> (e -> ReaderT r IO b)

38− -> ReaderT r m b

53+catch :: E.Exception e

54+ => JSM b

55+ -> (e -> JSM b)

56+ -> JSM b

3957t `catch` c = do

4058 r <- ask

41− liftIO (runReaderT t r `E.catch` \e -> runReaderT (c e) r)

59+ liftIO (runReaderT (syncAfter t) r `E.catch` \e -> runReaderT (c e) r)

4260

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

4462-- a bit better with 'JSM'

45−bracket :: MonadIO m => ReaderT r IO a -> (a -> ReaderT r IO b) -> (a -> ReaderT r IO c) -> ReaderT r m c

63+bracket :: JSM a -> (a -> JSM b) -> (a -> JSM c) -> JSM c

4664bracket aquire release f = do

4765 r <- ask

4866 liftIO $ E.bracket

49− (runReaderT aquire r)

50− (\x -> runReaderT (release x) r)

51− (\x -> runReaderT (f x) r)

67+ (runReaderT (syncAfter aquire) r)

68+ (\x -> runReaderT (syncAfter $ release x) r)

69+ (\x -> runReaderT (syncAfter $ f x) r)

5270

5371{-

5472-- | Handle JavaScriptCore functions that take a MutableJSArray in order

@@ -74,6 +92,4 @@ catchval f catcher = do

7492#endif

7593-}

7694

77−runJSaddle :: MonadIO m => JSContextRef -> JSM a -> m a

78−runJSaddle context f = liftIO $ runReaderT f context

7995

src/Language/Javascript/JSaddle/Types.hs+4

@@ -23,6 +23,7 @@ module Language.Javascript.JSaddle.Types (

2323 , Index

2424 , Nullable(..)

2525 , JSM

26+ , runJSaddle

2627 , JSCallAsFunction

2728#ifndef ghcjs_HOST_OS

2829 , JSValueReceived(..)

@@ -38,6 +39,7 @@ module Language.Javascript.JSaddle.Types (

3839) where

3940

4041import Control.Monad.Trans.Reader (ReaderT(..))

42+import Control.Monad.IO.Class (MonadIO(..))

4143#ifdef ghcjs_HOST_OS

4244import GHCJS.Types

4345import JavaScript.Object.Internal (Object(..))

@@ -167,4 +169,6 @@ type JSCallAsFunction = JSVal -- ^ Function object

167169-- For an example of how to set up WebKitGTK+ see tests/TestJSaddle.hs

168170type JSM = ReaderT JSContextRef IO

169171

172+runJSaddle :: MonadIO m => JSContextRef -> JSM a -> m a

173+runJSaddle context f = liftIO $ runReaderT f context

170174

src/Language/Javascript/JSaddle/WebSockets.hs+24−5

@@ -22,6 +22,8 @@ module Language.Javascript.JSaddle.WebSockets (

2222 , sendCommand

2323 , sendLazyCommand

2424 , sendAsyncCommand

25+ , syncPoint

26+ , syncAfter

2527) where

2628

2729import Control.Exception (throwIO)

@@ -51,9 +53,8 @@ import Network.Wai.Handler.WebSockets (websocketsOr)

5153

5254import Language.Javascript.JSaddle.Types

5355 (Command(..), AsyncCommand(..), Result(..), JSContextRef(..), JSVal(..),

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

56+ Object(..), JSValueReceived(..), JSM, Batch(..), JSValueForSend(..), runJSaddle)

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

56−import Language.Javascript.JSaddle.Monad (runJSaddle)

5758import Language.Javascript.JSaddle.Native (wrapJSVal)

5859import Language.Javascript.JSaddle.WebSockets.Files (mkEmbedded)

5960import Network.Wai.Handler.Warp

@@ -84,6 +85,17 @@ sendAsyncCommand cmd = do

8485 s <- asks doSendAsyncCommand

8586 liftIO $ s cmd

8687

88+-- | Forces execution of pending asyncronous code

89+syncPoint :: JSM ()

90+syncPoint = void $ sendCommand Sync

91+

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

93+syncAfter :: JSM a -> JSM a

94+syncAfter f = do

95+ result <- f

96+ syncPoint

97+ return result

98+

8799jsaddleOr :: ConnectionOptions -> JSM () -> Application -> Application

88100jsaddleOr opts entryPoint = websocketsOr opts wsApp

89101 where

@@ -127,9 +139,11 @@ jsaddleOr opts entryPoint = websocketsOr opts wsApp

127139 atomically (readTChan recvChan) >>= putMVar resultMVar

128140 (batch, Nothing) -> do

129141 sendTextData conn $ encode batch

130− SyncResult <- atomically $ readTChan recvChan

142+ atomically (readTChan recvChan) >>= \case

143+ SyncResult -> return ()

144+ ThrowJSValue e -> atomically (discardToSyncPoint commandChan) >>= (`putMVar` ThrowJSValue e)

145+ _ -> error "Unexpected result processing batch"

131146 return ()

132−

133147 runJSaddle ctx entryPoint

134148

135149 readBatch :: TChan (Either AsyncCommand (Command, MVar Result)) -> STM (Batch, Maybe (MVar Result))

@@ -144,6 +158,11 @@ jsaddleOr opts entryPoint = websocketsOr opts wsApp

144158 tryReadTChan chan >>= \case

145159 Nothing -> return (Batch (reverse asyncCmds) Sync, Nothing)

146160 Just cmd -> loop cmd asyncCmds

161+ discardToSyncPoint :: TChan (Either AsyncCommand (Command, MVar Result)) -> STM (MVar Result)

162+ discardToSyncPoint chan =

163+ readTChan chan >>= \case

164+ Right (_, resultMVar) -> return resultMVar

165+ _ -> discardToSyncPoint chan

147166

148167jsaddleApp :: Application

149168jsaddleApp = staticApp ($(mkSettings mkEmbedded)) {ssIndices = [unsafeToPiece "index.html"]}

@@ -151,4 +170,4 @@ jsaddleApp = staticApp ($(mkSettings mkEmbedded)) {ssIndices = [unsafeToPiece "i

151170run :: Int -> JSM () -> IO ()

152171run port f =

153172 runSettings (setPort port (setTimeout 3600 defaultSettings)) $

154− jsaddleOr defaultConnectionOptions f jsaddleApp

173+ jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp