bb2aeea · jsaddle · git.iko.soy

git.iko.soy/jsaddle

on master help sign in

Add functions for syncing lazy execution

bb2aeeaHamish Mackenzie10 years ago

src/Language/Javascript/JSaddle.hs−8

compare with master

unifiedsplit

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

51 -- * Modules

52 module JSaddle

53− , run

54) where

53) where

56import Language.Javascript.JSaddle.Types as JSaddle

55import Language.Javascript.JSaddle.Types as JSaddle

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

63import Language.Javascript.JSaddle.Object as JSaddle

62import Language.Javascript.JSaddle.Object as JSaddle

64import Language.Javascript.JSaddle.Evaluate as JSaddle

63import Language.Javascript.JSaddle.Evaluate as JSaddle

65import Language.Javascript.JSaddle.String as JSaddle

64import 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 #-}

1{-# LANGUAGE PatternSynonyms #-}

2{-# LANGUAGE PatternSynonyms #-}

2-----------------------------------------------------------------------------

3-----------------------------------------------------------------------------

3--

4--

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

19 -- * Running JSaddle given a JSContextRef

20 -- * Running JSaddle given a JSContextRef

20 , runJSaddle

21 , runJSaddle

22+ , run

22 -- * Exception Handling

24 -- * Exception Handling

25+ , syncPoint

26+ , syncAfter

23 , catch

27 , catch

24 , bracket

28 , bracket

25) where

29) where

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

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

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

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

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

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

34import 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

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

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

34-- a bit better with 'JSM'

52-- a bit better with 'JSM'

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

53+catch :: E.Exception e

36− => ReaderT r IO b

54+ => JSM b

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

55+ -> (e -> JSM b)

38− -> ReaderT r m b

56+ -> JSM b

39t `catch` c = do

57t `catch` c = do

40 r <- ask

58 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)

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

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

44-- a bit better with 'JSM'

62-- 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

46bracket aquire release f = do

64bracket aquire release f = do

47 r <- ask

65 r <- ask

48 liftIO $ E.bracket

66 liftIO $ E.bracket

49− (runReaderT aquire r)

67+ (runReaderT (syncAfter aquire) r)

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

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

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

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

53{-

71{-

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

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

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

74#endif

92#endif

75-}

93-}

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

78−runJSaddle context f = liftIO $ runReaderT f context

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

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

23 , Index

24 , Nullable(..)

25 , JSM

26+ , runJSaddle

26 , JSCallAsFunction

27 , JSCallAsFunction

27#ifndef ghcjs_HOST_OS

28#ifndef ghcjs_HOST_OS

28 , JSValueReceived(..)

29 , JSValueReceived(..)

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

38) where

39) where

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

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

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

41#ifdef ghcjs_HOST_OS

43#ifdef ghcjs_HOST_OS

42import GHCJS.Types

44import GHCJS.Types

43import JavaScript.Object.Internal (Object(..))

45import JavaScript.Object.Internal (Object(..))

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

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

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

168type JSM = ReaderT JSContextRef IO

170type JSM = ReaderT JSContextRef IO

169

171

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

173+runJSaddle context f = liftIO $ runReaderT f context

170

174

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

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

22 , sendCommand

23 , sendLazyCommand

24 , sendAsyncCommand

25+ , syncPoint

26+ , syncAfter

25) where

27) where

27import Control.Exception (throwIO)

29import Control.Exception (throwIO)

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

52import Language.Javascript.JSaddle.Types

54import Language.Javascript.JSaddle.Types

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

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

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

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

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

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

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

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

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

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

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

59import Network.Wai.Handler.Warp

60import Network.Wai.Handler.Warp

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

84 s <- asks doSendAsyncCommand

85 s <- asks doSendAsyncCommand

85 liftIO $ s cmd

86 liftIO $ s cmd

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+

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

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

88jsaddleOr opts entryPoint = websocketsOr opts wsApp

100jsaddleOr opts entryPoint = websocketsOr opts wsApp

89 where

101 where

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

127 atomically (readTChan recvChan) >>= putMVar resultMVar

139 atomically (readTChan recvChan) >>= putMVar resultMVar

128 (batch, Nothing) -> do

140 (batch, Nothing) -> do

129 sendTextData conn $ encode batch

141 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"

131 return ()

146 return ()

132−

133 runJSaddle ctx entryPoint

147 runJSaddle ctx entryPoint

134

148

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

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

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

144 tryReadTChan chan >>= \case

158 tryReadTChan chan >>= \case

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

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

146 Just cmd -> loop cmd asyncCmds

160 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

147

166

148jsaddleApp :: Application

167jsaddleApp :: Application

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

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

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

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

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

152run port f =

171run port f =

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

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

154− jsaddleOr defaultConnectionOptions f jsaddleApp

173+ jsaddleOr defaultConnectionOptions (f >> syncPoint) jsaddleApp