From 54bd3e56d3a0fbb9b51e2d409439c11f63664134 Mon Sep 17 00:00:00 2001 From: Phil Hazelden Date: Wed, 25 Jan 2023 18:13:26 +0000 Subject: [PATCH 1/2] Remove `recheck`. It's not useful with `recheckAt`, and makes fast growth more awkward to implement. This might break compatibility more than upstream wants, but at this point I've mostly given up on getting things merged there. If they do want fast growth we can figure out something. --- hedgehog/src/Hedgehog.hs | 3 +-- hedgehog/src/Hedgehog/Internal/Runner.hs | 13 ++----------- 2 files changed, 3 insertions(+), 13 deletions(-) diff --git a/hedgehog/src/Hedgehog.hs b/hedgehog/src/Hedgehog.hs index 989e797b..33354437 100644 --- a/hedgehog/src/Hedgehog.hs +++ b/hedgehog/src/Hedgehog.hs @@ -59,7 +59,6 @@ module Hedgehog ( , discard , check - , recheck , recheckAt , discover @@ -194,7 +193,7 @@ import Hedgehog.Internal.Property (Test, TestT, property, test) import Hedgehog.Internal.Property (TestLimit, withTests) import Hedgehog.Internal.Property (collect, label) import Hedgehog.Internal.Range (Range, Size(..)) -import Hedgehog.Internal.Runner (check, recheck, recheckAt, checkSequential, checkParallel) +import Hedgehog.Internal.Runner (check, recheckAt, checkSequential, checkParallel) import Hedgehog.Internal.Seed (Seed(..)) import Hedgehog.Internal.State (Command(..), Callback(..)) import Hedgehog.Internal.State (Action, Sequential(..), Parallel(..)) diff --git a/hedgehog/src/Hedgehog/Internal/Runner.hs b/hedgehog/src/Hedgehog/Internal/Runner.hs index c4b883c3..eacb5268 100644 --- a/hedgehog/src/Hedgehog/Internal/Runner.hs +++ b/hedgehog/src/Hedgehog/Internal/Runner.hs @@ -12,7 +12,6 @@ module Hedgehog.Internal.Runner ( -- * Running Individual Properties check - , recheck , recheckAt -- * Running Groups of Properties @@ -41,7 +40,7 @@ import Hedgehog.Internal.Property (Group(..), GroupName(..)) import Hedgehog.Internal.Property (Journal(..), Coverage(..), CoverCount(..)) import Hedgehog.Internal.Property (Property(..), PropertyConfig(..), PropertyName(..)) import Hedgehog.Internal.Property (PropertyT(..), Failure(..), runTestT) -import Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withTests, withSkip) +import Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withSkip) import Hedgehog.Internal.Property (TerminationCriteria(..)) import Hedgehog.Internal.Property (TestCount(..), PropertyCount(..)) import Hedgehog.Internal.Property (confidenceSuccess, confidenceFailure) @@ -425,16 +424,8 @@ check prop = do liftIO . displayRegion $ \region -> (== OK) . reportStatus <$> checkNamed region color Nothing Nothing prop --- | Check a property using a specific size and seed. +-- | Check a property using a specific seed and skip. -- -recheck :: MonadIO m => Size -> Seed -> Property -> m () -recheck size seed prop0 = do - color <- detectColor - let prop = withTests 1 prop0 - _ <- liftIO . displayRegion $ \region -> - checkRegion region color Nothing size seed prop - pure () - recheckAt :: MonadIO m => Seed -> Skip -> Property -> m () recheckAt seed skip prop0 = do color <- detectColor From 0899d8a74fadc7dbbf7748a2f2d1920680c96966 Mon Sep 17 00:00:00 2001 From: Phil Hazelden Date: Thu, 26 Jan 2023 12:54:37 +0000 Subject: [PATCH 2/2] Grow sizes faster when we run a small number of tests. Closes #472. --- hedgehog/hedgehog.cabal | 1 + hedgehog/src/Hedgehog/Internal/Runner.hs | 93 +++++++++++++++++++----- hedgehog/test/Test/Hedgehog/Size.hs | 86 ++++++++++++++++++++++ hedgehog/test/Test/Hedgehog/Skip.hs | 6 +- hedgehog/test/test.hs | 2 + 5 files changed, 165 insertions(+), 23 deletions(-) create mode 100644 hedgehog/test/Test/Hedgehog/Size.hs diff --git a/hedgehog/hedgehog.cabal b/hedgehog/hedgehog.cabal index fdc8a67f..73e061cf 100644 --- a/hedgehog/hedgehog.cabal +++ b/hedgehog/hedgehog.cabal @@ -137,6 +137,7 @@ test-suite test Test.Hedgehog.Filter Test.Hedgehog.Maybe Test.Hedgehog.Seed + Test.Hedgehog.Size Test.Hedgehog.Skip Test.Hedgehog.Text Test.Hedgehog.Zip diff --git a/hedgehog/src/Hedgehog/Internal/Runner.hs b/hedgehog/src/Hedgehog/Internal/Runner.hs index eacb5268..398e9481 100644 --- a/hedgehog/src/Hedgehog/Internal/Runner.hs +++ b/hedgehog/src/Hedgehog/Internal/Runner.hs @@ -41,7 +41,7 @@ import Hedgehog.Internal.Property (Journal(..), Coverage(..), CoverCou import Hedgehog.Internal.Property (Property(..), PropertyConfig(..), PropertyName(..)) import Hedgehog.Internal.Property (PropertyT(..), Failure(..), runTestT) import Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withSkip) -import Hedgehog.Internal.Property (TerminationCriteria(..)) +import Hedgehog.Internal.Property (TerminationCriteria(..), TestLimit(..)) import Hedgehog.Internal.Property (TestCount(..), PropertyCount(..)) import Hedgehog.Internal.Property (confidenceSuccess, confidenceFailure) import Hedgehog.Internal.Property (coverageSuccess, journalCoverage) @@ -52,7 +52,7 @@ import Hedgehog.Internal.Region import Hedgehog.Internal.Report import qualified Hedgehog.Internal.Seed as Seed import Hedgehog.Internal.Tree (TreeT(..), NodeT(..)) -import Hedgehog.Range (Size) +import Hedgehog.Range (Size(..)) import Language.Haskell.TH.Syntax (Lift) @@ -206,12 +206,11 @@ checkReport :: MonadIO m => MonadCatch m => PropertyConfig - -> Size -> Seed -> PropertyT m () -> (Report Progress -> m ()) -> m (Report Result) -checkReport cfg size0 seed0 test0 updateUI = do +checkReport cfg seed0 test0 updateUI = do skip <- liftIO $ resolveSkip $ propertySkip cfg let @@ -254,14 +253,17 @@ checkReport cfg size0 seed0 test0 updateUI = do loop :: TestCount -> DiscardCount - -> Size + -> DiscardCount -> Seed -> Coverage CoverCount -> m (Report Result) - loop !tests !discards !size !seed !coverage0 = do + loop !tests !discards !recentDiscards !seed !coverage0 = do updateUI $ Report tests discards coverage0 seed0 Running let + size = + calculateSize terminationCriteria tests recentDiscards + coverageReached = successVerified tests coverage0 @@ -301,11 +303,7 @@ checkReport cfg size0 seed0 test0 updateUI = do failureReport $ "Test coverage cannot be reached after " <> show tests <> " tests" - if size > 99 then - -- size has reached limit, reset to 0 - loop tests discards 0 seed coverage0 - - else if enoughTestsRun then + if enoughTestsRun then -- at this point, we know that enough tests have been run in order to -- make a decision on if this was a successful run or not -- @@ -335,7 +333,7 @@ checkReport cfg size0 seed0 test0 updateUI = do -- failed was 31, but we want the user to be able to skip to 32 and -- start with the one that failed. (Just n, _) | n > tests + 1 -> - loop (tests + 1) discards (size + 1) s1 coverage0 + loop (tests + 1) discards recentDiscards s1 coverage0 (Just _, Just shrinkPath) -> do node <- runTreeT . evalGenT size s0 . runTestT $ unPropertyT test @@ -348,7 +346,7 @@ checkReport cfg size0 seed0 test0 updateUI = do runTreeT . evalGenT size s0 . runTestT $ unPropertyT test case x of Nothing -> - loop tests (discards + 1) (size + 1) s1 coverage0 + loop tests (discards + 1) (recentDiscards + 1) s1 coverage0 Just (Left _, _) -> let @@ -369,23 +367,78 @@ checkReport cfg size0 seed0 test0 updateUI = do coverage = journalCoverage journal <> coverage0 in - loop (tests + 1) discards (size + 1) s1 coverage + loop (tests + 1) discards 0 s1 coverage + + loop 0 0 0 seed0 mempty + +calculateSize :: TerminationCriteria -> TestCount -> DiscardCount -> Size +calculateSize term (TestCount tests) (DiscardCount discards) = + let + growDiscards (Size n) = + -- If we're discarding a lot, try larger sizes. When we succeed, we should + -- reset the discard count we pass here. + Size $ min 99 $ n + (discards `div` 10) + + steppingSizer (TestLimit limit) = + -- `tests` runs from 0 up to `limit - 1`, so exactly `limit` tests get + -- run. Suppose `limit` is (100n + r). Then we do `n` cycles where size + -- goes 0,1,...,99, and then for the final `r` tests, we try to increase + -- from 0 to 99 in equal increments. So if `r` is 10 we go 0,11,22,...,99. + -- + -- If we can't reach 99 we get as close as we can in equal increments + -- without going over, and if `r` is 1 we just run the final test at size + -- 0. + -- + -- More examples: + -- r == 2: 0, 99 + -- r == 3: 0, 49, 98 + -- r == 4: 0, 33, 66, 99 + -- r == 5: 0, 24, 48, 72, 96 + + let + (fullCycles, leftOvers) = limit `divMod` 100 + (cyclesCompleted, cyclePos) = tests `divMod` 100 + in + if tests >= limit then + error "test count is higher than limit" + else if cyclesCompleted < fullCycles then + Size cyclePos + else + -- leftOvers must be >= 1, or one of the previous branches would have + -- run. + if leftOvers == 1 then + Size 0 + else + let step = 99 `div` (leftOvers - 1) + in Size $ cyclePos * step + in + growDiscards $ case term of + -- Run exactly `limit` tests. + NoConfidenceTermination limit -> + steppingSizer limit + + -- Run exactly `limit` tests, but also use a confidence threshold for + -- coverage. + NoEarlyTermination _ limit -> + steppingSizer limit - loop 0 0 size0 seed0 mempty + -- Run some multiple of 100 tests. The TestLimit is ignored. That's likely + -- a bug elsewhere, but it makes this bit easy. + EarlyTermination _ _ -> + Size $ tests `mod` 100 checkRegion :: MonadIO m => Region -> UseColor -> Maybe PropertyName - -> Size -> Seed -> Property -> m (Report Result) -checkRegion region color name size seed prop = +checkRegion region color name size prop = liftIO $ do result <- - checkReport (propertyConfig prop) size seed (propertyTest prop) $ \progress -> do + checkReport (propertyConfig prop) size (propertyTest prop) $ \progress -> do ppprogress <- renderProgress color name progress case reportStatus progress of Running -> @@ -414,7 +467,7 @@ checkNamed :: -> m (Report Result) checkNamed region color name mseed prop = do seed <- resolveSeed mseed - checkRegion region color name 0 seed prop + checkRegion region color name seed prop -- | Check a property. -- @@ -431,7 +484,7 @@ recheckAt seed skip prop0 = do color <- detectColor let prop = withSkip skip prop0 _ <- liftIO . displayRegion $ \region -> - checkRegion region color Nothing 0 seed prop + checkRegion region color Nothing seed prop pure () -- | Check a group of properties using the specified runner config. diff --git a/hedgehog/test/Test/Hedgehog/Size.hs b/hedgehog/test/Test/Hedgehog/Size.hs new file mode 100644 index 00000000..afb9e621 --- /dev/null +++ b/hedgehog/test/Test/Hedgehog/Size.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Test.Hedgehog.Size where + +import Control.Monad ( void, when ) +import Control.Monad.IO.Class ( MonadIO(..) ) + +import Data.Foldable ( for_ ) +import qualified Data.IORef as IORef + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Internal.Config as Config +import qualified Hedgehog.Internal.Property as Property +import Hedgehog.Internal.Report ( Report(..) + , Result(..) + ) +import qualified Hedgehog.Internal.Runner as Runner + +checkProp :: MonadIO m => Property -> m (Report Result) +checkProp prop = do + seed <- Config.resolveSeed Nothing + liftIO $ Runner.checkReport (Property.propertyConfig prop) + seed + (Property.propertyTest prop) + (const $ pure ()) + +checkGrowth :: + MonadIO m => (Property -> Property) -> [Size] -> m [Size] +checkGrowth applyTerminationCriteria discardOn = do + logRef <- liftIO $ IORef.newIORef [] + + void $ checkProp $ applyTerminationCriteria $ property $ do + curSize <- forAll $ Gen.sized pure + liftIO $ IORef.modifyIORef' logRef (curSize :) + when (curSize `elem` discardOn) discard + + liftIO $ reverse <$> IORef.readIORef logRef + +data GrowthTest = + GrowthTest + TestLimit -- ^ number of tests to run + [Size] -- ^ which sizes should be discarded + [Size] -- ^ the expected sizes run at (including ones discarded) for + -- NoConfidenceTermination and NoEarlyTermination + [Size] -- ^ the expected sizes run at (including ones discarded) for + -- EarlyTermination + +growthTests :: [GrowthTest] +growthTests = + [ GrowthTest 1 [] [0] [0 .. 99] + , GrowthTest 5 [] [0, 24 .. 96] [0 .. 99] + , GrowthTest 10 [] [0, 11 .. 99] [0 .. 99] + , GrowthTest 101 [] ([0 .. 99] ++ [0]) [0 .. 99] + , GrowthTest 105 [] ([0 .. 99] ++ [0, 24 .. 96]) [0 .. 99] + , GrowthTest 5 [24] (concat [[0], replicate 10 24, [25, 48, 72, 96]]) + (concat [[0 .. 23], replicate 10 24, [25], [25 .. 99]]) + , let discards = concat [ replicate 10 96 + , replicate 10 97 + , replicate 10 98 + , replicate 70 99 -- discard limit is 100 + ] + in GrowthTest 5 [96 .. 99] ([0, 24 .. 72] ++ discards) + ([0 .. 95] ++ discards) + ] + +prop_GrowthTest :: Property +prop_GrowthTest = + withTests 1 . property $ do + for_ growthTests $ + \(GrowthTest testLimit discardOn expected1 expected2) -> do + let noConfidenceTerm = withTests testLimit + sizes1 <- checkGrowth noConfidenceTerm discardOn + sizes1 === expected1 + + let noEarlyTerm = withConfidence 1000 . noConfidenceTerm + sizes2 <- checkGrowth noEarlyTerm discardOn + sizes2 === expected1 + + let earlyTerm = verifiedTermination . noEarlyTerm + sizes3 <- checkGrowth earlyTerm discardOn + sizes3 === expected2 + +tests :: IO Bool +tests = + checkParallel $$(discover) diff --git a/hedgehog/test/Test/Hedgehog/Skip.hs b/hedgehog/test/Test/Hedgehog/Skip.hs index a8ef3957..3681e097 100644 --- a/hedgehog/test/Test/Hedgehog/Skip.hs +++ b/hedgehog/test/Test/Hedgehog/Skip.hs @@ -25,14 +25,15 @@ import Hedgehog.Internal.Report (Report(..), Result(..), FailureReport -- | We use this property to help test skipping. It keeps a log of every time it -- runs in the 'IORef' it's passed. -- --- It ignores its seed. It fails at size 2. When it shrinks, it initially +-- It ignores its seed. The third test fails. When it shrinks, it initially -- shrinks to something that will pass, and then to something that will fail. -- skipTestProperty :: IORef [(Size, Int, Bool)] -> Property skipTestProperty logRef = withTests 5 . property $ do val@(curSize, _, shouldPass) <- forAll $ do - curSize <- Gen.sized pure + -- With 5 tests, size goes 0, 24, 48, 72, 96. + curSize <- Gen.sized $ pure . (`div` 24) (shouldPass, nShrinks) <- (,) <$> Gen.shrink (\b -> if b then [] else [True]) (pure $ curSize /= 2) @@ -50,7 +51,6 @@ checkProp prop = do seed <- Config.resolveSeed Nothing liftIO $ Runner.checkReport (Property.propertyConfig prop) - 0 seed (Property.propertyTest prop) (const $ pure ()) diff --git a/hedgehog/test/test.hs b/hedgehog/test/test.hs index 43ee3bff..ea95411d 100644 --- a/hedgehog/test/test.hs +++ b/hedgehog/test/test.hs @@ -5,6 +5,7 @@ import qualified Test.Hedgehog.Confidence import qualified Test.Hedgehog.Filter import qualified Test.Hedgehog.Maybe import qualified Test.Hedgehog.Seed +import qualified Test.Hedgehog.Size import qualified Test.Hedgehog.Skip import qualified Test.Hedgehog.Text import qualified Test.Hedgehog.Zip @@ -18,6 +19,7 @@ main = , Test.Hedgehog.Filter.tests , Test.Hedgehog.Maybe.tests , Test.Hedgehog.Seed.tests + , Test.Hedgehog.Size.tests , Test.Hedgehog.Skip.tests , Test.Hedgehog.Text.tests , Test.Hedgehog.Zip.tests