3f48016 · jsaddle · git.iko.soy

git.iko.soy/jsaddle

on master help sign in

Sync callbacks for jsaddle-wkwebview take 2

3f48016Hamish Mackenzie9 years ago

jsaddle-warp/src/Language/Javascript/JSaddle/WebSockets.hs+1−1

compare with master

unifiedsplit

@@ -53,7 +53,7 @@ jsaddleOr opts entryPoint = websocketsOr opts wsApp

53 receiveDataMessage conn >>= \case

54 (WS.Text t) ->

55 case decode t of

56− Nothing -> error $ "jsaddle WebSocket decode failed : " <> show t

56+ Nothing -> error $ "jsaddle Results decode failed : " <> show t

57 Just r -> processResult r

58 _ -> error "jsaddle WebSocket unexpected binary data"

59 start

jsaddle-wkwebview/src/Language/Javascript/JSaddle/WKWebView/Internal.hs+2−2

@@ -81,7 +81,7 @@ jsaddleResult ptrHandler s = do

81 processResult <- deRefStablePtr ptrHandler

82 result <- packCString s

83 case decode (fromStrict result) of

84− Nothing -> error $ "jsaddle WebSocket decode failed : " <> show result

84+ Nothing -> error $ "jsaddle Results decode failed : " <> show result

85 Just r -> processResult r

87jsaddleSyncResult :: StablePtr (Results -> IO Batch) -> JSaddleHandler -> CString -> IO ()

@@ -89,7 +89,7 @@ jsaddleSyncResult ptrHandler jsaddleHandler s = do

89 syncProcessResult <- deRefStablePtr ptrHandler

90 result <- packCString s

91 case decode (fromStrict result) of

92− Nothing -> error $ "jsaddle WebSocket decode failed : " <> show result

92+ Nothing -> error $ "jsaddle Results decode failed : " <> show result

93 Just r -> do -- void . forkIO $ do

94 batch <- syncProcessResult r

95 useAsCString (toStrict $ encode batch) $

jsaddle/src/Language/Javascript/JSaddle/Run.hs+26−33

@@ -49,7 +49,7 @@ import Control.Concurrent.STM.TChan

49import Control.Concurrent.STM.TVar

50 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)

51import Control.Concurrent.MVar

52− (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar)

52+ (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar, readMVar)

54import System.IO.Unsafe (unsafeInterleaveIO)

55import System.Mem.Weak (addFinalizer)

@@ -61,7 +61,7 @@ import Data.Time.Clock (getCurrentTime,diffUTCTime)

61import Data.IORef (newIORef, atomicWriteIORef, readIORef)

63import Language.Javascript.JSaddle.Types

64− (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),

64+ (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),

65 Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))

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

67-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)

@@ -152,7 +152,6 @@ runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results ->

152runJavaScript sendBatch entryPoint = do

153 startTime' <- getCurrentTime

154 recvMVar <- newEmptyMVar

155− syncSendBatch <- newEmptyMVar

156 lastAsyncBatch <- newEmptyMVar

155 lastAsyncBatch <- newEmptyMVar

157 commandChan <- newTChanIO

156 commandChan <- newTChanIO

158 callbacks <- newTVarIO M.empty

157 callbacks <- newTVarIO M.empty

@@ -176,7 +175,8 @@ runJavaScript sendBatch entryPoint = do

176 let processResults :: Bool -> Results -> IO ()

175 let processResults :: Bool -> Results -> IO ()

177 processResults syncCallbacks = \case

176 processResults syncCallbacks = \case

178 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

177 (ProtocolError err) -> error $ "Protocol error : " <> T.unpack err

179− (Callback f this a) -> do

178+ (Callback n br f this a) -> do

179+ putMVar recvMVar (n, br)

180 f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx

181 this' <- runReaderT (unJSM $ wrapJSVal this) ctx

182 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx

@@ -185,27 +185,20 @@ runJavaScript sendBatch entryPoint = do

185 Nothing -> liftIO $ putStrLn "Callback called after it was freed"

186 Just cb -> void . forkIO $ do

187 runReaderT (unJSM $ cb f' this' args) ctx

188− when syncCallbacks $ do

188+ when syncCallbacks $

189 doSendAsyncCommand ctx EndSyncBlock

190+ Duplicate nBatch nExpected -> do

191+ putStrLn $ "Error : Unexpected Duplicate. syncCallbacks=" <> show syncCallbacks <>

192+ " nBatch=" <> show nBatch <> " nExpected=" <> show nExpected

190− void $ doSendCommand ctx Sync

193+ void $ doSendCommand ctx Sync

191− Duplicate -> error "Error : Unexpected Duplicate"

192− m -> putMVar recvMVar m

194+ BatchResults n br -> putMVar recvMVar (n, br)

193 asyncResults :: Results -> IO ()

195 asyncResults :: Results -> IO ()

196+ asyncResults results =

194− asyncResults = processResults False

197+ void . forkIO $ processResults False results

195 syncResults :: Results -> IO Batch

198 syncResults :: Results -> IO Batch

196 syncResults results = do

199 syncResults results = do

