From 8419e268a90fee2a6329e91037cfa5f5ab6db5c5 Mon Sep 17 00:00:00 2001 From: Tommy Bidne Date: Tue, 23 May 2023 15:29:36 +1200 Subject: [PATCH] Add shrink time limit Add withShrinkTime to allow configuring shrink behavior in terms of time. --- hedgehog/hedgehog.cabal | 1 + hedgehog/src/Hedgehog.hs | 4 + hedgehog/src/Hedgehog/Internal/Property.hs | 25 ++++ hedgehog/src/Hedgehog/Internal/Runner.hs | 59 ++++++++- hedgehog/test/Test/Hedgehog/Shrink.hs | 143 +++++++++++++++++++++ hedgehog/test/test.hs | 2 + 6 files changed, 227 insertions(+), 7 deletions(-) create mode 100644 hedgehog/test/Test/Hedgehog/Shrink.hs diff --git a/hedgehog/hedgehog.cabal b/hedgehog/hedgehog.cabal index 4bb66eef..b330def2 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.Shrink Test.Hedgehog.Skip Test.Hedgehog.Text Test.Hedgehog.Zip diff --git a/hedgehog/src/Hedgehog.hs b/hedgehog/src/Hedgehog.hs index 989e797b..817e8682 100644 --- a/hedgehog/src/Hedgehog.hs +++ b/hedgehog/src/Hedgehog.hs @@ -80,6 +80,9 @@ module Hedgehog ( , withShrinks , ShrinkLimit + , withShrinkTime + , ShrinkTimeLimit + , withRetries , ShrinkRetries @@ -188,6 +191,7 @@ import Hedgehog.Internal.Property (Property, PropertyT, PropertyName) import Hedgehog.Internal.Property (Group(..), GroupName) import Hedgehog.Internal.Property (Confidence, verifiedTermination, withConfidence) import Hedgehog.Internal.Property (ShrinkLimit, withShrinks) +import Hedgehog.Internal.Property (ShrinkTimeLimit, withShrinkTime) import Hedgehog.Internal.Property (ShrinkRetries, withRetries) import Hedgehog.Internal.Property (Skip, withSkip) import Hedgehog.Internal.Property (Test, TestT, property, test) diff --git a/hedgehog/src/Hedgehog/Internal/Property.hs b/hedgehog/src/Hedgehog/Internal/Property.hs index c901550d..1c0ef657 100644 --- a/hedgehog/src/Hedgehog/Internal/Property.hs +++ b/hedgehog/src/Hedgehog/Internal/Property.hs @@ -33,6 +33,7 @@ module Hedgehog.Internal.Property ( , DiscardLimit(..) , DiscardCount(..) , ShrinkLimit(..) + , ShrinkTimeLimit (..) , ShrinkCount(..) , Skip(..) , ShrinkPath(..) @@ -40,6 +41,7 @@ module Hedgehog.Internal.Property ( , withTests , withDiscards , withShrinks + , withShrinkTime , withRetries , withSkip , property @@ -281,6 +283,7 @@ data PropertyConfig = PropertyConfig { propertyDiscardLimit :: !DiscardLimit , propertyShrinkLimit :: !ShrinkLimit + , propertyShrinkTimeLimit :: !(Maybe ShrinkTimeLimit) , propertyShrinkRetries :: !ShrinkRetries , propertyTerminationCriteria :: !TerminationCriteria @@ -339,6 +342,19 @@ newtype ShrinkLimit = ShrinkLimit Int deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift) +-- | The time limit before giving up on shrinking, in microseconds. +-- +-- Can be constructed using numeric literals: +-- +-- @ +-- -- 1_000_000 microseconds == 1 second +-- 1_000_000 :: ShrinkTimeLimit +-- @ +-- +newtype ShrinkTimeLimit = + ShrinkTimeLimit Int + deriving (Eq, Ord, Show, Num, Enum, Real, Integral, Lift) + -- | The numbers of times a property was able to shrink after a failing test. -- newtype ShrinkCount = @@ -1164,6 +1180,8 @@ defaultConfig = 100 , propertyShrinkLimit = 1000 + , propertyShrinkTimeLimit = + Nothing , propertyShrinkRetries = 0 , propertyTerminationCriteria = @@ -1248,6 +1266,13 @@ withShrinks :: ShrinkLimit -> Property -> Property withShrinks n = mapConfig $ \config -> config { propertyShrinkLimit = n } +-- | Set the time -- in microseconds -- a property is allowed to shrink before +-- the test runner gives up and prints the counterexample. +-- +withShrinkTime :: ShrinkTimeLimit -> Property -> Property +withShrinkTime n = + mapConfig $ \config -> config { propertyShrinkTimeLimit = Just n } + -- | Set the number of times a property will be executed for each shrink before -- the test runner gives up and tries a different shrink. See 'ShrinkRetries' -- for more information. diff --git a/hedgehog/src/Hedgehog/Internal/Runner.hs b/hedgehog/src/Hedgehog/Internal/Runner.hs index c4b883c3..dc19b2cf 100644 --- a/hedgehog/src/Hedgehog/Internal/Runner.hs +++ b/hedgehog/src/Hedgehog/Internal/Runner.hs @@ -3,6 +3,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -31,7 +32,10 @@ import Control.Concurrent.STM (TVar, atomically) import qualified Control.Concurrent.STM.TVar as TVar import Control.Exception.Safe (MonadCatch, catchAny) import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans.Control (MonadBaseControl (..)) +import Data.IORef (newIORef, readIORef, writeIORef) import Data.Maybe (isJust) +import qualified System.Timeout as T import Hedgehog.Internal.Config import Hedgehog.Internal.Gen (evalGenT) @@ -42,6 +46,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, withTests, withSkip) +import Hedgehog.Internal.Property (ShrinkTimeLimit (..)) import Hedgehog.Internal.Property (TerminationCriteria(..)) import Hedgehog.Internal.Property (TestCount(..), PropertyCount(..)) import Hedgehog.Internal.Property (confidenceSuccess, confidenceFailure) @@ -118,17 +123,27 @@ runTreeN n m = do pure o takeSmallest :: - MonadIO m + forall m. + ( MonadBaseControl IO m + , MonadIO m + ) => ShrinkCount -> ShrinkPath -> ShrinkLimit + -> Maybe ShrinkTimeLimit -> ShrinkRetries -> (Progress -> m ()) -> NodeT m (Maybe (Either Failure (), Journal)) -> m Result -takeSmallest shrinks0 (ShrinkPath shrinkPath0) slimit retries updateUI = +takeSmallest shrinks0 (ShrinkPath shrinkPath0) slimit mstimeLimit retries updateUI = let - loop shrinks revShrinkPath = \case + loop :: + ShrinkCount + -> [Int] + -> (Result -> m ()) + -> NodeT m (Maybe (Either Failure (), Journal)) + -> m Result + loop shrinks revShrinkPath updateResultSoFar = \case NodeT Nothing _ -> pure GaveUp @@ -141,6 +156,7 @@ takeSmallest shrinks0 (ShrinkPath shrinkPath0) slimit retries updateUI = failure = mkFailure shrinks shrinkPath Nothing loc err mdiff (reverse logs) + updateResultSoFar (Failed failure) updateUI $ Shrinking failure if shrinks >= fromIntegral slimit then @@ -150,14 +166,27 @@ takeSmallest shrinks0 (ShrinkPath shrinkPath0) slimit retries updateUI = findM (zip [0..] xs) (Failed failure) $ \(n, m) -> do o <- runTreeN retries m if isFailure o then - Just <$> loop (shrinks + 1) (n : revShrinkPath) o + Just <$> loop (shrinks + 1) (n : revShrinkPath) updateResultSoFar o else return Nothing Right () -> return OK - in - loop shrinks0 (reverse shrinkPath0) + runLoop = loop shrinks0 (reverse shrinkPath0) + in case mstimeLimit of + -- no time limit, shrink normally + Nothing -> runLoop (const (pure ())) + -- run the loop in the timeout + Just (ShrinkTimeLimit timeLimit) -> \nodeT -> do + resultSoFar <- liftIO $ newIORef Nothing + let updateResultSoFar = liftIO . writeIORef resultSoFar . Just + timeout timeLimit (runLoop updateResultSoFar nodeT) >>= \case + -- timed out, return preliminary result if it exists + Nothing -> liftIO (readIORef resultSoFar) <&> \case + Nothing -> GaveUp + Just r -> r + -- did not time out, return result + Just r -> pure r -- | Follow a given shrink path, instead of searching exhaustively. Assume that -- the end of the path is minimal, and don't try to shrink any further than @@ -204,7 +233,9 @@ skipToShrink (ShrinkPath shrinkPath) updateUI = checkReport :: forall m. - MonadIO m + ( MonadBaseControl IO m + , MonadIO m + ) => MonadCatch m => PropertyConfig -> Size @@ -361,6 +392,7 @@ checkReport cfg size0 seed0 test0 updateUI = do 0 (ShrinkPath []) (propertyShrinkLimit cfg) + (propertyShrinkTimeLimit cfg) (propertyShrinkRetries cfg) (updateUI . mkReport) node @@ -594,3 +626,16 @@ checkParallel = , runnerVerbosity = Nothing } + +-- vendored from lifted-base +timeout :: MonadBaseControl IO m => Int -> m a -> m (Maybe a) +timeout t m = + liftBaseWith (\runInIO -> T.timeout t (runInIO m)) >>= + maybe (pure Nothing) (fmap Just . restoreM) + +-- vendored from base's Data.Functor until base < 4.11.0.0 is dropped +-- (ghc 8.4.1) +(<&>) :: Functor f => f a -> (a -> b) -> f b +as <&> f = f <$> as + +infixl 1 <&> \ No newline at end of file diff --git a/hedgehog/test/Test/Hedgehog/Shrink.hs b/hedgehog/test/Test/Hedgehog/Shrink.hs new file mode 100644 index 00000000..b955a9d0 --- /dev/null +++ b/hedgehog/test/Test/Hedgehog/Shrink.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Test.Hedgehog.Shrink where + +import qualified Control.Concurrent as CC +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO(..)) +import Data.IORef (IORef) +import qualified Data.IORef as IORef + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import qualified Hedgehog.Internal.Config as Config +import qualified Hedgehog.Internal.Property as Property +import qualified Hedgehog.Internal.Runner as Runner +import Hedgehog.Internal.Report (FailureReport(..), FailedAnnotation (..)) +import Hedgehog.Internal.Report (Report(..), Result(..)) + +-- No limit fully shrinks (18) +prop_ShrinkNoLimit :: Property +prop_ShrinkNoLimit = + withTests 1 . property $ do + (report, gens) <- checkModProp id + [50, 0, 25, 13, 7, 4, 6, 5] === gens + case reportStatus report of + Failed f -> failureShrinks f === 5 + _ -> failure + +-- Shrinks 3 times +prop_ShrinkLimit :: Property +prop_ShrinkLimit = + withTests 1 . property $ do + (report, gens) <- checkModProp (withShrinks 3) + [50, 0, 25, 13, 7] === gens + case reportStatus report of + Failed f -> failureShrinks f === 3 + _ -> failure + +-- Time limit of 0 i.e. does not shrink at all +prop_ShrinkTimeLimitZero :: Property +prop_ShrinkTimeLimitZero = + withTests 1 . property $ do + (report, gens) <- checkModProp (withShrinkTime 0) + [50] === gens + case reportStatus report of + GaveUp -> pure () + _ -> failure + +-- Time limit of 1,000,000 microseconds = 1 s. Verifies that we get a +-- "partial" shrink. +-- +-- There is tension in the shrinkTime. On the one hand, we want it long enough +-- so that we generate the four values [50, 0, 25, 13] before it gets stuck +-- on 13. We don't want it too long, though, because that makes the test +-- slower. +-- +-- Experience shows that values under 1 second would cause an occasional CI +-- failure (the machine would not generate all four values before the timeout). +-- A timeout of 1 second, on the other hand, passed CI with 10,000 tests +-- (and took 7 hours!). Thus we use the 1 second timeout as it seems robust +-- enough to not cause CI failures, and we cap the tests at 1 to keep the +-- running time fast. +prop_ShrinkTimeLimit :: Property +prop_ShrinkTimeLimit = + withTests 1 . property $ do + -- Test generates [ 50 , 0 , 25 , 13 , 7 , 4 , 6 , 5 ] + -- The 1 s timeout combined with the 10 s delay on 13 means + -- shrinking will get stuck on 13, hence: + -- - only generate [50 , 0 , 25 , 13] + -- - final shrink value is 25 + (report, gens) <- checkModPropGen delay (withShrinkTime shrinkTime) + [50 , 0 , 25 , 13] === gens + case reportStatus report of + Failed f -> do + 1 === failureShrinks f + case failureAnnotations f of + [ann] -> "25" === failedValue ann + _ -> failure + _ -> failure + where + delay x = when (x == 13) (liftIO $ CC.threadDelay delayTime) + shrinkTime = 1000000 -- 1 sec + -- Does not matter what this is, as long as it is longer than shrinkTime + delayTime = 10000000 -- 10 sec + +-- Given a property modifier, returns the property's report and generated +-- values. +checkModProp :: + ( MonadIO m + , MonadTest m + ) + => -- property modifier + (Property -> Property) + -> m (Report Result, [Int]) +checkModProp = checkModPropGen (const (pure ())) + +-- checkModProp with function to run on the generated values +checkModPropGen :: + ( MonadIO m + , MonadTest m + ) + => -- function to run on generated values + (Int -> PropertyT IO ()) + -- property modifier + -> (Property -> Property) + -> m (Report Result, [Int]) +checkModPropGen onGen md = do + gensRef <- liftIO $ IORef.newIORef [] + report <- checkProp $ modProp onGen gensRef md + gens <- liftIO $ reverse <$> IORef.readIORef gensRef + annotateShow report + annotateShow gens + pure (report, gens) + +modProp :: + -- function to run on generated values + (Int -> PropertyT IO ()) + -- reference to hold generated values + -> IORef [Int] + -- property modifier + -> (Property -> Property) + -> Property +modProp onGen gensRef md = withTests 1 . md . property $ do + -- [ 50 , 0 , 25 , 13 , 7 , 4 , 6 , 5 ] + x :: Int <- forAll $ Gen.integral (Range.linearFrom 0 50 100) + liftIO $ IORef.modifyIORef' gensRef (x :) + onGen x + diff x (<) 5 + +checkProp :: MonadIO m => Property -> m (Report Result) +checkProp prop = do + seed <- Config.resolveSeed Nothing + liftIO $ Runner.checkReport + (Property.propertyConfig prop) + 0 + seed + (Property.propertyTest prop) + (const $ pure ()) + +tests :: IO Bool +tests = checkParallel $$(discover) \ No newline at end of file diff --git a/hedgehog/test/test.hs b/hedgehog/test/test.hs index 43ee3bff..a1ebadb0 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.Shrink 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.Shrink.tests , Test.Hedgehog.Skip.tests , Test.Hedgehog.Text.tests , Test.Hedgehog.Zip.tests