mirror of
https://github.com/barrucadu/dejafu.git
synced 2024-12-24 22:12:25 +03:00
parent
2f4fe81473
commit
a571368125
@ -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
|
||||
|
@ -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
|
||||
]
|
||||
|
||||
|
@ -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
|
||||
|
||||
|
@ -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.
|
||||
|
||||
|
||||
---------------------------------------------------------------------------------------------------
|
||||
|
@ -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
|
||||
data Failure =
|
||||
InternalError
|
||||
-- The @Eq@, @Ord@, and @NFData@ instances compare/evaluate the
|
||||
-- exception with @show@ in the @UncaughtException@ case.
|
||||
--
|
||||
-- @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@
|
||||
|
@ -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
|
||||
Just ts' -> simple ts' act
|
||||
Nothing
|
||||
| t == initialThread -> pure (Left UncaughtException, Single act)
|
||||
| otherwise -> simple (kill t ts) act
|
||||
let some = toException e
|
||||
in case propagate some t ts of
|
||||
Just ts' -> simple ts' act
|
||||
Nothing
|
||||
| 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)
|
||||
|
Loading…
Reference in New Issue
Block a user