Testing for correctness under asynchronous exceptions in Haskell

Question

I am trying to come up with tests for correct behavior under asynchronous exceptions. To make things concrete, consider the following example,

casMVar :: Eq a => MVar a -> a -> a -> IO Bool
casMVar m old new = do
  cur <- takeMVar m
  if cur == old
  then putMVar m new >> return True
  else putMVar m old >> return False

where the invariant is that m is not empty. I think that this invariant is violated under asynchronous exceptions, since such an exception might arrive in the if expression. On my machine it is however not exposed by throwing exceptions at a forked casMVar with increasing delays, like so,

values :: Maybe (List Bool)
values = action <$> killDelays
where
  killDelays = toDelays <$> [-100..100]
  toDelays :: Int -> (Int, Int)
  toDelays dt = if dt < 0 then (-dt, 0) else (0, dt)
  action :: (Int, Int) -> IO (Maybe Bool)
  action (s, t) = do
    m <- newMVar False
    threadId <- forkIO $ threadDelay s >> void (casMVar m False True)
    threadDelay t
    throwTo threadId ThreadKilled
    tryReadMVar m

Although values is a list of Just False's concatenated with a list of Just True's.

Is there some way to expose the violation? Or at least to increase the probability that on a some machine the violation is exposed? I am specifically not looking for ways to make this code correct, the question is purely about testing.

Answer 1

I don't know of a general method for testing arbitrary code under asynchronous exceptions. For the particular example you gave, I would simply pass an exception throwing value as parameter of casMVar, and check whether after the evaluation of casMVar the MVar is non-empty:

boom = error "Handle me!"

pokemonHandler :: a -> SomeException -> IO a
pokemonHandler a e = return a

spec :: Spec
spec = do
  describe "casMVar" $ do
    it "puts back a value on the MVar under an exception" $ do
      m <- newMVar "foo"
      a <- async $
        casMVar m boom "bar" `catch` pokemonHandler True
      _ <- wait a
      val <- readMVar m
      val `shouldBe` "foo"

The complete code can be found here https://github.com/capitanbatata/sandbox/tree/master/testing-under-async-exceptions