io-sim: exception handling in traceResult

Author: coot

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
 
@@ -422,7 +422,16 @@ traceResult strict = unsafePerformIO . eval
   where
     eval :: SimTrace a -> IO (Either Failure a)
     eval a = do
-      r <- try (evaluate a)
+      -- NOTE: It's fine to let asynchronous exceptions pass through. The only
+      -- way simulation could raise them is by using `throw` in pure code, while
+      -- `throwIO` in the simulation will be captured as `FailureException`.  So
+      -- we can safely assume asynchronous exceptions are coming from the
+      -- environment running the simulation, e.g. `QuickCheck`, as in the case
+      -- of `within` or `discardedAfter` operators.
+      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

io-sim/test/Test/Control/Monad/IOSim.hs

@@ -1,6 +1,9 @@
 {-# LANGUAGE CPP #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
+-- `-fno-full-laziness` is needed for `discardAfter` to work correctly, see
+-- `unit_discardAfter` below..
+{-# OPTIONS_GHC -fno-full-laziness #-}
 
 module Test.Control.Monad.IOSim
   ( tests
@@ -43,6 +46,7 @@ import Test.Control.Monad.STM
 import Test.Control.Monad.Utils
 
 import Test.QuickCheck
+import Test.QuickCheck.Property as QC
 import Test.Tasty hiding (after)
 import Test.Tasty.QuickCheck
 
@@ -60,6 +64,8 @@ tests =
     , testProperty "timeout"                prop_timeout
     , testProperty "timeouts"               prop_timeouts
     , testProperty "stacked timeouts"       prop_stacked_timeouts
+    , testProperty "timeout: discardAfter"  unit_discardAfter
+    , testProperty "timeout: within"        unit_within
     , testProperty "async exceptions 1"     unit_timeouts_and_async_exceptions_1
     , testProperty "async exceptions 2"     unit_timeouts_and_async_exceptions_2
     , testProperty "async exceptions 3"     unit_timeouts_and_async_exceptions_3
@@ -1073,6 +1079,42 @@ prop_stacked_timeouts timeout0 timeout1 actionDuration =
               = Just Nothing
 
 
+-- | Check that `discardAfter` works as expected.
+--
+-- NOTE: using `discardAfter` with `IOSim` is more tricky than for `IO`
+-- properties, since `IOSim` is a pure computation.  One need to wrap the
+-- simulation in a lambda and use `-fno-full-laziness` to avoid GHC from
+-- moving the thunk outside of the lambda, and evaluating it just once.
+--
+unit_discardAfter :: Property
+unit_discardAfter = mapTotalResult f $ discardAfter 10 $ \() -> runSimOrThrow $ True <$ (forever (threadDelay 10))
+  where
+    -- if `discard` kills the computation with the `Timeout` exception,
+    -- `theException` is `Nothing`, but if `traceResult` wraps it, then it is
+    -- a `Just`. We mark each test a success if `theException` is `Nothing`,
+    -- otherwise the test would fail with too many discarded cases, but if we re
+    -- introduce the bug in `traceResult` then it fails, since then
+    -- `theException` is a `Just`.
+    f :: QC.Result -> QC.Result
+    f r@MkResult { QC.theException = Nothing }
+       = r { ok = Just True }
+    f r = r
+
+
+-- | Check that `within` works as expected.
+--
+unit_within :: Property
+unit_within = mapTotalResult f $ within 1 $ runSimOrThrow $ True <$ (forever (threadDelay 10))
+  where
+    -- if `within` kills the computation with the `Timeout` exception,
+    -- `theException` is `Nothing`, but if `traceResult` wraps it, then it is
+    -- a `Just`.
+    f :: QC.Result -> QC.Result
+    f r@MkResult { QC.theException = Nothing }
+       = r { expect = False }
+    f r = r
+
+
 unit_timeouts_and_async_exceptions_1 :: Property
 unit_timeouts_and_async_exceptions_1 =
     let trace = runSimTrace experiment in