Include the exception in UncaughtException

Closes #133

dejafu-tests/Cases/MultiThreaded.hs

@@ -1,7 +1,7 @@
 module Cases.MultiThreaded where
 
 import Control.Exception (ArithException(..))
-import Test.DejaFu (Failure(..), gives, gives')
+import Test.DejaFu (Failure(..), gives, gives', isUncaughtException)
 import Test.Framework (Test)
 
 import Control.Concurrent.Classy hiding (newQSemN, signalQSemN, waitQSemN)
@@ -167,7 +167,7 @@ exceptionTests = toTestList
       killThread tid
       readMVar y
 
-  , djfuT "Throwing to main kills the computation, if unhandled" (gives [Left UncaughtException]) $ do
+  , djfuT "Throwing to main kills the computation, if unhandled" (alwaysFailsWith isUncaughtException) $ do
       tid <- myThreadId
       j <- spawn $ throwTo tid Overflow
       readMVar j

dejafu-tests/Cases/SingleThreaded.hs

@@ -3,7 +3,7 @@
 module Cases.SingleThreaded where
 
 import Control.Exception (ArithException(..), ArrayException(..))
-import Test.DejaFu (Failure(..), gives, gives')
+import Test.DejaFu (Failure(..), gives, gives', isUncaughtException)
 
 import Control.Concurrent.Classy
 import Test.DejaFu.Conc (subconcurrency)
@@ -160,7 +160,7 @@ stmTests =
         (\_ -> writeTVar ctv 6)
       (6==) <$> atomically (readTVar ctv)
 
-  , djfu "MonadSTM is a MonadFail" (gives [Left UncaughtException]) $
+  , djfu "MonadSTM is a MonadFail" (alwaysFailsWith isUncaughtException) $
       (atomically $ fail "hello world" :: MonadConc m => m ())  -- avoid an ambiguous type
   ]
 
@@ -180,7 +180,7 @@ exceptionTests =
           (\_ -> return False))
         (\_ -> return True)
 
-  , djfu "Uncaught exceptions kill the computation" (gives [Left UncaughtException]) $
+  , djfu "Uncaught exceptions kill the computation" (alwaysFailsWith isUncaughtException) $
       catchArithException
         (throw $ IndexOutOfBounds "")
         (\_ -> return False)
@@ -199,7 +199,7 @@ exceptionTests =
         (atomically $ throwSTM Overflow)
         (\_ -> return True)
 
-  , djfu "Throwing an unhandled exception to the main thread kills it" (gives [Left UncaughtException]) $ do
+  , djfu "Throwing an unhandled exception to the main thread kills it" (alwaysFailsWith isUncaughtException) $ do
       tid <- myThreadId
       throwTo tid Overflow
 
@@ -207,7 +207,7 @@ exceptionTests =
       tid <- myThreadId
       catchArithException (throwTo tid Overflow >> pure False) (\_ -> pure True)
 
-  , djfu "MonadConc is a MonadFail" (gives [Left UncaughtException]) $
+  , djfu "MonadConc is a MonadFail" (alwaysFailsWith isUncaughtException) $
       (fail "hello world" :: MonadConc m => m ())  -- avoid an ambiguous type
   ]
 

dejafu-tests/Common.hs

@@ -12,7 +12,7 @@ import qualified Control.Monad.Catch as C
 import Control.Monad.Conc.Class
 import Control.Monad.STM.Class
 import System.Random (mkStdGen)
-import Test.DejaFu (Predicate, Result(..))
+import Test.DejaFu (Predicate, Failure, Result(..), alwaysTrue)
 import Test.DejaFu.Conc (ConcST)
 import qualified Test.Framework as TF
 import Test.Framework.Providers.HUnit (hUnitTestToTests)
@@ -58,6 +58,9 @@ djfu name p c = head . toTestList $ testDejafu c name p
 djfuT :: Show a => String -> Predicate a -> (forall t. ConcST t a) -> [TF.Test]
 djfuT name p c = toTestList $ T name c p
 
+alwaysFailsWith :: (Failure -> Bool) -> Predicate a
+alwaysFailsWith p = alwaysTrue (either p (const False))
+
 -------------------------------------------------------------------------------
 -- Exceptions
 

dejafu/CHANGELOG.markdown

@@ -14,6 +14,10 @@ unreleased
 
 - New `isInternalError`, `isAbort`, `isDeadlock`, `isUncaughtException`, and
   `isIllegalSubconcurrency` functions for matching failure types.  Also exported from Test.DejaFu.
+- The `UncaughtException` `Failure` constructor now includes the exception.
+
+    The `Read`, `Enum`, and `Bounded` instances are gone.  The `Eq`, `Ord`, and `NFData` instances
+    use the `show` of the exception.  Pretty-printed failures include the exception text.
 
 
 ---------------------------------------------------------------------------------------------------

dejafu/Test/DejaFu/Common.hs

@@ -69,8 +69,10 @@ module Test.DejaFu.Common
   ) where
 
 import           Control.DeepSeq   (NFData(..))
