ghc-mod/test/MonadSpec.hs
2016-07-10 23:42:13 +02:00

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