197− existing <- tryTakeMVar syncSendBatch

200+ void . forkIO $ processResults True results

198− when (isJust existing) $ error "Error : Unexpected Sync Results"

199− tryTakeMVar lastAsyncBatch >>= \case

201+ readMVar lastAsyncBatch

200− Just lastAsync -> processResults True results >> return lastAsync

201− Nothing -> do

202− nextBatch <- newEmptyMVar

203− putMVar syncSendBatch (\batch -> do

204− existing <- tryTakeMVar nextBatch

205− when (isJust existing) $ error "Error : Unexpected Sync Results"

206− putMVar nextBatch batch)

207− processResults True results

208− takeMVar nextBatch

209 logInfo s =

202 logInfo s =

210 readIORef loggingEnabled >>= \case

203 readIORef loggingEnabled >>= \case

211 True -> do

204 True -> do

@@ -219,24 +212,24 @@ runJavaScript sendBatch entryPoint = do

219 readBatch nBatch commandChan >>= \case

212 readBatch nBatch commandChan >>= \case

220 (batch@(Batch cmds _ _), resultMVars) -> do

213 (batch@(Batch cmds _ _), resultMVars) -> do

221 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))

214 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))

222− tryTakeMVar syncSendBatch >>= \case

215+ _ <- tryTakeMVar lastAsyncBatch

223− Just send -> send batch

224− Nothing -> do

225− putMVar lastAsyncBatch batch

216+ putMVar lastAsyncBatch batch

226− sendBatch batch

217+ sendBatch batch

227− takeMVar recvMVar >>= \r -> do

218+ takeResult recvMVar nBatch >>= \case

228− _ <- tryTakeMVar lastAsyncBatch

219+ (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"

229− case r of

230− Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"

220+ (_, Success results) | length results /= length resultMVars -> error "Unexpected number of jsaddle results"

231− | otherwise -> zipWithM_ putMVar resultMVars results

221+ | otherwise -> zipWithM_ putMVar resultMVars results

232− Failure results exception -> do

222+ (_, Failure results exception) -> do

233 -- The exception will only be rethrown in Haskell if/when one of the

223 -- The exception will only be rethrown in Haskell if/when one of the

234 -- missing results (if any) is evaluated.

224 -- missing results (if any) is evaluated.

235 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"

225 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"

236 zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)

226 zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)

237− _ -> error "Unexpected jsaddle results"

238 return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)

227 return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)

239 where

228 where

229+ takeResult recvMVar nBatch =

230+ takeMVar recvMVar >>= \case

231+ (n, _) | n < nBatch -> takeResult recvMVar nBatch

232+ r -> return r

240 readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])

233 readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])

241 readBatch nBatch chan = do

234 readBatch nBatch chan = do

242 first <- atomically $ readTChan chan -- We want at least one command to send

235 first <- atomically $ readTChan chan -- We want at least one command to send

jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+25−11

@@ -44,6 +44,8 @@ initState = "\

44 \ jsaddle_values.set(4, window);\n\

45 \ var jsaddle_index = 100;\n\

46 \ var expectedBatch = 1;\n\

47+ \ var lastResults = [0, {}];\n\

48+ \ var inCallback = 0;\n\

47 \"

49 \"

49runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString

51runBatch :: (ByteString -> ByteString) -> Maybe (ByteString -> ByteString) -> ByteString

@@ -52,6 +54,7 @@ runBatch send sendSync = "\

52 \ var processBatch = function(timestamp) {\n\

54 \ var processBatch = function(timestamp) {\n\

53 \ var batch = firstBatch;\n\

55 \ var batch = firstBatch;\n\

54 \ var results = [];\n\

56 \ var results = [];\n\

57+ \ inCallback++;\n\

55 \ try {\n\

58 \ try {\n\

56 \ syncDepth = initialSyncDepth || 0;\n\

59 \ syncDepth = initialSyncDepth || 0;\n\

57 \ for(;;){\n\

60 \ for(;;){\n\

@@ -108,7 +111,7 @@ runBatch send sendSync = "\

108 \ jsaddle_values.set(nArg, arguments[i]);\n\

111 \ jsaddle_values.set(nArg, arguments[i]);\n\

109 \ args[i] = nArg;\n\

112 \ args[i] = nArg;\n\

110 \ }\n\

113 \ }\n\

111− \ " <> send "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> "\n\

114+ \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n\

112 \ })})();\n\

115 \ })})();\n\

113 \ break;\n\

116 \ break;\n\

114 \ case \"NewSyncCallback\":\n\

117 \ case \"NewSyncCallback\":\n\

@@ -125,9 +128,13 @@ runBatch send sendSync = "\

125 \ }\n" <> (

128 \ }\n" <> (

126 case sendSync of

129 case sendSync of

127 Just s ->

130 Just s ->

131+ " if(inCallback > 0) {\n\

132+ \ " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n\

133+ \ } else {\n\

128− " runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> ", 1);\n"

134+ \ runBatch(" <> s "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> ", 1);\n\

135+ \ }\n"

129 Nothing ->

136 Nothing ->

