From 58a65120a598e473baef15263dac9b9c6659aaaa 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 | 53 +++++++++++++--- hedgehog/test/Test/Hedgehog/Shrink.hs | 73 ++++++++++++++++++++++ hedgehog/test/test.hs | 2 + 6 files changed, 151 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..0a8b1eb2 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,11 @@ 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.Functor ((<&>)) +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 +47,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 +124,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 +157,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 +167,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 +234,9 @@ skipToShrink (ShrinkPath shrinkPath) updateUI = checkReport :: forall m. - MonadIO m + ( MonadBaseControl IO m + , MonadIO m + ) => MonadCatch m => PropertyConfig -> Size @@ -361,6 +393,7 @@ checkReport cfg size0 seed0 test0 updateUI = do 0 (ShrinkPath []) (propertyShrinkLimit cfg) + (propertyShrinkTimeLimit cfg) (propertyShrinkRetries cfg) (updateUI . mkReport) node @@ -594,3 +627,9 @@ 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) \ 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..877f6984 --- /dev/null +++ b/hedgehog/test/Test/Hedgehog/Shrink.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Test.Hedgehog.Shrink where + +import Control.Monad.IO.Class (MonadIO(..)) + +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 (Report(..), Result(..), FailureReport(..)) + +modProp :: (Property -> Property) -> Property +modProp md = withTests 1 . md . property $ do + x :: Int <- forAll $ Gen.integral (Range.linearFrom 0 500000 1000000) + 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 ()) + +-- No limit fully shrinks (18) +prop_ShrinkNoLimit :: Property +prop_ShrinkNoLimit = + property $ do + report <- checkProp $ modProp id + case reportStatus report of + Failed f -> failureShrinks f === 18 + _ -> failure + +-- Shrinks 3 times +prop_ShrinkLimit :: Property +prop_ShrinkLimit = + property $ do + report <- checkProp $ modProp (withShrinks 3) + 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 = + property $ do + report <- checkProp $ modProp (withShrinkTime 0) + case reportStatus report of + GaveUp -> pure () + _ -> failure + +-- Time limit of 1 microsecond. Non-deterministic, can shrink s times w/ +-- 0 <= s <= 18. +prop_ShrinkTimeLimit :: Property +prop_ShrinkTimeLimit = + property $ do + report <- checkProp $ modProp (withShrinkTime 1) + case reportStatus report of + Failed f -> do + let shrinks = failureShrinks f + diff shrinks (>=) 0 + diff shrinks (<=) 18 + GaveUp -> pure () + _ -> failure + +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