ghc-mod/test/MonadSpec.hs

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