mirror of
https://github.com/barrucadu/dejafu.git
synced 2024-11-05 06:45:08 +03:00
Give predicates discard functions
This commit is contained in:
parent
6eaae0a589
commit
db95dde7df
@ -24,10 +24,11 @@ This project is versioned according to the [Package Versioning Policy](https://p
|
||||
`dejafuDiscardIO`, `runTestM`, and `runTestWayM` functions are now gone.
|
||||
|
||||
- The `Predicate` type has been replaced with a more general `ProPredicate` type which is a
|
||||
profunctor. (#124)
|
||||
profunctor and (b) can discard results not needed to determine if the predicate passes. (#124)
|
||||
|
||||
All testing functions have been generalised to take a `ProPredicate` instead. The `Predicate a`
|
||||
type remains as an alias for `ProPredicate a a`.
|
||||
type remains as an alias for `ProPredicate a a`. Passing tests have their resident memory usage
|
||||
significantly decreased.
|
||||
|
||||
### Test.DejaFu.Common
|
||||
|
||||
@ -53,6 +54,8 @@ This project is versioned according to the [Package Versioning Policy](https://p
|
||||
|
||||
It is no longer possible to test things in `ST`.
|
||||
|
||||
- New functions `strengthenDiscard` and `weakenDiscard` to combine discard functions.
|
||||
|
||||
### Miscellaneous
|
||||
|
||||
- The minimum supported version of concurrency is now 1.3.0.0.
|
||||
|
@ -286,6 +286,7 @@ import Control.Monad.IO.Class (MonadIO(..))
|
||||
import Control.Monad.Ref (MonadRef)
|
||||
import Data.Function (on)
|
||||
import Data.List (intercalate, intersperse, minimumBy)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Ord (comparing)
|
||||
import Data.Profunctor (Profunctor(..))
|
||||
|
||||
@ -387,7 +388,8 @@ dejafuDiscard :: (MonadConc n, MonadIO n, MonadRef r n, Show b)
|
||||
-- ^ The predicate (with a name) to check
|
||||
-> n Bool
|
||||
dejafuDiscard discard way memtype conc (name, test) = do
|
||||
traces <- runSCTDiscard discard way memtype conc
|
||||
let discarder = strengthenDiscard discard (pdiscard test)
|
||||
traces <- runSCTDiscard discarder way memtype conc
|
||||
liftIO $ doTest name (peval test traces)
|
||||
|
||||
-- | Variant of 'dejafu' which takes a collection of predicates to
|
||||
@ -417,10 +419,25 @@ dejafusWay :: (MonadConc n, MonadIO n, MonadRef r n, Show b)
|
||||
-- ^ The list of predicates (with names) to check
|
||||
-> n Bool
|
||||
dejafusWay way memtype conc tests = do
|
||||
traces <- runSCT way memtype conc
|
||||
results <- mapM (\(name, test) -> liftIO . doTest name $ peval test traces) tests
|
||||
pure (and results)
|
||||
traces <- runSCTDiscard discarder way memtype conc
|
||||
results <- mapM (\(name, test) -> liftIO . doTest name $ check test traces) tests
|
||||
pure (and results)
|
||||
where
|
||||
discarder = foldr
|
||||
(weakenDiscard . pdiscard . snd)
|
||||
(const (Just DiscardResultAndTrace))
|
||||
tests
|
||||
|
||||
-- for evaluating each individual predicate, we only want the
|
||||
-- results/traces it would not discard, but the traces set may
|
||||
-- include more than this if the different predicates have
|
||||
-- different discard functions, so we do another pass of
|
||||
-- discarding.
|
||||
check p = peval p . mapMaybe go where
|
||||
go r@(efa, _) = case pdiscard p efa of
|
||||
Just DiscardResultAndTrace -> Nothing
|
||||
Just DiscardTrace -> Just (efa, [])
|
||||
Nothing -> Just r
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Test cases
|
||||
@ -488,8 +505,8 @@ runTestWay :: (MonadConc n, MonadRef r n)
|
||||
-> ConcT r n a
|
||||
-- ^ The computation to test
|
||||
-> n (Result b)
|
||||
runTestWay way memtype predicate conc =
|
||||
peval predicate <$> runSCT way memtype conc
|
||||
runTestWay way memtype p conc =
|
||||
peval p <$> runSCTDiscard (pdiscard p) way memtype conc
|
||||
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
@ -508,14 +525,17 @@ type Predicate a = ProPredicate a a
|
||||
-- into a 'Result', possibly discarding some on the way.
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
newtype ProPredicate a b = ProPredicate
|
||||
{ peval :: [(Either Failure a, Trace)] -> Result b
|
||||
data ProPredicate a b = ProPredicate
|
||||
{ pdiscard :: Either Failure a -> Maybe Discard
|
||||
-- ^ Selectively discard results before computing the result.
|
||||
, peval :: [(Either Failure a, Trace)] -> Result b
|
||||
-- ^ Compute the result with the un-discarded results.
|
||||
}
|
||||
|
||||
instance Profunctor ProPredicate where
|
||||
dimap f g p = ProPredicate
|
||||
{ peval = fmap g . peval p . map (first (fmap f))
|
||||
{ pdiscard = pdiscard p . fmap f
|
||||
, peval = fmap g . peval p . map (first (fmap f))
|
||||
}
|
||||
|
||||
instance Functor (ProPredicate x) where
|
||||
@ -617,7 +637,8 @@ alwaysSame = representative $ alwaysTrue2 (==)
|
||||
-- @since 1.0.0.0
|
||||
notAlwaysSame :: Eq a => Predicate a
|
||||
notAlwaysSame = ProPredicate
|
||||
{ peval = \case
|
||||
{ pdiscard = const Nothing
|
||||
, peval = \case
|
||||
[x] -> defaultFail [x]
|
||||
xs -> go xs (defaultFail [])
|
||||
}
|
||||
@ -636,7 +657,8 @@ notAlwaysSame = ProPredicate
|
||||
-- @since 1.0.0.0
|
||||
alwaysTrue :: (Either Failure a -> Bool) -> Predicate a
|
||||
alwaysTrue p = ProPredicate
|
||||
{ peval = \xs -> go xs $ (defaultFail (failures xs)) { _pass = True }
|
||||
{ pdiscard = \efa -> if p efa then Just DiscardResultAndTrace else Nothing
|
||||
, peval = \xs -> go xs $ (defaultFail (failures xs)) { _pass = True }
|
||||
}
|
||||
where
|
||||
go (y:ys) res
|
||||
@ -656,7 +678,8 @@ alwaysTrue p = ProPredicate
|
||||
-- @since 1.0.0.0
|
||||
alwaysTrue2 :: (Either Failure a -> Either Failure a -> Bool) -> Predicate a
|
||||
alwaysTrue2 p = ProPredicate
|
||||
{ peval = \case
|
||||
{ pdiscard = const Nothing
|
||||
, peval = \case
|
||||
[_] -> defaultPass
|
||||
xs -> go xs $ defaultPass { _failures = failures xs }
|
||||
}
|
||||
@ -686,7 +709,8 @@ alwaysTrue2 p = ProPredicate
|
||||
-- @since 1.0.0.0
|
||||
somewhereTrue :: (Either Failure a -> Bool) -> Predicate a
|
||||
somewhereTrue p = ProPredicate
|
||||
{ peval = \xs -> go xs $ defaultFail (failures xs)
|
||||
{ pdiscard = \efa -> if p efa then Just DiscardTrace else Nothing
|
||||
, peval = \xs -> go xs $ defaultFail (failures xs)
|
||||
}
|
||||
where
|
||||
go (y:ys) res
|
||||
@ -702,7 +726,8 @@ somewhereTrue p = ProPredicate
|
||||
-- @since 1.0.0.0
|
||||
gives :: (Eq a, Show a) => [Either Failure a] -> Predicate a
|
||||
gives expected = ProPredicate
|
||||
{ peval = \xs -> go expected [] xs $ defaultFail (failures xs)
|
||||
{ pdiscard = \efa -> if efa `elem` expected then Just DiscardTrace else Nothing
|
||||
, peval = \xs -> go expected [] xs $ defaultFail (failures xs)
|
||||
}
|
||||
where
|
||||
go waitingFor alreadySeen ((x, _):xs) res
|
||||
|
@ -25,6 +25,8 @@ module Test.DejaFu.SCT
|
||||
, Discard(..)
|
||||
, runSCTDiscard
|
||||
, resultsSetDiscard
|
||||
, weakenDiscard
|
||||
, strengthenDiscard
|
||||
|
||||
-- ** Strict variants
|
||||
, runSCT'
|
||||
@ -248,6 +250,42 @@ data Discard
|
||||
instance NFData Discard where
|
||||
rnf d = d `seq` ()
|
||||
|
||||
-- | Combine two discard values, keeping the weaker.
|
||||
--
|
||||
-- @Nothing@ is weaker than @Just DiscardTrace@, which is weaker than
|
||||
-- @Just DiscardResultAndTrace@. This forms a commutative monoid
|
||||
-- where the unit is @const (Just DiscardResultAndTrace)@.
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
weakenDiscard ::
|
||||
(Either Failure a -> Maybe Discard)
|
||||
-> (Either Failure a -> Maybe Discard)
|
||||
-> Either Failure a -> Maybe Discard
|
||||
weakenDiscard d1 d2 efa = case (d1 efa, d2 efa) of
|
||||
(Nothing, _) -> Nothing
|
||||
(_, Nothing) -> Nothing
|
||||
(Just DiscardTrace, _) -> Just DiscardTrace
|
||||
(_, Just DiscardTrace) -> Just DiscardTrace
|
||||
_ -> Just DiscardResultAndTrace
|
||||
|
||||
-- | Combine two discard functions, keeping the stronger.
|
||||
--
|
||||
-- @Just DiscardResultAndTrace@ is stronger than @Just DiscardTrace@,
|
||||
-- which is stronger than @Nothing@. This forms a commutative monoid
|
||||
-- where the unit is @const Nothing@.
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
strengthenDiscard ::
|
||||
(Either Failure a -> Maybe Discard)
|
||||
-> (Either Failure a -> Maybe Discard)
|
||||
-> Either Failure a -> Maybe Discard
|
||||
strengthenDiscard d1 d2 efa = case (d1 efa, d2 efa) of
|
||||
(Just DiscardResultAndTrace, _) -> Just DiscardResultAndTrace
|
||||
(_, Just DiscardResultAndTrace) -> Just DiscardResultAndTrace
|
||||
(Just DiscardTrace, _) -> Just DiscardTrace
|
||||
(_, Just DiscardTrace) -> Just DiscardTrace
|
||||
_ -> Nothing
|
||||
|
||||
-- | A variant of 'runSCT' which can selectively discard results.
|
||||
--
|
||||
-- @since 1.0.0.0
|
||||
|
@ -88,7 +88,7 @@ instance Testable (Conc.ConcIO ()) where
|
||||
-- | @since 0.3.0.0
|
||||
instance Assertable (Conc.ConcIO ()) where
|
||||
assert conc = do
|
||||
traces <- SCT.runSCTDiscard (const Nothing) defaultWay defaultMemType (try conc)
|
||||
traces <- SCT.runSCTDiscard (pdiscard assertableP) defaultWay defaultMemType (try conc)
|
||||
assertString . showErr $ peval assertableP traces
|
||||
|
||||
assertableP :: Predicate (Either HUnitFailure ())
|
||||
@ -265,11 +265,8 @@ testconc discard way memtype concio tests = case map toTest tests of
|
||||
|
||||
where
|
||||
toTest (name, p) = TestLabel name . TestCase $ do
|
||||
-- Sharing of traces probably not possible (without something
|
||||
-- really unsafe) here, as 'test' doesn't allow side-effects
|
||||
-- (eg, constructing an 'MVar' to share the traces after one
|
||||
-- test computed them).
|
||||
traces <- SCT.runSCTDiscard discard way memtype concio
|
||||
let discarder = SCT.strengthenDiscard discard (pdiscard p)
|
||||
traces <- SCT.runSCTDiscard discarder way memtype concio
|
||||
assertString . showErr $ peval p traces
|
||||
|
||||
-- | Produce a HUnit 'Test' from a Deja Fu refinement property test.
|
||||
|
@ -94,8 +94,8 @@ instance IsTest (Conc.ConcIO (Maybe String)) where
|
||||
run options conc callback = do
|
||||
let memtype = lookupOption options
|
||||
let way = lookupOption options
|
||||
let traces = SCT.runSCTDiscard (const Nothing) way memtype conc
|
||||
run options (ConcTest traces assertableP) callback
|
||||
let traces = SCT.runSCTDiscard (pdiscard assertableP) way memtype conc
|
||||
run options (ConcTest traces (peval assertableP)) callback
|
||||
|
||||
concOptions :: [OptionDescription]
|
||||
concOptions =
|
||||
@ -284,7 +284,7 @@ testPropertyFor = testprop
|
||||
-- Tasty integration
|
||||
|
||||
data ConcTest where
|
||||
ConcTest :: Show b => IO [(Either Failure a, Conc.Trace)] -> ProPredicate a b -> ConcTest
|
||||
ConcTest :: Show b => IO [(Either Failure a, Conc.Trace)] -> ([(Either Failure a, Conc.Trace)] -> Result b) -> ConcTest
|
||||
deriving Typeable
|
||||
|
||||
data PropTest where
|
||||
@ -296,7 +296,7 @@ instance IsTest ConcTest where
|
||||
|
||||
run _ (ConcTest iotraces p) _ = do
|
||||
traces <- iotraces
|
||||
let err = showErr $ peval p traces
|
||||
let err = showErr $ p traces
|
||||
pure (if null err then testPassed "" else testFailed err)
|
||||
|
||||
instance IsTest PropTest where
|
||||
@ -327,11 +327,10 @@ testconc discard way memtype concio tests = case map toTest tests of
|
||||
ts -> testGroup "Deja Fu Tests" ts
|
||||
|
||||
where
|
||||
toTest (name, p) = singleTest name $ ConcTest traces p
|
||||
|
||||
-- As with HUnit, constructing a test is side-effect free, so
|
||||
-- sharing of traces can't happen here.
|
||||
traces = SCT.runSCTDiscard discard way memtype concio
|
||||
toTest (name, p) =
|
||||
let discarder = SCT.strengthenDiscard discard (pdiscard p)
|
||||
traces = SCT.runSCTDiscard discarder way memtype concio
|
||||
in singleTest name $ ConcTest traces (peval p)
|
||||
|
||||
-- | Produce a Tasty 'TestTree' from a Deja Fu refinement property test.
|
||||
testprop :: (R.Testable p, R.Listable (R.X p), Eq (R.X p), Show (R.X p), Show (R.O p))
|
||||
|
Loading…
Reference in New Issue
Block a user