Give predicates discard functions

dejafu/CHANGELOG.markdown

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

dejafu/Test/DejaFu.hs

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

dejafu/Test/DejaFu/SCT.hs

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

hunit-dejafu/Test/HUnit/DejaFu.hs

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

tasty-dejafu/Test/Tasty/DejaFu.hs

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