68651f4 · jsaddle · git.iko.soy

git.iko.soy/jsaddle

on master help sign in

Fix #35 and add animationFrameHandlers.

68651f4Hamish Mackenzie9 years ago

jsaddle/jsaddle.cabal+1

compare with master

unifiedsplit

@@ -63,6 +63,7 @@ library

63 GHCJS.Prim

64 GHCJS.Prim.Internal

65 GHCJS.Types

66+ GHCJS.Concurrent

66 GHCJS.Foreign

67 GHCJS.Foreign

67 GHCJS.Foreign.Internal

68 GHCJS.Foreign.Internal

68 GHCJS.Internal.Types

69 GHCJS.Internal.Types

jsaddle/src/Language/Javascript/JSaddle/Null.hs+1−1

@@ -37,7 +37,7 @@ run f = do

37 _ <- forkIO $ forever $

38 readChan batches >>= \case

39 Batch commands _ batchNumber ->

40− processResult $ BatchResults batchNumber . Success $ mapMaybe (\case

40+ processResult $ BatchResults batchNumber . Success [] $ mapMaybe (\case

41 Left _ -> Nothing

42 Right command -> Just $

43 case command of

jsaddle/src/Language/Javascript/JSaddle/Object.hs+5−5

@@ -119,9 +119,10 @@ import Language.Javascript.JSaddle.Native

119 (newAsyncCallback, newSyncCallback, callAsFunction, callAsConstructor)

120import Language.Javascript.JSaddle.Monad (askJSM, JSM)

121import Language.Javascript.JSaddle.Types

122− (JSString, Object(..), SomeJSArray(..),

122+ (JSValueForSend(..), AsyncCommand(..), JSString, Object(..),

123− JSVal(..), JSCallAsFunction, JSContextRef(..))

123+ SomeJSArray(..), JSVal(..), JSCallAsFunction, JSContextRef(..))

124import JavaScript.Object.Internal (create, listProps)

125+import Language.Javascript.JSaddle.Run (sendAsyncCommand)

125#endif

126#endif

126import JavaScript.Array.Internal (fromListIO)

127import JavaScript.Array.Internal (fromListIO)

127import Language.Javascript.JSaddle.Value (valToObject)

128import Language.Javascript.JSaddle.Value (valToObject)

@@ -481,9 +482,8 @@ freeFunction :: Function -> JSM ()

481freeFunction (Function callback _) = liftIO $

482freeFunction (Function callback _) = liftIO $

482 releaseCallback callback

483 releaseCallback callback

483#else

484#else

484−freeFunction (Function object) = do

485+freeFunction (Function (Object (JSVal objectRef))) =

485− free <- freeCallback <$> askJSM

486+ sendAsyncCommand (FreeCallback (JSValueForSend objectRef))

486− liftIO $ free object

487#endif

488

489instance ToJSVal Function where

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

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

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

74import Control.DeepSeq (deepseq)

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

76+import Data.Foldable (forM_)

76#endif

77#endif

78-- | Enable (or disable) JSaddle logging

79-- | Enable (or disable) JSaddle logging

@@ -162,25 +163,26 @@ runJavaScript sendBatch entryPoint = do

162 callbacks <- newTVarIO M.empty

163 callbacks <- newTVarIO M.empty

163 nextRef' <- newTVarIO 0

164 nextRef' <- newTVarIO 0

164 finalizerThreads' <- newMVar S.empty

165 finalizerThreads' <- newMVar S.empty

166+ animationFrameHandlers' <- newMVar []

165 loggingEnabled <- newIORef False

167 loggingEnabled <- newIORef False

166 let ctx = JSContextRef {

168 let ctx = JSContextRef {

167− contextId = contextId'

169+ contextId = contextId'

168− , startTime = startTime'

170+ , startTime = startTime'

169− , doSendCommand = \cmd -> cmd `deepseq` do

171+ , doSendCommand = \cmd -> cmd `deepseq` do

170− result <- newEmptyMVar

172+ result <- newEmptyMVar

171− atomically $ writeTChan commandChan (Right (cmd, result))

173+ atomically $ writeTChan commandChan (Right (cmd, result))

172− unsafeInterleaveIO $

174+ unsafeInterleaveIO $

173− takeMVar result >>= \case

175+ takeMVar result >>= \case

174− (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)

176+ (ThrowJSValue (JSValueReceived v)) -> throwIO $ JSException (JSVal v)

175− r -> return r

177+ r -> return r

176− , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)

178+ , doSendAsyncCommand = \cmd -> cmd `deepseq` atomically (writeTChan commandChan $ Left cmd)

177− , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb)

179+ , addCallback = \(Object (JSVal val)) cb -> atomically $ modifyTVar' callbacks (M.insert val cb)

178− , freeCallback = \(Object (JSVal val)) -> atomically $ modifyTVar' callbacks (M.delete val)

179− , nextRef = nextRef'

180+ , nextRef = nextRef'

180− , doEnableLogging = atomicWriteIORef loggingEnabled

181+ , doEnableLogging = atomicWriteIORef loggingEnabled

181− , finalizerThreads = finalizerThreads'

182+ , finalizerThreads = finalizerThreads'

183+ , animationFrameHandlers = animationFrameHandlers'

182− }

184+ }

