68651f4 · jsaddle · git.iko.soy

git.iko.soy/jsaddle

Fix #35 and add animationFrameHandlers.

To fix #35 a FreeCallback async command is sent now sent (instead of immediately freeing the callback). When the batch results comes back it includes a list of all the callbacks that can now safely be freed. The animationFrameHandlers in JSContextRef will be used in inAnimationFrame (in `jsadddle-dom`).

commit68651f42e5b784211636049d36c224d3854e2bce authorHamish Mackenzie <Hamish.K.Mackenzie@googlemail.com> dateTue 27 Jun 2017, 13:53 (9 years ago) parent903c374

6 files changed+64−48

compare with master

unifiedsplit

jsaddle/jsaddle.cabal+1 jsaddle/src/Language/Javascript/JSaddle/Null.hs+1−1 jsaddle/src/Language/Javascript/JSaddle/Object.hs+5−5 jsaddle/src/Language/Javascript/JSaddle/Run.hs+33−25 jsaddle/src/Language/Javascript/JSaddle/Run/Files.hs+12−6 jsaddle/src/Language/Javascript/JSaddle/Types.hs+12−11

jsaddle/jsaddle.cabal+1

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

6363 GHCJS.Prim

6464 GHCJS.Prim.Internal

6565 GHCJS.Types

66+ GHCJS.Concurrent

6667 GHCJS.Foreign

6768 GHCJS.Foreign.Internal

6869 GHCJS.Internal.Types

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

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

3737 _ <- forkIO $ forever $

3838 readChan batches >>= \case

3939 Batch commands _ batchNumber ->

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

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

4141 Left _ -> Nothing

4242 Right command -> Just $

4343 case command of

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

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

119119 (newAsyncCallback, newSyncCallback, callAsFunction, callAsConstructor)

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

121121import Language.Javascript.JSaddle.Types

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

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

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

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

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

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

125126#endif

126127import JavaScript.Array.Internal (fromListIO)

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

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

481482freeFunction (Function callback _) = liftIO $

482483 releaseCallback callback

483484#else

484−freeFunction (Function object) = do

485− free <- freeCallback <$> askJSM

486− liftIO $ free object

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

486+ sendAsyncCommand (FreeCallback (JSValueForSend objectRef))

487487#endif

488488

489489instance ToJSVal Function where

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

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

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

7474import Control.DeepSeq (deepseq)

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

76+import Data.Foldable (forM_)

7677#endif

7778

7879-- | Enable (or disable) JSaddle logging

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

162163 callbacks <- newTVarIO M.empty

163164 nextRef' <- newTVarIO 0

164165 finalizerThreads' <- newMVar S.empty

166+ animationFrameHandlers' <- newMVar []

165167 loggingEnabled <- newIORef False

166168 let ctx = JSContextRef {

167− contextId = contextId'

168− , startTime = startTime'

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

170− result <- newEmptyMVar

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

172− unsafeInterleaveIO $

173− takeMVar result >>= \case

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

175− r -> return r

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

177− , 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− , doEnableLogging = atomicWriteIORef loggingEnabled

181− , finalizerThreads = finalizerThreads'

182− }

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

169+ contextId = contextId'

170+ , startTime = startTime'

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

172+ result <- newEmptyMVar

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

174+ unsafeInterleaveIO $

175+ takeMVar result >>= \case

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

177+ r -> return r

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

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

180+ , nextRef = nextRef'

181+ , doEnableLogging = atomicWriteIORef loggingEnabled

182+ , finalizerThreads = finalizerThreads'

183+ , animationFrameHandlers = animationFrameHandlers'

184+ }

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

184186 processResults syncCallbacks = \case

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

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

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

224226 putMVar lastAsyncBatch batch

225227 sendBatch batch

226228 takeResult recvMVar nBatch >>= \case

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

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

229− | otherwise -> zipWithM_ putMVar resultMVars results

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

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

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

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

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

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

230+ (_, Success callbacksToFree results)

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

232+ | otherwise -> do

233+ zipWithM_ putMVar resultMVars results

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

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

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

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

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

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

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

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

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

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

236244 where

237245 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 = "\

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

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

5656 \ var batch = firstBatch;\n\

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

5758 \ var results = [];\n\

5859 \ inCallback++;\n\

5960 \ try {\n\

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

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

156157 \ })();\n\

157158 \ break;\n\

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

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

161+ \ break;\n\

158162 \ case \"CallAsFunction\":\n\

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

160164 \ jsaddle_values.set(n,\n\

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

268272 \ }\n\

269273 \ }\n\

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

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

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

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

273277 \ break;\n\

274278 \ } else {\n" <> (

275279 case sendSync of

276280 Just s ->

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

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

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

279− \ results = [];\n"

283+ \ results = [];\n\

284+ \ callbacksToFree = [];\n"

280285 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\

282287 \ break;\n"

283288 ) <>

284289 " }\n\

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

293298 \ } else {\n\

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

295300 \ }\n\

296− \ results = [];\n"

301+ \ results = [];\n\

302+ \ callbacksToFree = [];\n"

297303 Nothing ->

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

299305 \ break;\n"

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

305311 \ catch (err) {\n\

306312 \ var n = ++jsaddle_index;\n\

307313 \ 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\

309315 \ }\n\

310316 \ inCallback--;\n\

311317 \ };\n\

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

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

132132type JSContextRef = ()

133133#else

134134data JSContextRef = JSContextRef {

135− contextId :: UUID

136− , startTime :: UTCTime

137− , doSendCommand :: Command -> IO Result

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

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

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

141− , nextRef :: TVar JSValueRef

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

143− , finalizerThreads :: MVar (Set Text)

135+ contextId :: UUID

136+ , startTime :: UTCTime

137+ , doSendCommand :: Command -> IO Result

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

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

140+ , nextRef :: TVar JSValueRef

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

142+ , finalizerThreads :: MVar (Set Text)

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

144144}

145145#endif

146146

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

377377 | NewEmptyObject JSValueForSend

378378 | NewAsyncCallback JSValueForSend

379379 | NewSyncCallback JSValueForSend

380+ | FreeCallback JSValueForSend

380381 | NewArray [JSValueForSend] JSValueForSend

381382 | EvaluateScript JSStringForSend JSValueForSend

382383 | SyncWithAnimationFrame JSValueForSend

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

445446

446447instance FromJSON Result

447448

448−data BatchResults = Success [Result]

449− | Failure [Result] JSValueReceived

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

450+ | Failure [JSValueReceived] [Result] JSValueReceived

450451 deriving (Show, Generic)

451452

452453instance ToJSON BatchResults where