diff --git a/CHANGELOG.rst b/CHANGELOG.rst --- a/CHANGELOG.rst +++ b/CHANGELOG.rst @@ -7,6 +7,30 @@ .. _PVP: https://pvp.haskell.org/ +1.10.0.0 (2018-06-17) +--------------------- + +* Git: :tag:`dejafu-1.10.0.0` +* Hackage: :hackage:`dejafu-1.10.0.0` + +Added +~~~~~ + +* The ``Test.DejaFu.notAlwaysSameOn`` and ``notAlwaysSameBy`` + predicates, generalising ``notAlwaysSame``. + +Changed +~~~~~~~ + +* ``Test.DejaFu.autocheck`` and related functions use the + ``successful`` predicate, rather than looking specifically for + deadlocks and uncaught exceptions. + +* (:issue:`259`) The ``Test.DejaFu.alwaysSame``, ``alwaysSameOn``, + ``alwaysSameBy``, and ``notAlwaysSame`` predicates fail if the + computation under test fails. + + 1.9.1.0 (2018-06-10) -------------------- diff --git a/Test/DejaFu.hs b/Test/DejaFu.hs --- a/Test/DejaFu.hs +++ b/Test/DejaFu.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TupleSections #-} {- | @@ -7,7 +6,7 @@ License : MIT Maintainer : Michael Walker Stability : experimental -Portability : LambdaCase, MultiParamTypeClasses, TupleSections +Portability : TupleSections dejafu is a library for unit-testing concurrent Haskell programs, written using the [concurrency](https://hackage.haskell.org/package/concurrency) @@ -27,17 +26,15 @@ We can test it with dejafu like so: >>> autocheck example -[pass] Never Deadlocks -[pass] No Exceptions -[fail] Consistent Result +[pass] Successful +[fail] Deterministic "hello" S0----S1--S0-- "world" S0----S2--S0-- False The 'autocheck' function takes a concurrent program to test and looks -for some common unwanted behaviours: deadlocks, uncaught exceptions in -the main thread, and nondeterminism. Here we see the program is +for concurrency errors and nondeterminism. Here we see the program is nondeterministic, dejafu gives us all the distinct results it found and, for each, a summarised execution trace leading to that result: @@ -177,6 +174,8 @@ , representative , alwaysSameOn , alwaysSameBy + , notAlwaysSameOn + , notAlwaysSameBy , alwaysTrue , somewhereTrue , alwaysNothing @@ -272,14 +271,16 @@ import Control.Monad (unless, when) import Control.Monad.Conc.Class (MonadConc) import Control.Monad.IO.Class (MonadIO(..)) +import Data.Either (isLeft) import Data.Function (on) -import Data.List (intercalate, intersperse) +import Data.List (intercalate, intersperse, partition) import Data.Maybe (catMaybes, isJust, isNothing, mapMaybe) import Data.Profunctor (Profunctor(..)) import System.Environment (lookupEnv) import Test.DejaFu.Conc +import Test.DejaFu.Internal import Test.DejaFu.Refinement import Test.DejaFu.SCT import Test.DejaFu.Settings @@ -314,13 +315,12 @@ -- | Automatically test a computation. -- --- In particular, look for deadlocks, uncaught exceptions, and --- multiple return values. Returns @True@ if all tests pass +-- In particular, concurrency errors and nondeterminism. Returns +-- @True@ if all tests pass -- -- >>> autocheck example --- [pass] Never Deadlocks --- [pass] No Exceptions --- [fail] Consistent Result +-- [pass] Successful +-- [fail] Deterministic -- "hello" S0----S1--S0-- -- -- "world" S0----S2--S0-- @@ -337,9 +337,8 @@ -- memory model. -- -- >>> autocheckWay defaultWay defaultMemType relaxed --- [pass] Never Deadlocks --- [pass] No Exceptions --- [fail] Consistent Result +-- [pass] Successful +-- [fail] Deterministic -- (False,True) S0---------S1----S0--S2----S0-- -- -- (False,False) S0---------S1--P2----S1--S0--- @@ -350,9 +349,8 @@ -- False -- -- >>> autocheckWay defaultWay SequentialConsistency relaxed --- [pass] Never Deadlocks --- [pass] No Exceptions --- [fail] Consistent Result +-- [pass] Successful +-- [fail] Deterministic -- (False,True) S0---------S1----S0--S2----S0-- -- -- (True,True) S0---------S1-P2----S1---S0--- @@ -374,9 +372,8 @@ -- | Variant of 'autocheck' which takes a settings record. -- -- >>> autocheckWithSettings (fromWayAndMemType defaultWay defaultMemType) relaxed --- [pass] Never Deadlocks --- [pass] No Exceptions --- [fail] Consistent Result +-- [pass] Successful +-- [fail] Deterministic -- (False,True) S0---------S1----S0--S2----S0-- -- -- (False,False) S0---------S1--P2----S1--S0--- @@ -387,9 +384,8 @@ -- False -- -- >>> autocheckWithSettings (fromWayAndMemType defaultWay SequentialConsistency) relaxed --- [pass] Never Deadlocks --- [pass] No Exceptions --- [fail] Consistent Result +-- [pass] Successful +-- [fail] Deterministic -- (False,True) S0---------S1----S0--S2----S0-- -- -- (True,True) S0---------S1-P2----S1---S0--- @@ -405,9 +401,8 @@ -- ^ The computation to test. -> n Bool autocheckWithSettings settings = dejafusWithSettings settings - [ ("Never Deadlocks", representative deadlocksNever) - , ("No Exceptions", representative exceptionsNever) - , ("Consistent Result", alwaysSame) -- already representative + [ ("Successful", representative successful) + , ("Deterministic", alwaysSame) -- already representative ] -- | Check a predicate and print the result to stdout, return 'True' @@ -830,54 +825,86 @@ exceptionsSometimes :: Predicate a exceptionsSometimes = somewhereTrue $ either isUncaughtException (const False) --- | Check that the result of a computation is always the same. In --- particular this means either: (a) it always fails in the same way, --- or (b) it never fails and the values returned are all equal. +-- | Check that a computation always gives the same, successful, +-- result. -- -- > alwaysSame = alwaysSameBy (==) -- --- @since 1.0.0.0 +-- @since 1.10.0.0 alwaysSame :: Eq a => Predicate a alwaysSame = alwaysSameBy (==) --- | Check that the result of a computation is always the same by --- comparing the result of a function on every result. +-- | Check that a computation always gives the same (according to the +-- provided function), successful, result. -- -- > alwaysSameOn = alwaysSameBy ((==) `on` f) -- --- @since 1.0.0.0 -alwaysSameOn :: Eq b => (Either Failure a -> b) -> Predicate a +-- @since 1.10.0.0 +alwaysSameOn :: Eq b => (a -> b) -> Predicate a alwaysSameOn f = alwaysSameBy ((==) `on` f) -- | Check that the result of a computation is always the same, using -- some transformation on results. -- --- @since 1.0.0.0 -alwaysSameBy :: (Either Failure a -> Either Failure a -> Bool) -> Predicate a +-- @since 1.10.0.0 +alwaysSameBy :: (a -> a -> Bool) -> Predicate a alwaysSameBy f = ProPredicate { pdiscard = const Nothing - , peval = \xs -> case simplestsBy f xs of - [] -> defaultPass - [_] -> defaultPass - xs' -> defaultFail xs' + , peval = \xs -> + let (failures, successes) = partition (isLeft . fst) xs + simpleSuccesses = simplestsBy (f `on` efromRight) successes + in case (failures, simpleSuccesses) of + ([], []) -> defaultPass + ([], [_]) -> defaultPass + (_, _) -> defaultFail (failures ++ simpleSuccesses) } --- | Check that the result of a computation is not always the same. +-- | Check that a computation never fails, and gives multiple distinct +-- successful results. -- --- @since 1.0.0.0 +-- > notAlwaysSame = notAlwaysSameBy (==) +-- +-- @since 1.10.0.0 notAlwaysSame :: Eq a => Predicate a -notAlwaysSame = ProPredicate +notAlwaysSame = notAlwaysSameBy (==) + +-- | Check that a computation never fails, and gives multiple distinct +-- (according to the provided function) successful results. +-- +-- > notAlwaysSameOn = notAlwaysSameBy ((==) `on` f) +-- +-- @since 1.10.0.0 +notAlwaysSameOn :: Eq b => (a -> b) -> Predicate a +notAlwaysSameOn f = notAlwaysSameBy ((==) `on` f) + +-- | Check that a computation never fails, and gives multiple distinct +-- successful results, by applying a transformation on results. +-- +-- This inverts the condition, so (eg) @notAlwaysSameBy (==)@ will +-- pass if there are unequal results. +-- +-- @since 1.10.0.0 +notAlwaysSameBy :: (a -> a -> Bool) -> Predicate a +notAlwaysSameBy f = ProPredicate { pdiscard = const Nothing - , peval = \case - [x] -> defaultFail [x] - xs -> go xs (defaultFail []) + , peval = \xs -> + let (failures, successes) = partition (isLeft . fst) xs + in case successes of + [x] -> defaultFail (x : failures) + _ -> + let res = go successes (defaultFail []) + in case failures of + [] -> res + _ -> res { _failures = failures ++ _failures res, _pass = False } } where + y1 .*. y2 = not (on f (efromRight . fst) y1 y2) + go [y1,y2] res - | fst y1 /= fst y2 = res { _pass = True } + | y1 .*. y2 = res { _pass = True } | otherwise = res { _failures = y1 : y2 : _failures res } go (y1:y2:ys) res - | fst y1 /= fst y2 = go (y2:ys) res { _pass = True } + | y1 .*. y2 = go (y2:ys) res { _pass = True } | otherwise = go (y2:ys) res { _failures = y1 : y2 : _failures res } go _ res = res diff --git a/Test/DejaFu/Internal.hs b/Test/DejaFu/Internal.hs --- a/Test/DejaFu/Internal.hs +++ b/Test/DejaFu/Internal.hs @@ -351,6 +351,12 @@ efromList (x:xs) = x:|xs efromList _ = withFrozenCallStack $ fatal "fromList: empty list" +-- | 'fromRight' but with a better error message if it fails. Use +-- this only where it shouldn't fail! +efromRight :: HasCallStack => Either a b -> b +efromRight (Right b) = b +efromRight _ = withFrozenCallStack $ fatal "fromRight: Left" + -- | 'M.adjust' but which errors if the key is not present. Use this -- only where it shouldn't fail! eadjust :: (Ord k, Show k, HasCallStack) => (v -> v) -> k -> M.Map k v -> M.Map k v diff --git a/dejafu.cabal b/dejafu.cabal --- a/dejafu.cabal +++ b/dejafu.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: dejafu -version: 1.9.1.0 +version: 1.10.0.0 synopsis: A library for unit-testing concurrent programs. description: @@ -33,7 +33,7 @@ source-repository this type: git location: https://github.com/barrucadu/dejafu.git - tag: dejafu-1.9.1.0 + tag: dejafu-1.10.0.0 library exposed-modules: Test.DejaFu