183− let processResults :: Bool -> Results -> IO ()

185+ processResults :: Bool -> Results -> IO ()

184 processResults syncCallbacks = \case

186 processResults syncCallbacks = \case

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

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

186 (Callback n br (JSValueReceived fNumber) f this a) -> do

188 (Callback n br (JSValueReceived fNumber) f this a) -> do

@@ -224,14 +226,20 @@ runJavaScript sendBatch entryPoint = do

224 putMVar lastAsyncBatch batch

226 putMVar lastAsyncBatch batch

225 sendBatch batch

227 sendBatch batch

226 takeResult recvMVar nBatch >>= \case

228 takeResult recvMVar nBatch >>= \case

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

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

230+ (_, Success callbacksToFree results)

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

231+ | length results /= length resultMVars -> error "Unexpected number of jsaddle results"

232+ | otherwise -> do

229− | otherwise -> zipWithM_ putMVar resultMVars results

233+ zipWithM_ putMVar resultMVars results

234+ forM_ callbacksToFree $ \(JSValueReceived val) ->

235+ atomically (modifyTVar' callbacks (M.delete val))

230− (_, Failure results exception) -> do

236+ (_, Failure callbacksToFree results exception) -> do

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

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

232− -- missing results (if any) is evaluated.

238+ -- missing results (if any) is evaluated.

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

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

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

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

241+ forM_ callbacksToFree $ \(JSValueReceived val) ->

242+ atomically (modifyTVar' callbacks (M.delete val))

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

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

236 where

244 where

237 numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()

245 numberForeverFromM_ :: (Monad m, Enum n) => n -> (n -> m a) -> m ()

jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+12−6

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

54 \ var runBatch = function(firstBatch, initialSyncDepth) {\n\

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

56 \ var batch = firstBatch;\n\

57+ \ var callbacksToFree = [];\n\

57 \ var results = [];\n\

58 \ var results = [];\n\

58 \ inCallback++;\n\

59 \ inCallback++;\n\

59 \ try {\n\

60 \ try {\n\

@@ -155,6 +156,9 @@ runBatch send sendSync = "\

155 \ jsaddle_values.set(nFunction, func);\n\

156 \ jsaddle_values.set(nFunction, func);\n\

156 \ })();\n\

157 \ })();\n\

157 \ break;\n\

158 \ break;\n\

159+ \ case \"FreeCallback\":\n\

160+ \ callbacksToFree.push(d.contents);\n\

161+ \ break;\n\

158 \ case \"CallAsFunction\":\n\

162 \ case \"CallAsFunction\":\n\

159 \ var n = d.contents[3];\n\

163 \ var n = d.contents[3];\n\

160 \ jsaddle_values.set(n,\n\

164 \ jsaddle_values.set(n,\n\

@@ -268,17 +272,18 @@ runBatch send sendSync = "\

268 \ }\n\

272 \ }\n\

269 \ }\n\