-import           Control.Exception (Exception(..), MaskingState(..))
+import           Control.Exception (Exception(..), MaskingState(..),
+                                    SomeException, displayException)
 import           Control.Monad.Ref (MonadRef(..))
+import           Data.Function     (on)
 import           Data.List         (intercalate)
 import           Data.Maybe        (fromMaybe, mapMaybe)
 import           Data.Set          (Set)
@@ -836,9 +838,12 @@ preEmpCount [] _ = 0
 
 -- | An indication of how a concurrent computation failed.
 --
--- @since 0.5.0.0
+-- The @Eq@, @Ord@, and @NFData@ instances compare/evaluate the
-data Failure =
+-- exception with @show@ in the @UncaughtException@ case.
-    InternalError
+--
+-- @since unreleased
+data Failure
+  = InternalError
   -- ^ Will be raised if the scheduler does something bad. This should
   -- never arise unless you write your own, faulty, scheduler! If it
   -- does, please file a bug report.
@@ -851,16 +856,31 @@ data Failure =
   -- ^ The computation became blocked indefinitely on @MVar@s.
   | STMDeadlock
   -- ^ The computation became blocked indefinitely on @TVar@s.
-  | UncaughtException
+  | UncaughtException SomeException
   -- ^ An uncaught exception bubbled to the top of the computation.
   | IllegalSubconcurrency
   -- ^ Calls to @subconcurrency@ were nested, or attempted when
   -- multiple threads existed.
-  deriving (Eq, Show, Read, Ord, Enum, Bounded)
+  deriving Show
+
+instance Eq Failure where
+  (==) = (==) `on` _other
+
+instance Ord Failure where
+  compare = compare `on` _other
 
--- | @since 0.5.1.0
 instance NFData Failure where
-  rnf f = f `seq` ()
+  rnf = rnf . _other
+
+-- | Convert failures into a different representation we can Eq / Ord
+-- / NFData.
+_other :: Failure -> (Int, Maybe String)
+_other InternalError = (0, Nothing)
+_other Abort = (1, Nothing)
+_other Deadlock = (2, Nothing)
+_other STMDeadlock = (3, Nothing)
+_other (UncaughtException e) = (4, Just (show e))
+_other IllegalSubconcurrency = (5, Nothing)
 
 -- | Pretty-print a failure
 --
@@ -870,7 +890,7 @@ showFail Abort = "[abort]"
 showFail Deadlock = "[deadlock]"
 showFail STMDeadlock = "[stm-deadlock]"
 showFail InternalError = "[internal-error]"
-showFail UncaughtException = "[exception]"
+showFail (UncaughtException exc) = "[" ++ displayException exc ++ "]"
 showFail IllegalSubconcurrency = "[illegal-subconcurrency]"
 
 -- | Check if a failure is an @InternalError@.
@@ -899,7 +919,7 @@ isDeadlock _ = False
 --
 -- @since undefined
 isUncaughtException :: Failure -> Bool
-isUncaughtException UncaughtException = True
+isUncaughtException (UncaughtException _) = True
 isUncaughtException _ = False
 
 -- | Check if a failure is an @IllegalSubconcurrency@

dejafu/Test/DejaFu/Conc/Internal.hs

@@ -387,11 +387,12 @@ stepThread sched memtype tid action ctx = case action of
     -- this is not inline in the long @case@ above as it's needed by
     -- @AAtom@, @AThrow@, and @AThrowTo@.
     stepThrow t ts act e =
-      case propagate (toException e) t ts of
+      let some = toException e
-        Just ts' -> simple ts' act
+      in case propagate some t ts of
-        Nothing
+           Just ts' -> simple ts' act
-          | t == initialThread -> pure (Left UncaughtException, Single act)
+           Nothing
-          | otherwise -> simple (kill t ts) act
+             | t == initialThread -> pure (Left (UncaughtException some), Single act)
+             | otherwise -> simple (kill t ts) act
 
     -- helper for actions which only change the threads.
     simple threads' act = pure (Right ctx { cThreads = threads' }, Single act)