How can I prevent QuickCheck from catching all exceptions?

Question

The QuickCheck library seems to catch all exceptions that are thrown when testing a property. In particular, this behavior prevents me from putting a time limit on the entire QuickCheck computation. For example:

module QuickCheckTimeout where

import System.Timeout (timeout)
import Control.Concurrent (threadDelay)
import Test.QuickCheck (quickCheck, within, Property)
import Test.QuickCheck.Monadic (monadicIO, run, assert)

-- use threadDelay to simulate a slow computation
prop_slow_plus_zero_right_identity :: Int -> Property
prop_slow_plus_zero_right_identity i = monadicIO $ do
  run (threadDelay (100000 * i))
  assert (i + 0 == i)

runTests :: IO ()
runTests = do
  result <- timeout 3000000 (quickCheck prop_slow_plus_zero_right_identity)
  case result of
    Nothing -> putStrLn "timed out!"
    Just _  -> putStrLn "completed!"

Because QuickCheck catches all the exceptions, timeout breaks: it doesn't actually abort the computation! Instead, QuickCheck treats the property as having failed, and tries to shrink the input that caused the failure. This shrinking process is then not run with a time bound, causing the total time used by the computation to exceed the prescribed time limit.

One might think I could use QuickCheck's within combinator to bound the computation time. (within treats a property as having failed if it doesn't finish within the given time limit.) However, within doesn't quite do what I want, since QuickCheck still tries to shrink the input that caused the failure, a process that can take far too long. (What could alternatively work for me is a version of within that prevents QuickCheck from trying to shrink the inputs to a property that failed because it didn't finish within the given time limit.)

How can I prevent QuickCheck from catching all exceptions?

Answer 1

Since QuickCheck does the right thing when the user manually interrupts the test by pressing Ctrl+C, you might be able to work around this issue by writing something similar to timeout, but that throws an asynchroneous UserInterrupt exception instead of a custom exception type.

This is pretty much a straight copy-and-paste job from the source of System.Timeout:

import Control.Concurrent
import Control.Exception

timeout' n f = do
    pid <- myThreadId
    bracket (forkIO (threadDelay n >> throwTo pid UserInterrupt))
            (killThread)
            (const f)

With this approach, you'll have to use quickCheckResult and check the failure reason to detect whether the test timed out or not. It seems to work decent enough:

> runTests 
*** Failed! Exception: 'user interrupt' (after 13 tests):  
16

Answer 2

Maybe the chasingbottoms package would be useful? http://hackage.haskell.org/packages/archive/ChasingBottoms/1.3.0.3/doc/html/Test-ChasingBottoms-TimeOut.html