62 lines
2.0 KiB
Haskell
62 lines
2.0 KiB
Haskell
module MonadSpec where
|
|
|
|
import Test.Hspec
|
|
import TestUtils
|
|
import Control.Monad.Error.Class
|
|
import Control.Concurrent
|
|
import Control.Exception
|
|
|
|
spec :: Spec
|
|
spec = do
|
|
describe "When using GhcModT in a do block" $
|
|
it "a pattern match failure causes a call to `fail` on ErrorT in the monad stack" $ do
|
|
(a, _h)
|
|
<- runGmOutDef $ runGhcModT defaultOptions $
|
|
do
|
|
Just _ <- return Nothing
|
|
return "hello"
|
|
`catchError` (const $ fail "oh noes")
|
|
a `shouldBe` (Left $ GMEString "oh noes")
|
|
|
|
describe "runGhcModT" $
|
|
it "throws an exception when run in multiple threads" $ do
|
|
|
|
mv_ex :: MVar (Either SomeException ())
|
|
<- newEmptyMVar
|
|
mv_startup_barrier :: MVar ()
|
|
<- newEmptyMVar
|
|
mv_startup_barrier :: MVar () <- newEmptyMVar
|
|
|
|
_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'
|
|
|
|
_t1 <- forkOS $ do
|
|
-- wait (inside GhcModT) for t2 to receive the exception
|
|
_ <- runD $ liftIO $ do
|
|
putMVar mv_startup_barrier ()
|
|
readMVar mv_ex
|
|
return ()
|
|
|
|
_t2 <- forkOS $ do
|
|
readMVar mv_startup_barrier -- wait for t1 to be in GhcModT
|
|
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 (Right _) = False
|
|
isLeft (Left _) = True
|