diff --git a/io-sim/CHANGELOG.md b/io-sim/CHANGELOG.md index 3a90c9eb..1b2bb104 100644 --- a/io-sim/CHANGELOG.md +++ b/io-sim/CHANGELOG.md @@ -8,6 +8,10 @@ * Added support for unique symbol generation à la `Data.Unique`. * Removed a misleading internal comment. +* Fixed error handling in `traceResult` so one can combine it (or ather APIs + which are based on it: `runSim`, `runSimOrThrow`, or `runSimStrictShutdown`) + with `within` or `discardAfter` from `QuickCheck`. See the test suite how to + use `discardAfter` with `IOSim`. ## 1.8.0.1 diff --git a/io-sim/src/Control/Monad/IOSim.hs b/io-sim/src/Control/Monad/IOSim.hs index ecd0f1be..83175bd6 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 @@ -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 `discardAfter` 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 diff --git a/io-sim/test/Test/Control/Monad/IOSim.hs b/io-sim/test/Test/Control/Monad/IOSim.hs index cb3fc106..2bf4f1f9 100644 --- a/io-sim/test/Test/Control/Monad/IOSim.hs +++ b/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 @@ -67,6 +71,10 @@ tests = , testProperty "{register,thread}Delay" unit_registerDelay_threadDelay , testProperty "throwTo and STM" unit_throwTo_and_stm ] + , testGroup "QuickCheck" + [ testProperty "timeout: discardAfter" unit_discardAfter + , testProperty "timeout: within" unit_within + ] , testProperty "threadId order (IOSim)" (withMaxSuccess 1000 prop_threadId_order_order_Sim) , testProperty "forkIO order (IOSim)" (withMaxSuccess 1000 prop_fork_order_ST) , testProperty "order (IO)" (expectFailure prop_fork_order_IO) @@ -1073,6 +1081,46 @@ 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 10 + $ 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