io-sim: exception handling in traceResult

Author: coot

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
 

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

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