Add shrink time limit

Add withShrinkTime to allow configuring shrink behavior in terms
of time.

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

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)

hedgehog/src/Hedgehog/Internal/Property.hs

@@ -33,13 +33,15 @@ module Hedgehog.Internal.Property (
   , DiscardLimit(..)
   , DiscardCount(..)
   , ShrinkLimit(..)
+  , ShrinkTimeLimit (..)
   , ShrinkCount(..)
   , Skip(..)
   , ShrinkPath(..)
   , ShrinkRetries(..)
   , 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.

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)

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)

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