Make runGhcModT thread lock test more reliable
it was failing reproducibly with `cabal test --show-details=streaming`
This commit is contained in:
parent
c0e563fbff
commit
bb5ac3899a
@ -20,17 +20,26 @@ spec = do
|
|||||||
|
|
||||||
describe "runGhcModT" $
|
describe "runGhcModT" $
|
||||||
it "throws an exception when run in multiple threads" $ do
|
it "throws an exception when run in multiple threads" $ do
|
||||||
mv1 :: MVar (Either SomeException ())
|
|
||||||
<- newEmptyMVar
|
|
||||||
mv2 :: MVar (Either SomeException ())
|
|
||||||
<- newEmptyMVar
|
|
||||||
|
|
||||||
_ <- forkOS $ putMVar mv1 =<< (try $ evaluate =<< (runD $ liftIO $ readMVar mv2 >> return ()))
|
mv_ex :: MVar (Either SomeException ())
|
||||||
_ <- forkOS $ putMVar mv2 =<< (try $ evaluate =<< (runD $ return ()))
|
<- newEmptyMVar
|
||||||
e1 <- takeMVar mv1
|
mv_startup_barrier :: MVar () <- newEmptyMVar
|
||||||
e2 <- takeMVar mv2
|
|
||||||
|
|
||||||
(isLeft e1 || isLeft e2) `shouldBe` True
|
_t1 <- forkOS $ do
|
||||||
|
putMVar mv_startup_barrier ()
|
||||||
|
-- wait (inside GhcModT) for t2 to receive the exception
|
||||||
|
_ <- runD $ liftIO $ readMVar mv_ex
|
||||||
|
return ()
|
||||||
|
|
||||||
|
_t2 <- forkOS $ do
|
||||||
|
readMVar mv_startup_barrier -- wait for t1 to start up
|
||||||
|
res <- try $ runD $ return ()
|
||||||
|
res' <- evaluate res
|
||||||
|
putMVar mv_ex res'
|
||||||
|
|
||||||
|
ex <- takeMVar mv_ex
|
||||||
|
|
||||||
|
isLeft ex `shouldBe` True
|
||||||
|
|
||||||
isLeft :: Either a b -> Bool
|
isLeft :: Either a b -> Bool
|
||||||
isLeft (Right _) = False
|
isLeft (Right _) = False
|
||||||
|
Loading…
Reference in New Issue
Block a user