From ccd7e07ce163d61c13affaecf82ac14c760f03d0 Mon Sep 17 00:00:00 2001 From: Tommy Bidne Date: Thu, 25 Jul 2024 15:24:37 +1200 Subject: [PATCH] Add shrink timeout Add withShrinkTimeoutMicros to allow configuring shrink behavior in terms of a timeout. --- CHANGELOG.md | 8 + hedgehog/hedgehog.cabal | 1 + hedgehog/src/Hedgehog.hs | 4 + hedgehog/src/Hedgehog/Internal/Property.hs | 27 ++++ hedgehog/src/Hedgehog/Internal/Runner.hs | 59 ++++++- hedgehog/test/Test/Hedgehog/Shrink.hs | 171 +++++++++++++++++++++ hedgehog/test/test.hs | 2 + 7 files changed, 265 insertions(+), 7 deletions(-) create mode 100644 hedgehog/test/Test/Hedgehog/Shrink.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 18902097..9ec38057 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,7 @@ +## Unreleased + +* Add `Hedgehog.withShrinkTimeoutMicros` ([#488][488], [@tbidne][tbidne]) + ## Version 1.6 (2024-08-27) * Add callstacks to generators that can error ([#538][538], [@ChickenProp][ChickenProp]) @@ -320,6 +324,8 @@ https://github.com/jchia [Vekhir]: https://github.com/Vekhir +[tbidne]: + https://github.com/tbidne [538]: https://github.com/hedgehogqa/haskell-hedgehog/pull/538 @@ -365,6 +371,8 @@ https://github.com/hedgehogqa/haskell-hedgehog/pull/489 [486]: https://github.com/hedgehogqa/haskell-hedgehog/pull/486 +[488]: + https://github.com/hedgehogqa/haskell-hedgehog/pull/488 [485]: https://github.com/hedgehogqa/haskell-hedgehog/pull/485 [482]: diff --git a/hedgehog/hedgehog.cabal b/hedgehog/hedgehog.cabal index 942bc1cd..3f07af82 100644 --- a/hedgehog/hedgehog.cabal +++ b/hedgehog/hedgehog.cabal @@ -136,6 +136,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..d34bfbc0 100644 --- a/hedgehog/src/Hedgehog.hs +++ b/hedgehog/src/Hedgehog.hs @@ -80,6 +80,9 @@ module Hedgehog ( , withShrinks , ShrinkLimit + , withShrinkTimeoutMicros + , ShrinkTimeoutMicros + , 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 (ShrinkTimeoutMicros, withShrinkTimeoutMicros) 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 f4a2ca68..a25db1c5 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(..) + , ShrinkTimeoutMicros (..) , ShrinkCount(..) , Skip(..) , ShrinkPath(..) @@ -40,6 +41,7 @@ module Hedgehog.Internal.Property ( , withTests , withDiscards , withShrinks + , withShrinkTimeoutMicros , withRetries , withSkip , property @@ -281,6 +283,7 @@ data PropertyConfig = PropertyConfig { propertyDiscardLimit :: !DiscardLimit , propertyShrinkLimit :: !ShrinkLimit + , propertyShrinkTimeoutMicros :: !(Maybe ShrinkTimeoutMicros) , propertyShrinkRetries :: !ShrinkRetries , propertyTerminationCriteria :: !TerminationCriteria @@ -343,6 +346,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 :: ShrinkTimeoutMicros +-- @ +-- +newtype ShrinkTimeoutMicros = + ShrinkTimeoutMicros 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 = @@ -1183,6 +1199,8 @@ defaultConfig = 100 , propertyShrinkLimit = 1000 + , propertyShrinkTimeoutMicros = + Nothing , propertyShrinkRetries = 0 , propertyTerminationCriteria = @@ -1267,6 +1285,15 @@ withShrinks :: ShrinkLimit -> Property -> Property withShrinks n = mapConfig $ \config -> config { propertyShrinkLimit = n } +-- | Set the timeout -- in microseconds -- after which the test runner gives +-- up on shrinking and prints the best counterexample. Note that shrinking +-- can be cancelled before the timeout if the 'ShrinkLimit' is reached. +-- See 'withShrinks'. +-- +withShrinkTimeoutMicros :: ShrinkTimeoutMicros -> Property -> Property +withShrinkTimeoutMicros n = + mapConfig $ \config -> config { propertyShrinkTimeoutMicros = 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 929c9dc7..2e5a15f7 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 (ShrinkTimeoutMicros (..)) 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 ShrinkTimeoutMicros -> ShrinkRetries -> (Progress -> m ()) -> NodeT m (Maybe (Either Failure (), Journal)) -> m Result -takeSmallest shrinks0 (ShrinkPath shrinkPath0) slimit retries updateUI = +takeSmallest shrinks0 (ShrinkPath shrinkPath0) slimit mstimeoutMicros 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 mstimeoutMicros of + -- no timeout, shrink normally + Nothing -> runLoop (const (pure ())) + -- run the loop in the timeout + Just (ShrinkTimeoutMicros timeoutMicros) -> \nodeT -> do + resultSoFar <- liftIO $ newIORef Nothing + let updateResultSoFar = liftIO . writeIORef resultSoFar . Just + timeout timeoutMicros (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 @@ -364,6 +395,7 @@ checkReport cfg size0 seed0 test0 updateUI = do 0 (ShrinkPath []) (propertyShrinkLimit cfg) + (propertyShrinkTimeoutMicros cfg) (propertyShrinkRetries cfg) (updateUI . mkReport) node @@ -597,3 +629,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 <&> diff --git a/hedgehog/test/Test/Hedgehog/Shrink.hs b/hedgehog/test/Test/Hedgehog/Shrink.hs new file mode 100644 index 00000000..0482d34d --- /dev/null +++ b/hedgehog/test/Test/Hedgehog/Shrink.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE CPP #-} +{-# 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 +#if MIN_VERSION_base(4,11,0) +import qualified GHC.Clock as Clock +#endif + +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 (5) +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 + +-- Timeout of 0 i.e. does not shrink at all +prop_ShrinkTimeoutMicrosZero :: Property +prop_ShrinkTimeoutMicrosZero = + withTests 1 . property $ do + (report, gens) <- checkModProp (withShrinkTimeoutMicros 0) + [50] === gens + case reportStatus report of + GaveUp -> pure () + _ -> failure + +-- Timeout 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_ShrinkTimeoutMicros :: Property +prop_ShrinkTimeoutMicros = + 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 (withShrinkTimeoutMicros 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 + +-- Timeout of 2 seconds. Verifies that withShrinkTimeoutMicros indeed cancels +-- shrinking within the time limit we want. +prop_ShrinkTimeoutMicrosClock :: Property +#if MIN_VERSION_base(4,11,0) +prop_ShrinkTimeoutMicrosClock = + withTests 1 . property $ do + startTime <- liftIO $ Clock.getMonotonicTime + annotateShow startTime + _ <- checkModPropGen delay30s (withShrinkTimeoutMicros 2000000) + endTime <- liftIO $ Clock.getMonotonicTime + annotateShow endTime + let timeElapsed = endTime - startTime + annotateShow timeElapsed + -- should be around 2 + diff timeElapsed (>=) 1.5 + diff timeElapsed (<=) 2.5 + where + delay30s x = when (x == 13) (liftIO $ CC.threadDelay 30000000) +#else +-- Needed because auto test discovery via $$(discover) picks up +-- prop_ShrinkTimeoutMicrosClock name before cpp is evaluated. +prop_ShrinkTimeoutMicrosClock = property (pure ()) +#endif + +-- 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) 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