Extract non-discarding implies QuickCheck utility

IntersectMBO · May 3, 2024 · 214db42 · 214db42
1 parent f25ea0b
commit 214db42
Show file tree

Hide file tree

Showing 3 changed files with 9 additions and 4 deletions.
diff --git a/...usion/changelog.d/20240425_110304_alexander.esgen_customize_prefer_candidate.md b/...usion/changelog.d/20240425_110304_alexander.esgen_customize_prefer_candidate.md
diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/General.hs
@@ -74,6 +74,7 @@ import           Test.Util.HardFork.Future (Future)
 import           Test.Util.Orphans.Arbitrary ()
 import           Test.Util.Orphans.IOLike ()
 import           Test.Util.Orphans.NoThunks ()
+import           Test.Util.QuickCheck
 import           Test.Util.Range
 import           Test.Util.Shrink (andId, dropId)
 import           Test.Util.Slots (NumSlots (..))
@@ -674,10 +675,6 @@ prop_general_internal syncity pga testOutput =
                 | ((s1, _, max1), (s2, min2, _)) <- orderedPairs extrema
                 ]
       where
-        -- QuickCheck's @==>@ 'discard's the test if @p1@ fails; that's not
-        -- what we want
-        implies p1 p2 = not p1 .||. p2
-
         -- all pairs @(x, y)@ where @x@ precedes @y@ in the given list
         orderedPairs :: [a] -> [(a, a)]
         orderedPairs = \case

diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/QuickCheck.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/QuickCheck.hs
@@ -28,6 +28,7 @@ module Test.Util.QuickCheck (
     -- * Convenience
   , collects
   , forAllGenRunShrinkCheck
+  , implies
   ) where
 
 import           Control.Monad.Except
@@ -218,3 +219,10 @@ shrinkNP g f np = npToSListI np $ cshrinkNP (Proxy @Top) g f np
 
 collects :: Show a => [a] -> Property -> Property
 collects = repeatedly collect
+
+-- | QuickCheck's '==>' 'discard's the test if @p1@ fails; this is sometimes not
+-- what we want, for example if we have other properties that do not depend on
+-- @p1@ being true.
+implies :: Testable prop => Bool -> prop -> Property
+implies p1 p2 = not p1 .||. p2
+infixr 0 `implies`