Skip to content

Commit

Permalink
Add shrink time limit
Browse files Browse the repository at this point in the history
Add withShrinkTime to allow configuring shrink behavior in terms
of time.
  • Loading branch information
tbidne committed May 23, 2023
1 parent ad75bea commit 620ca5f
Show file tree
Hide file tree
Showing 6 changed files with 157 additions and 7 deletions.
1 change: 1 addition & 0 deletions hedgehog/hedgehog.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
4 changes: 4 additions & 0 deletions hedgehog/src/Hedgehog.hs
Original file line number Diff line number Diff line change
Expand Up @@ -80,6 +80,9 @@ module Hedgehog (
, withShrinks
, ShrinkLimit

, withShrinkTime
, ShrinkTimeLimit

, withRetries
, ShrinkRetries

Expand Down Expand Up @@ -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)
Expand Down
25 changes: 25 additions & 0 deletions hedgehog/src/Hedgehog/Internal/Property.hs
Original file line number Diff line number Diff line change
Expand Up @@ -33,13 +33,15 @@ module Hedgehog.Internal.Property (
, DiscardLimit(..)
, DiscardCount(..)
, ShrinkLimit(..)
, ShrinkTimeLimit (..)
, ShrinkCount(..)
, Skip(..)
, ShrinkPath(..)
, ShrinkRetries(..)
, withTests
, withDiscards
, withShrinks
, withShrinkTime
, withRetries
, withSkip
, property
Expand Down Expand Up @@ -281,6 +283,7 @@ data PropertyConfig =
PropertyConfig {
propertyDiscardLimit :: !DiscardLimit
, propertyShrinkLimit :: !ShrinkLimit
, propertyShrinkTimeLimit :: !(Maybe ShrinkTimeLimit)
, propertyShrinkRetries :: !ShrinkRetries
, propertyTerminationCriteria :: !TerminationCriteria

Expand Down Expand Up @@ -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 =
Expand Down Expand Up @@ -1164,6 +1180,8 @@ defaultConfig =
100
, propertyShrinkLimit =
1000
, propertyShrinkTimeLimit =
Nothing
, propertyShrinkRetries =
0
, propertyTerminationCriteria =
Expand Down Expand Up @@ -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.
Expand Down
59 changes: 52 additions & 7 deletions hedgehog/src/Hedgehog/Internal/Runner.hs
Original file line number Diff line number Diff line change
Expand Up @@ -3,6 +3,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE DoAndIfThenElse #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoImplicitPrelude #-}
Expand Down Expand Up @@ -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)
Expand All @@ -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)
Expand Down Expand Up @@ -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

Expand All @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -204,7 +233,9 @@ skipToShrink (ShrinkPath shrinkPath) updateUI =

checkReport ::
forall m.
MonadIO m
( MonadBaseControl IO m
, MonadIO m
)
=> MonadCatch m
=> PropertyConfig
-> Size
Expand Down Expand Up @@ -361,6 +392,7 @@ checkReport cfg size0 seed0 test0 updateUI = do
0
(ShrinkPath [])
(propertyShrinkLimit cfg)
(propertyShrinkTimeLimit cfg)
(propertyShrinkRetries cfg)
(updateUI . mkReport)
node
Expand Down Expand Up @@ -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 <&>
73 changes: 73 additions & 0 deletions hedgehog/test/Test/Hedgehog/Shrink.hs
Original file line number Diff line number Diff line change
@@ -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)
2 changes: 2 additions & 0 deletions hedgehog/test/test.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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
Expand Down

0 comments on commit 620ca5f

Please sign in to comment.