Add shrink timeout

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]:

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

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)

hedgehog/src/Hedgehog/Internal/Property.hs

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

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,46 +123,75 @@ 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 =
-  let
-    loop shrinks revShrinkPath = \case
-      NodeT Nothing _ ->
-        pure GaveUp
-
-      NodeT (Just (x, (Journal logs))) xs ->
-        case x of
-          Left (Failure loc err mdiff) -> do
-            let
-              shrinkPath =
-                ShrinkPath $ reverse revShrinkPath
-              failure =
-                mkFailure shrinks shrinkPath Nothing loc err mdiff (reverse logs)
-
-            updateUI $ Shrinking failure
+takeSmallest shrinks0 (ShrinkPath shrinkPath0) slimit mstimeoutMicros retries updateUI =
+  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
+
+  where
+    runLoop ::
+      (Result -> m ()) -- ^ Update result function.
+      -> NodeT m (Maybe (Either Failure (), Journal))
+      -> m Result
+    runLoop updateResultSoFar = loop shrinks0 (reverse shrinkPath0)
+      where
+        loop ::
+          ShrinkCount
+          -> [Int]
+          -> NodeT m (Maybe (Either Failure (), Journal))
+          -> m Result
+        loop shrinks revShrinkPath = \case
+          NodeT Nothing _ ->
+            pure GaveUp
 
-            if shrinks >= fromIntegral slimit then
-              -- if we've hit the shrink limit, don't shrink any further
-              pure $ Failed failure
-            else
-              findM (zip [0..] xs) (Failed failure) $ \(n, m) -> do
-                o <- runTreeN retries m
-                if isFailure o then
-                  Just <$> loop (shrinks + 1) (n : revShrinkPath) o
+          NodeT (Just (x, (Journal logs))) xs ->
+            case x of
+              Left (Failure loc err mdiff) -> do
+                let
+                  shrinkPath =
+                    ShrinkPath $ reverse revShrinkPath
+                  failure =
+                    mkFailure shrinks shrinkPath Nothing loc err mdiff (reverse logs)
+
+                updateResultSoFar (Failed failure)
+                updateUI $ Shrinking failure
+
+                if shrinks >= fromIntegral slimit then
+                  -- if we've hit the shrink limit, don't shrink any further
+                  pure $ Failed failure
                 else
-                  return Nothing
+                  findM (zip [0..] xs) (Failed failure) $ \(n, m) -> do
+                    o <- runTreeN retries m
+                    if isFailure o then
+                      Just <$> loop (shrinks + 1) (n : revShrinkPath) o
+                    else
+                      return Nothing
 
-          Right () ->
-            return OK
-  in
-    loop shrinks0 (reverse shrinkPath0)
+              Right () ->
+                return OK
 
 -- | 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 +238,9 @@ skipToShrink (ShrinkPath shrinkPath) updateUI =
 
 checkReport ::
      forall m.
-     MonadIO m
+   ( MonadBaseControl IO m
+   , MonadIO m
+   )
   => MonadCatch m
   => PropertyConfig
   -> Size
@@ -364,6 +400,7 @@ checkReport cfg size0 seed0 test0 updateUI = do
                         0
                         (ShrinkPath [])
                         (propertyShrinkLimit cfg)
+                        (propertyShrinkTimeoutMicros cfg)
                         (propertyShrinkRetries cfg)
                         (updateUI . mkReport)
                         node
@@ -597,3 +634,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 <&>