Add shrink timeout

[tbidne]

Resolves #476.

There are some design decisions to make, so this is intended more to jumpstart the conversation than it is to present a finished implementation. Some notes:

1. I chose to add a new field, ShrinkTimeLimit :: Int independent of the current ShrinkLimit :: Int. This way is backwards compatible, and it allows one to specify both a total number of shrinks and a time limit. That said, it is arguable that combining these choices into a single option makes for a friendlier interface as e.g. someone might specify a time limit of 30s only to be unexpectedly thwarted by the default ShrinkLimit of 1,000.
2. Bikeshedding: ShrinkTimeLimit could also be named ShrinkTimeout.
3. The field is Int microseconds to make interop with timeout simpler, though I could imagine choosing something less implementation-derived, say, seconds (and maybe a different type e.g. Natural).
4. In case of a timeout, we want to present the latest shrink, so I modified the shrink loop to take in an "update" parameter that saves the current result in an IORef iff ShrinkTimeLimit is set. If ShrinkTimeLimit is not set then the "update" logic is const (pure ()). I mention this in case it can affect performance, as an alternative would be to have two totally different loops, at the cost of code reuse.
5. I added some tests, though the timeout test is naturally pretty weak as it is non-deterministic. If anyone has ideas here, I'm all ears.

Thanks!

[ChickenProp]

Not a maintainer myself, but I think this is neat!

More name bikeshedding: I'd suggest adding "micros" (e.g. withShrinkTimeMicros, ShrinkTimeLimitMicros) to make it clear what the units are.

I added some tests, though the timeout test is naturally pretty weak as it is non-deterministic. If anyone has ideas here, I'm all ears.

Given a known shrink tree, you could have a test deliberately hang on a given input, e.g. a timeout of 100 microseconds and hang for 200 after five shrinks.

[TysonMN]

My two cents:

I like the naming format xInUnits. In this case, the name would be withShrinkTimeInMicroseconds. I admit that the name can get a bit long though.

[tbidne]

@ChickenProp Given a known shrink tree, you could have a test deliberately hang on a given input, e.g. a timeout of 100 microseconds and hang for 200 after five shrinks.

Thanks for the idea! I added such a test here. I made the timeout longer (1 second) as lower values would often cause at least one ci job to fail (usually MacOS on an older GHC), due to the test timing out before it reached the generated values I specifically wanted it to get stuck on.

I also had a "sanity-check" style test that verified the timeout indeed cancels shrinking in the expected wall-clock time.

-- Time limit of 2 seconds. Verifies that withShrinkTime indeed cancels
-- shrinking within the time limit we want.
prop_ShrinkTimeLimitClock :: Property
prop_ShrinkTimeLimitClock =
  property $ do
    startTime <- liftIO $ Clock.getMonotonicTime
    annotateShow startTime
    _ <- checkModPropGen delay30s (withShrinkTime 2000000)
    endTime <- liftIO $ Clock.getMonotonicTime
    annotateShow endTime
    let timeElapsed = endTime - startTime
    annotateShow timeElapsed
    -- should be around 2
    diff timeElapsed (>=) 1.5
    diff timeElapsed (<=) 2.5
  where
    delay30s x = when (x == 13) (liftIO $ CC.threadDelay 30000000)

Unfortunately this relies on GHC.Clock, which requires a newer GHC (8.4.1) than the oldest on CI (8.0.2). I suppose I could conditionally add it with cpp, or maybe this test isn't so important anyway.

@TysonMN

As far as the name goes, I agree adding the units is a good idea. Yet ShrinkTimeInMicroseconds is a bit grim, considering the corresponding functions/fields e.g. propertyShrinkTimeInMicroseconds. Perhaps ShrinkTimeoutMicros? I am fine with either InMicro... vs. Micro..., but I think Microseconds should probably be abbreviated (Micro, Micros, Microsec), and ShrinkTimeout sounds a little better to me than ShrinkTimeLimit.

[tbidne]

Also it is probably a good idea to mention withShrinks in the documentation for withShrinkTime e.g.

-- | 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
-- (defaults to 1,000). See 'withShrinks'.
--
withShrinkTime :: ShrinkTimeLimit -> Property -> Property

[tbidne]

I went ahead and made those changes:

• Renamed ShrinkTimeLimit --> ShrinkTimeoutMicros.
• Added wall clock test w/ cpp.

[moodmosaic]

@tbidne, can I re-review this?

[tbidne]

@moodmosaic Please do, thanks!

[HuwCampbell]

I'm not a maintainer on the Haskell package, but it looks ok to me apart from a few small things.

The style guide is pretty clear on its preference for let over where (and I left a few other comments).

I'm not sure the behaviour with small timeouts is correct. It should report the failure case which started the search instead of GaveUp if a smaller failing case can't be found within the time limit.

Timing based tests are always a bit finicky – maybe add something to the examples instead?

---

Having thought about this a bit more; I think that the current type for takeSmallest and loop is actually bad, and if that gets fixed first it'll improve things markedly.

The "tell" is isFailure and Just (Left _, _). We're throwing away information (validating, not parsing).

There's also weirdness around its returns. It can't return GaveUp or Ok in practice; but that's not reflected in its type.

Thus: I think the shrink should be:

takeSmallest ::
     MonadIO m
  => ShrinkCount
  -> ShrinkPath
  -> ShrinkLimit
  -> ShrinkRetries
  -> (FailureReport -> m ())
  -> Failure
  -> Journal
  -> [TreeT m (Maybe (Either Failure (), Journal))]
  -> m FailureReport
takeSmallest shrinks0 (ShrinkPath shrinkPath0) slimit retries updateUI =
  let
    loop shrinks revShrinkPath (Failure loc err mdiff) (Journal logs) xs = do
      let
        shrinkPath =
          ShrinkPath $ reverse revShrinkPath
        failure =
          mkFailure shrinks shrinkPath Nothing loc err mdiff (reverse logs)

      updateUI failure

      if shrinks >= fromIntegral slimit then
        -- if we've hit the shrink limit, don't shrink any further
        pure failure
      else
        findM (zip [0..] xs) (failure) $ \(n, m) -> do
          o <- runTreeN retries m
          case o of
            NodeT (Just (Left smallerFailure, smallerLogs)) children ->
              Just <$>
                loop (shrinks + 1) (n : revShrinkPath) smallerFailure smallerLogs children
            _ ->
              return Nothing

  in
    loop shrinks0 (reverse shrinkPath0)

Ok. Back to the PR at hand, if you use that type, then things get a bit simpler, as you have "on hand" the starting position and won't return GaveUp.

There's also the question of multiple return paths, the IORef, and the returned value. If they're always in sync, why have both?

[moodmosaic]

Thanks @HuwCampbell 👍 Agreed!

@tbidne could you address the above? It LGTM once the comments are addressed. Thank you! 🙏

[tbidne]

Apologies for the delay.

I have rebased the PR via @HuwCampbell's excellent suggestion. The first commit is purely the suggested refactor, which passes the test suite locally.

The second commit is my changes, and indeed the refactor makes this significantly simpler. I also added the other requested changes e.g. let vs. where and moving the tests to examples. It may therefore be easier to review the commits individually.

I am curious what others think! It occurs to me that I could also add @since tags, assuming the next version is 1.8 (this will require a major version change).