`IOSim` interferes with `QuickCheck` exception handling

[MaximilianAlgehed]

Describe the bug
We observe the following:

ghci> quickCheck $ discardAfter 1 $ runSimOrThrow $ True <$ (forever (threadDelay 10))
*** Failed! Exception: '<<evaluation error: <<timeout>>>>' (after 1 test):

To Reproduce

ghci> import Test.QuickCheck
ghci> import Control.Monad.IOSim
ghci> import Control.Monad.Class.MonadTimer
ghci> quickCheck $ discardAfter 1 $ runSimOrThrow $ True <$ (forever (threadDelay 10))
*** Failed! Exception: '<<evaluation error: <<timeout>>>>' (after 1 test):

Expected behaviour

ghci> quickCheck $ discardAfter 1 $ runSimOrThrow $ True <$ (forever (threadDelay 10))
*** Gave up! Passed only 0 tests; 1000 discarded tests.

Desktop (please complete the following information):

• GHC version: 9.12.2
• io-sim version: 1.8.0.1
• io-classes version: 1.8.0.1

Additional context
I think what's going on here is that io-sim is catching all timeout exceptions even though these are thrown by QuickCheck in this case. Perhaps more care can be taken here to avoid overlapping with QuickCheck? QuickCheck might be able to use a different exception, but that feels like a crutch?

[coot]

With the patch below I get:

$ timeout 1 $ evaluate $ runSimOrThrow $ True <$ (forever $ threadDelay 10)
Nothing

rather than:

$ timeout 1 $ evaluate $ runSimOrThrow $ True <$ (forever $ threadDelay 10)
*** Exception: <<evaluation error: <<timeout>>>>

But still:

ghci> quickCheck $ discardAfter 1 $ runSimOrThrow $ True <$ (forever (threadDelay 10))
*** Exception: '<<timeout>>'

rather than the expected behaviour.

diff --git a/io-sim/src/Control/Monad/IOSim.hs b/io-sim/src/Control/Monad/IOSim.hs
index ecd0f1bec..658974c76 100644
--- a/io-sim/src/Control/Monad/IOSim.hs
+++ b/io-sim/src/Control/Monad/IOSim.hs
@@ -99,7 +99,7 @@ import Data.Typeable (Typeable)
 
 import Data.List.Trace (Trace (..))
 
-import Control.Exception (throw)
+import Control.Exception (SomeAsyncException (..), throw)
 
 import Control.Monad.ST.Lazy
 
@@ -111,6 +111,7 @@ import Control.Monad.IOSimPOR.Internal qualified as IOSimPOR (controlSimTraceST)
 import Control.Monad.IOSimPOR.QuickCheckUtils
 
 import Test.QuickCheck
+import Test.QuickCheck.Exception qualified as QC
 import Test.QuickCheck.Gen.Unsafe (Capture (..), capture)
 import Test.QuickCheck.Monadic (PropertyM, monadic')
 
@@ -422,7 +423,10 @@ traceResult strict = unsafePerformIO . eval
   where
     eval :: SimTrace a -> IO (Either Failure a)
     eval a = do
-      r <- try (evaluate a)
+      r <- tryJust (\e -> case fromException @SomeAsyncException e of
+                            Just _  -> Nothing
+                            Nothing -> Just e)
+                   (evaluate a)
       case r of
         Left e  -> return (Left (FailureEvaluation e))
         Right _ -> go a

[coot]

But with the patch:

ghci> quickCheck $ within 1 $ runSimOrThrow $ True <$ (forever $ threadDelay 10)
*** Failed! Timeout of 1 microseconds exceeded. (after 1 test):

which is the correct behaviour, while without it:

ghci> quickCheck $ within 1 $ runSimOrThrow $ True <$ (forever $ threadDelay 10)
*** Failed! Exception: '<<evaluation error: <<timeout>>>>' (after 1 test):

[coot]

@MaximilianAlgehed do you have a clue why the patch fixed within but not discardAfter?

[coot]

I debugged it a bit further. On top of the above patch, the following patch is also needed in QuickCheck to fix the bug (but I don't suggest including it).

TLDR: the patch adds Timeout exception handler to the io action run by ioRose inside the onTimeout function. It looks like a Timeout exception thrown by timeout leaked outside it—which is rather odd — but it could be a bug in the timeout function itself related to masking asynchronous exceptions.

diff --git a/src/Test/QuickCheck/Property.hs b/src/Test/QuickCheck/Property.hs
index 7c507de..bf7e881 100644
--- a/src/Test/QuickCheck/Property.hs
+++ b/src/Test/QuickCheck/Property.hs
@@ -21,12 +21,12 @@ import Test.QuickCheck.Exception
 import Test.QuickCheck.State( State(terminal, numSuccessTests, numDiscardedTests, maxSuccessTests, numSuccessShrinks, numTryShrinks, numTotTryShrinks), Confidence(.
.), TestProgress(..) )
 
 #ifndef NO_TIMEOUT
-import System.Timeout(timeout)
+import System.Timeout(Timeout, timeout)
 #endif
 import Data.Maybe
 import Control.Applicative
 #if defined(MIN_VERSION_base)
-import Control.Exception (displayException)
+import Control.Exception (onException, catch, fromException, displayException)
 #endif
 import Control.Monad
 import qualified Data.Map as Map
@@ -886,13 +886,18 @@ onTimeout :: Testable prop => Result -> Int -> prop -> Property
 onTimeout timeoutResult n = mapRoseResult f
   where
     f rose = ioRose $ do
-      let orError :: IO (Maybe a) -> a -> IO a
-          m `orError` x = fmap (fromMaybe x) m
-      MkRose res roses <- timeout n (reduceRose rose) `orError`
-        return timeoutResult
-      res' <- timeout n (protectResult (return res)) `orError`
-        timeoutResult
-      return (MkRose res' (map f roses))
+        let orError :: IO (Maybe a) -> a -> IO a
+            m `orError` x = fmap (fromMaybe x) m
+        MkRose res roses <- timeout n (reduceRose rose) `orError`
+           return timeoutResult
+        res' <- timeout n (protectResult (return res)) `orError`
+           timeoutResult
+        return (MkRose res' (map f roses))
+      `catch` handleTimeout
+
+    handleTimeout :: Timeout -> IO (Rose Result)
+    handleTimeout _ = return $ pure timeoutResult
+
 #ifdef NO_TIMEOUT
     timeout _ = fmap Just
 #endif

[coot]

It's tricky to use the original discardWith (e.g. without the QuickCheck patch), but not impossible:

{-# OPTIONS_GHC -fno-full-laziness #-}

unit_discardAfter :: Property
unit_discardAfter = discardAfter 10 $
                    -- we need a lambda here, and we need to make sure `GHC` will not
                    -- move the inner thunk outside of it (thus `-fno-full-laziness`) 
                    \() -> runSimOrThrow $ True <$ (forever (threadDelay 10))

it logs the expected:

      timeout: discardAfter: FAIL (0.09s)
        *** Gave up! Passed only 0 tests; 1000 discarded tests.
        Use --quickcheck-replay=545265 to reproduce.

What happens with

unit_discardAfter :: Property
unit_discardAfter = discardAfter 10 $
                    runSimOrThrow $ True <$ (forever (threadDelay 10))

is that the runSimOrThrow $ ... thunk is only evaluated once, unlike ioProperty $ ....

[MaximilianAlgehed]

I'm sorry I didn't have time to answer before you fixed this. Great work, thank you!