Give predicates discard functions

This commit is contained in:
Michael Walker 2017-11-08 10:53:21 +00:00
parent 6eaae0a589
commit db95dde7df
5 changed files with 93 additions and 31 deletions

View File

@ -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.

View File

@ -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

View File

@ -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

View File

@ -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.

View File

@ -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))