@@ -49,7 +49,7 @@ import Control.Concurrent.STM.TChan
4949import Control.Concurrent.STM.TVar
5050 (writeTVar, readTVar, readTVarIO, modifyTVar', newTVarIO)
5151import Control.Concurrent.MVar
52− (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar)
52+ (tryTakeMVar, MVar, putMVar, takeMVar, newEmptyMVar, readMVar)
5353
5454import System.IO.Unsafe (unsafeInterleaveIO)
5555import System.Mem.Weak (addFinalizer)
@@ -61,7 +61,7 @@ import Data.Time.Clock (getCurrentTime,diffUTCTime)
6161import Data.IORef (newIORef, atomicWriteIORef, readIORef)
6262
6363import Language.Javascript.JSaddle.Types
64− (Command(..), AsyncCommand(..), Result(..), Results(..), JSContextRef(..), JSVal(..),
64+ (Command(..), AsyncCommand(..), Result(..), BatchResults(..), Results(..), JSContextRef(..), JSVal(..),
6565 Object(..), JSValueReceived(..), JSM(..), Batch(..), JSValueForSend(..))
6666import Language.Javascript.JSaddle.Exception (JSException(..))
6767-- import Language.Javascript.JSaddle.Native.Internal (wrapJSVal)
@@ -152,7 +152,6 @@ runJavaScript :: (Batch -> IO ()) -> JSM () -> IO (Results -> IO (), Results ->
152152runJavaScript sendBatch entryPoint = do
153153 startTime' <- getCurrentTime
154154 recvMVar <- newEmptyMVar
155− syncSendBatch <- newEmptyMVar
156155 lastAsyncBatch <- newEmptyMVar
157156 commandChan <- newTChanIO
158157 callbacks <- newTVarIO M.empty
@@ -176,7 +175,8 @@ runJavaScript sendBatch entryPoint = do
176175 let processResults :: Bool -> Results -> IO ()
177176 processResults syncCallbacks = \case
178177 (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)
180180 f'@(JSVal fNumber) <- runReaderT (unJSM $ wrapJSVal f) ctx
181181 this' <- runReaderT (unJSM $ wrapJSVal this) ctx
182182 args <- runReaderT (unJSM $ mapM wrapJSVal a) ctx
@@ -185,27 +185,20 @@ runJavaScript sendBatch entryPoint = do
185185 Nothing -> liftIO $ putStrLn "Callback called after it was freed"
186186 Just cb -> void . forkIO $ do
187187 runReaderT (unJSM $ cb f' this' args) ctx
188− when syncCallbacks $ do
188+ when syncCallbacks $
189189 doSendAsyncCommand ctx EndSyncBlock
190− void $ doSendCommand ctx Sync
191− Duplicate -> error "Error : Unexpected Duplicate"
192− m -> putMVar recvMVar m
190+ Duplicate nBatch nExpected -> do
191+ putStrLn $ "Error : Unexpected Duplicate. syncCallbacks=" <> show syncCallbacks <>
192+ " nBatch=" <> show nBatch <> " nExpected=" <> show nExpected
193+ void $ doSendCommand ctx Sync
194+ BatchResults n br -> putMVar recvMVar (n, br)
193195 asyncResults :: Results -> IO ()
194− asyncResults = processResults False
196+ asyncResults results =
197+ void . forkIO $ processResults False results
195198 syncResults :: Results -> IO Batch
196199 syncResults results = do
197− existing <- tryTakeMVar syncSendBatch
198− when (isJust existing) $ error "Error : Unexpected Sync Results"
199− tryTakeMVar lastAsyncBatch >>= \case
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
200+ void . forkIO $ processResults True results
201+ readMVar lastAsyncBatch
209202 logInfo s =
210203 readIORef loggingEnabled >>= \case
211204 True -> do
@@ -219,24 +212,24 @@ runJavaScript sendBatch entryPoint = do
219212 readBatch nBatch commandChan >>= \case
220213 (batch@(Batch cmds _ _), resultMVars) -> do
221214 logInfo (\x -> "Sync " <> x <> show (length cmds, last cmds))
222− tryTakeMVar syncSendBatch >>= \case
223− Just send -> send batch
224− Nothing -> do
225− putMVar lastAsyncBatch batch
226− sendBatch batch
227− takeMVar recvMVar >>= \r -> do
228− _ <- tryTakeMVar lastAsyncBatch
229− case r of
230− Success results | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
231− | otherwise -> zipWithM_ putMVar resultMVars results
232− Failure results exception -> do
215+ _ <- tryTakeMVar lastAsyncBatch
216+ putMVar lastAsyncBatch batch
217+ sendBatch batch
218+ takeResult recvMVar nBatch >>= \case
219+ (n, _) | n /= nBatch -> error $ "Unexpected jsaddle results (expected batch " <> show nBatch <> ", got batch " <> show n <> ")"
220+ (_, Success results) | length results /= length resultMVars -> error "Unexpected number of jsaddle results"
221+ | otherwise -> zipWithM_ putMVar resultMVars results
222+ (_, Failure results exception) -> do
233223 -- The exception will only be rethrown in Haskell if/when one of the
234224 -- missing results (if any) is evaluated.
235225 putStrLn "A JavaScript exception was thrown! (may not reach Haskell code)"
236226 zipWithM_ putMVar resultMVars $ results <> repeat (ThrowJSValue exception)
237− _ -> error "Unexpected jsaddle results"
238227 return (asyncResults, syncResults, runReaderT (unJSM entryPoint) ctx)
239228 where
229+ takeResult recvMVar nBatch =
230+ takeMVar recvMVar >>= \case
231+ (n, _) | n < nBatch -> takeResult recvMVar nBatch
232+ r -> return r
240233 readBatch :: Int -> TChan (Either AsyncCommand (Command, MVar Result)) -> IO (Batch, [MVar Result])
241234 readBatch nBatch chan = do
242235 first <- atomically $ readTChan chan -- We want at least one command to send