Add shrink timeout

Add withShrinkTimeoutMicros to allow configuring shrink behavior in
terms of a timeout.

Author: tbidne

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
 
+  , 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
 
@@ -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 :: 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 =
@@ -1164,6 +1180,8 @@ defaultConfig =
         100
     , propertyShrinkLimit =
         1000
+    , propertyShrinkTimeoutMicros =
+        Nothing
     , propertyShrinkRetries =
         0
     , propertyTerminationCriteria =
@@ -1248,6 +1266,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.
@@ -1491,4 +1518,4 @@ collect x =
 --
 -- These functions are exported in case you need them in a pinch, but are not
 -- part of the public API and may change at any time, even as part of a minor
--- update.
+-- update.

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 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 +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 mstimeLimit of
+       -- no time limit, shrink normally
+       Nothing -> runLoop (const (pure ()))
+       -- run the loop in the timeout
+       Just (ShrinkTimeoutMicros 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 +233,9 @@ skipToShrink (ShrinkPath shrinkPath) updateUI =
 
 checkReport ::
      forall m.
-     MonadIO m
+   ( MonadBaseControl IO m
+   , MonadIO m
+   )
   => MonadCatch m
   => PropertyConfig
   -> Size
@@ -361,6 +392,7 @@ checkReport cfg size0 seed0 test0 updateUI = do
                         0
                         (ShrinkPath [])
                         (propertyShrinkLimit cfg)
+                        (propertyShrinkTimeoutMicros cfg)
                         (propertyShrinkRetries cfg)
                         (updateUI . mkReport)
                         node
@@ -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 <&>