273 \ }\n\

270 \ if(syncDepth <= 0) {\n\

274 \ if(syncDepth <= 0) {\n\

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

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

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

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

273 \ break;\n\

277 \ break;\n\

274 \ } else {\n" <> (

278 \ } else {\n" <> (

275 case sendSync of

279 case sendSync of

276 Just s ->

280 Just s ->

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

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

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

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

279− \ results = [];\n"

283+ \ results = [];\n\

284+ \ callbacksToFree = [];\n"

280 Nothing ->

285 Nothing ->

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

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

282 \ break;\n"

287 \ break;\n"

283 ) <>

288 ) <>

284 " }\n\

289 " }\n\

@@ -293,7 +298,8 @@ runBatch send sendSync = "\

293 \ } else {\n\

298 \ } else {\n\

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

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

295 \ }\n\

300 \ }\n\

296− \ results = [];\n"

301+ \ results = [];\n\

302+ \ callbacksToFree = [];\n"

297 Nothing ->

303 Nothing ->

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

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

299 \ break;\n"

305 \ break;\n"

@@ -305,7 +311,7 @@ runBatch send sendSync = "\

305 \ catch (err) {\n\

311 \ catch (err) {\n\

306 \ var n = ++jsaddle_index;\n\

312 \ var n = ++jsaddle_index;\n\

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

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

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

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

309 \ }\n\

315 \ }\n\

310 \ inCallback--;\n\

316 \ inCallback--;\n\

311 \ };\n\

317 \ };\n\

jsaddle/src/Language/Javascript/JSaddle/Types.hs+12−11

@@ -132,15 +132,15 @@ import GHC.Exts (Constraint)

132type JSContextRef = ()

133#else

134data JSContextRef = JSContextRef {

135− contextId :: UUID

135+ contextId :: UUID

136− , startTime :: UTCTime

136+ , startTime :: UTCTime

137− , doSendCommand :: Command -> IO Result

137+ , doSendCommand :: Command -> IO Result

138− , doSendAsyncCommand :: AsyncCommand -> IO ()

138+ , doSendAsyncCommand :: AsyncCommand -> IO ()

139− , addCallback :: Object -> JSCallAsFunction -> IO ()

139+ , addCallback :: Object -> JSCallAsFunction -> IO ()

140− , freeCallback :: Object -> IO ()

141− , nextRef :: TVar JSValueRef

140+ , nextRef :: TVar JSValueRef

142− , doEnableLogging :: Bool -> IO ()

141+ , doEnableLogging :: Bool -> IO ()

143− , finalizerThreads :: MVar (Set Text)

142+ , finalizerThreads :: MVar (Set Text)

143+ , animationFrameHandlers :: MVar [Double -> JSM ()]

144}

145#endif

146

@@ -377,6 +377,7 @@ data AsyncCommand = FreeRef Text JSValueForSend

377 | NewEmptyObject JSValueForSend

378 | NewAsyncCallback JSValueForSend

379 | NewSyncCallback JSValueForSend

380+ | FreeCallback JSValueForSend

380 | NewArray [JSValueForSend] JSValueForSend

381 | NewArray [JSValueForSend] JSValueForSend

381 | EvaluateScript JSStringForSend JSValueForSend

382 | EvaluateScript JSStringForSend JSValueForSend

382 | SyncWithAnimationFrame JSValueForSend

383 | SyncWithAnimationFrame JSValueForSend

@@ -445,8 +446,8 @@ instance ToJSON Result where

445

446

446instance FromJSON Result

447instance FromJSON Result

447

448

448−data BatchResults = Success [Result]

449+data BatchResults = Success [JSValueReceived] [Result]

449− | Failure [Result] JSValueReceived

450+ | Failure [JSValueReceived] [Result] JSValueReceived

450 deriving (Show, Generic)

451 deriving (Show, Generic)

451

452

452instance ToJSON BatchResults where

453instance ToJSON BatchResults where