130− " " <> send "{\"tag\": \"Callback\", \"contents\": [nFunction, nThis, args]}" <> "\n"

137+ " " <> send "{\"tag\": \"Callback\", \"contents\": [lastResults[0], lastResults[1], nFunction, nThis, args]}" <> "\n"

131 ) <>

138 ) <>

132 " })})();\n\

139 " })})();\n\

133 \ break;\n\

140 \ break;\n\

@@ -243,29 +250,35 @@ runBatch send sendSync = "\

243 \ }\n\

250 \ }\n\

244 \ }\n\

251 \ }\n\

245 \ }\n\

252 \ }\n\

246− \ if(syncDepth === 0) {\n\

253+ \ if(syncDepth <= 0) {\n\

247− \ " <> send "{\"tag\": \"Success\", \"contents\": results}" <> "\n\

254+ \ lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\

255+ \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> "\n\

248 \ break;\n\

256 \ break;\n\

249 \ } else {\n" <> (

257 \ } else {\n" <> (

250 case sendSync of

258 case sendSync of

251 Just s ->

259 Just s ->

252− " batch = " <> s "{\"tag\": \"Success\", \"contents\": results}" <> "\n\

260+ " lastResults = [batch[2], {\"tag\": \"Success\", \"contents\": results}];\n\

261+ \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\

253 \ results = [];\n"

262 \ results = [];\n"

254 Nothing ->

263 Nothing ->

255− " " <> send "{\"tag\": \"Success\", \"contents\": results}" <> "\n\

264+ " " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Success\", \"contents\": results}]}" <> "\n\

256 \ break;\n"

265 \ break;\n"

257 ) <>

266 ) <>

258 " }\n\

267 " }\n\

259 \ } else {\n\

268 \ } else {\n\

260− \ if(syncDepth === 0) {\n\

269+ \ if(syncDepth <= 0) {\n\

261 \ break;\n\

270 \ break;\n\

262 \ } else {\n" <> (

271 \ } else {\n" <> (

263 case sendSync of

272 case sendSync of

264 Just s ->

273 Just s ->

274+ " if(batch[2] === expectedBatch - 1) {\n\

275+ \ batch = " <> s "{\"tag\": \"BatchResults\", \"contents\": [lastResults[0], lastResults[1]]}" <> ";\n\

276+ \ } else {\n\

265− " batch = " <> s "{\"tag\": \"Duplicate\"}" <> "\n\

277+ \ batch = " <> s "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> ";\n\

278+ \ }\n\

266 \ results = [];\n"

279 \ results = [];\n"

267 Nothing ->

280 Nothing ->

268− " " <> send "{\"tag\": \"Duplicate\"}" <> "\n\

281+ " " <> send "{\"tag\": \"Duplicate\", \"contents\": [batch[2], expectedBatch]}" <> "\n\

269 \ break;\n"

282 \ break;\n"

270 ) <>

283 ) <>

271 " }\n\

284 " }\n\

@@ -275,8 +288,9 @@ runBatch send sendSync = "\

275 \ catch (err) {\n\

288 \ catch (err) {\n\

276 \ var n = ++jsaddle_index;\n\

289 \ var n = ++jsaddle_index;\n\

277 \ jsaddle_values.set(n, err);\n\

290 \ jsaddle_values.set(n, err);\n\

278− \ " <> send "{\"tag\": \"Failure\", \"contents\": [results,n]}" <> "\n\

291+ \ " <> send "{\"tag\": \"BatchResults\", \"contents\": [batch[2], {\"tag\": \"Failure\", \"contents\": [results, n]}]}" <> "\n\

279 \ }\n\

292 \ }\n\

293+ \ inCallback--;\n\

280 \ };\n\

294 \ };\n\

281 \ if(batch[1] && (initialSyncDepth || 0) === 0) {\n\

295 \ if(batch[1] && (initialSyncDepth || 0) === 0) {\n\

282 \ window.requestAnimationFrame(processBatch);\n\

296 \ window.requestAnimationFrame(processBatch);\n\

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

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

73 , Command(..)

74 , Batch(..)

75 , Result(..)

76+ , BatchResults(..)

76 , Results(..)

77 , Results(..)

77#endif

78#endif

78) where

79) where

@@ -385,10 +386,18 @@ instance ToJSON Result where

385

386

386instance FromJSON Result

387instance FromJSON Result

387

388

388−data Results = Success [Result]

389+data BatchResults = Success [Result]

389− | Failure [Result] JSValueReceived

390+ | Failure [Result] JSValueReceived

391+ deriving (Show, Generic)

392+

393+instance ToJSON BatchResults where

394+ toEncoding = genericToEncoding defaultOptions

395+

396+instance FromJSON BatchResults

397+

398+data Results = BatchResults Int BatchResults

390− | Duplicate

399+ | Duplicate Int Int

391− | Callback JSValueReceived JSValueReceived [JSValueReceived]

400+ | Callback Int BatchResults JSValueReceived JSValueReceived [JSValueReceived]

392 | ProtocolError Text

401 | ProtocolError Text

393 deriving (Show, Generic)

402 deriving (Show, Generic)

394

403