diff --git a/hedgehog/hedgehog.cabal b/hedgehog/hedgehog.cabal index 94f96a86..ba08d489 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.State Test.Hedgehog.Text 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 f6785d2d..2654e31e 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,8 +40,8 @@ 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 (TerminationCriteria(..)) +import Hedgehog.Internal.Property (ShrinkLimit, ShrinkRetries, withSkip) +import Hedgehog.Internal.Property (TerminationCriteria(..), TestLimit(..)) import Hedgehog.Internal.Property (TestCount(..), PropertyCount(..)) import Hedgehog.Internal.Property (confidenceSuccess, confidenceFailure) import Hedgehog.Internal.Property (coverageSuccess, journalCoverage) @@ -53,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) @@ -207,12 +206,12 @@ checkReport :: MonadIO m => MonadCatch m => PropertyConfig - -> Size + -> Size -- ^ ignored, but retained for backwards compatibility -> 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 @@ -255,14 +254,16 @@ checkReport cfg size0 seed0 test0 updateUI = do loop :: TestCount -> DiscardCount - -> Size -> Seed -> Coverage CoverCount -> m (Report Result) - loop !tests !discards !size !seed !coverage0 = do + loop !tests !discards !seed !coverage0 = do updateUI $ Report tests discards coverage0 seed0 Running let + size = + calculateSize terminationCriteria tests discards + coverageReached = successVerified tests coverage0 @@ -302,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 -- @@ -337,9 +334,9 @@ checkReport cfg size0 seed0 test0 updateUI = do -- start with the one that failed. (Just (n, d), _) | n > tests + 1 -> - loop (tests + 1) discards (size + 1) s1 coverage0 + loop (tests + 1) discards s1 coverage0 | d > discards -> - loop tests (discards + 1) (size + 1) s1 coverage0 + loop tests (discards + 1) s1 coverage0 (Just _, Just shrinkPath) -> do node <- runTreeT . evalGenT size s0 . runTestT $ unPropertyT test @@ -352,7 +349,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) s1 coverage0 Just (Left _, _) -> let @@ -373,23 +370,81 @@ checkReport cfg size0 seed0 test0 updateUI = do coverage = journalCoverage journal <> coverage0 in - loop (tests + 1) discards (size + 1) s1 coverage + loop (tests + 1) discards s1 coverage - loop 0 0 size0 seed0 mempty + loop 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 could + -- reset the discard count we pass here; but we don't, because it would be + -- awkward to make that work with skipping. (We don't remember the order + -- of tests and discards.) + 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 + + -- 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 + -> Size -- ^ ignored, but retained for backwards compatibility -> Seed -> Property -> m (Report Result) -checkRegion region color name size seed prop = +checkRegion region color name _ seed prop = liftIO $ do result <- - checkReport (propertyConfig prop) size seed (propertyTest prop) $ \progress -> do + checkReport (propertyConfig prop) undefined seed (propertyTest prop) $ \progress -> do ppprogress <- renderProgress color name progress case reportStatus progress of Running -> @@ -418,7 +473,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 undefined seed prop -- | Check a property. -- @@ -428,22 +483,14 @@ 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 let prop = withSkip skip prop0 _ <- liftIO . displayRegion $ \region -> - checkRegion region color Nothing 0 seed prop + checkRegion region color Nothing undefined 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..47722897 --- /dev/null +++ b/hedgehog/test/Test/Hedgehog/Size.hs @@ -0,0 +1,93 @@ +{-# 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) + undefined + 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, 49, 73, 97]]) + (concat [ [0 .. 23] + , replicate 10 24 + , [25] + , [26 .. 99] + , [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 92881110..af815f35 100644 --- a/hedgehog/test/Test/Hedgehog/Skip.hs +++ b/hedgehog/test/Test/Hedgehog/Skip.hs @@ -26,24 +26,27 @@ 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 discards at size 1 and fails at size 2. When it --- shrinks, it initially shrinks to something that will pass, and then to --- something that will fail. +-- It ignores its seed. The second test discards (and continues to discard +-- until the size grows) and the third fails. When it shrinks, it initially +-- shrinks to something that will pass, and then to something that will fail. -- skipTestProperty :: IORef [(Size, Int, Bool, Bool)] -> Property skipTestProperty logRef = withTests 5 . property $ do - val@(curSize, _, shouldDiscard, shouldPass) <- forAll $ do + val@(testNum, _, shouldDiscard, shouldPass) <- forAll $ do + -- With 5 tests, size goes 0, 24, 48, 72, 97. + -- When we also discard at 24, it goes 0, (24 x 10), 25, 49, 73, 97. curSize <- Gen.sized pure + let testNum = curSize `div` 24 (shouldDiscard, shouldPass, nShrinks) <- (,,) - <$> pure (curSize == 1) - <*> Gen.shrink (\b -> if b then [] else [True]) (pure $ curSize /= 2) + <$> pure (curSize == 24) + <*> Gen.shrink (\b -> if b then [] else [True]) (pure $ testNum /= 2) <*> Gen.shrink (\n -> reverse [0 .. n-1]) (pure 3) - pure (curSize, nShrinks, shouldDiscard, shouldPass) + pure (testNum, nShrinks, shouldDiscard, shouldPass) -- Fail coverage to make sure we disable it when shrinking. - cover 100 "Not 4" (curSize /= 4) + cover 100 "Not 4" (testNum /= 4) liftIO $ IORef.modifyIORef' logRef (val :) when shouldDiscard discard @@ -54,7 +57,7 @@ checkProp prop = do seed <- Config.resolveSeed Nothing liftIO $ Runner.checkReport (Property.propertyConfig prop) - 0 + undefined seed (Property.propertyTest prop) (const $ pure ()) @@ -79,17 +82,20 @@ prop_SkipNothing = logs <- liftIO $ reverse <$> IORef.readIORef logRef logs === - [ (0, 3, False, True) - , (1, 3, True, True) - , (2, 3, False, False) - , (2, 3, False, True) - , (2, 2, False, False) - , (2, 2, False, True) - , (2, 1, False, False) - , (2, 1, False, True) - , (2, 0, False, False) - , (2, 0, False, True) - ] + concat + [ [ (0, 3, False, True) ] + , replicate 10 (1, 3, True, True) + , [ (1, 3, False, True) + , (2, 3, False, False) + , (2, 3, False, True) + , (2, 2, False, False) + , (2, 2, False, True) + , (2, 1, False, False) + , (2, 1, False, True) + , (2, 0, False, False) + , (2, 0, False, True) + ] + ] prop_SkipToFailingTest :: Property prop_SkipToFailingTest = @@ -105,7 +111,8 @@ prop_SkipToFailingTest = failureShrinks f === 3 failureShrinkPath f === ShrinkPath [1, 1, 1] - _ -> + _ -> do + annotateShow report failure logs <- liftIO $ reverse <$> IORef.readIORef logRef @@ -148,7 +155,8 @@ prop_SkipToNoShrink = failureShrinks f === 0 failureShrinkPath f === Property.ShrinkPath [] - _ -> + _ -> do + annotateShow report failure logs <- liftIO $ reverse <$> IORef.readIORef logRef @@ -168,7 +176,8 @@ prop_SkipToFailingShrink = failureShrinks f === 2 failureShrinkPath f === Property.ShrinkPath [1, 1] - _ -> + _ -> do + annotateShow report failure logs <- liftIO $ reverse <$> IORef.readIORef logRef @@ -215,10 +224,10 @@ prop_SkipToReportedShrink = failure1 === failure2 - reportTests report1 === 2 - reportTests report2 === 2 - reportDiscards report1 === 1 - reportDiscards report2 === 1 + reportTests report1 === 3 + reportTests report2 === 3 + reportDiscards report1 === 10 + reportDiscards report2 === 10 genSkip :: Gen Skip genSkip = diff --git a/hedgehog/test/Test/Hedgehog/State.hs b/hedgehog/test/Test/Hedgehog/State.hs index 60a0ec56..d3173ccb 100644 --- a/hedgehog/test/Test/Hedgehog/State.hs +++ b/hedgehog/test/Test/Hedgehog/State.hs @@ -82,7 +82,7 @@ prop_mkInput = -- logs. seed <- Config.resolveSeed Nothing void $ liftIO $ Runner.checkReport (Property.propertyConfig prop) - 0 + undefined seed (Property.propertyTest prop) (const $ pure ()) diff --git a/hedgehog/test/test.hs b/hedgehog/test/test.hs index f9ed19fd..b83aa7d5 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.State import qualified Test.Hedgehog.Text @@ -19,6 +20,7 @@ main = , Test.Hedgehog.Filter.tests , Test.Hedgehog.Maybe.tests , Test.Hedgehog.Seed.tests + , Test.Hedgehog.Size.tests , Test.Hedgehog.Skip.tests , Test.Hedgehog.State.tests , Test.Hedgehog.Text.tests