Applying Gen.filter to Gen.sequential can cause shrinking to spin

[ChickenProp]

This might only happen if there's an infinite shrink loop, I'm not sure. I haven't found one in the actual code I'm working on, but I can't yet rule out that it exists. Even given that there's an infinite shrink, the example code isn't working how I expect, but I might be misunderstanding.

I discovered this while working on the same set of tests as for #448. As there, I have a "setup" command and a "validate" command. The setup is only valid once, and the validate is only valid after setup. So all generated action sequences will be "setup" followed by 0 or more "validate"s.

Shrinking was generating a lot of sequences that were just a single setup, and I decided I wasn't interested in testing those over and over. So I added a filter to only test sequences of length > 1. And that caused it to hang.

The minimal example code is very similar to the other issue, except for adding

Gen.filter ((1 <) . length . sequentialActions) $

before the Gen.sequential. But I've included a very slightly simplified version of it here, that doesn't depend on Var.

import           Control.Monad.Trans            ( liftIO )
import           Data.Kind                      ( Type )
import           Hedgehog
import qualified Hedgehog.Gen                  as Gen
import qualified Hedgehog.Range                as Range
import qualified Test.Hspec                    as Hspec
import           Test.Hspec.Hedgehog            ( hedgehog )

spec :: Hspec.Spec
spec = Hspec.it "Example" $ hedgehog $ do
  actions <-
    forAll $ Gen.filter ((1 <) . length . sequentialActions) $ Gen.sequential
      (Range.linear 1 100)
      (SMState Nothing)
      [setup, validate]
  liftIO $ putStrLn "---"
  executeSequential (SMState Nothing) actions

newtype SMState (v :: Type -> Type) = SMState (Maybe ())
  deriving stock (Eq, Show)

newtype InputSetup (v :: Type -> Type) = InputSetup Bool
  deriving stock Show
instance HTraversable InputSetup where
  htraverse _ (InputSetup a) = pure $ InputSetup a

setup :: Command Gen (PropertyT IO) SMState
setup = Command gen exec callbacks where
  gen (SMState (Just _)) = Nothing
  gen (SMState Nothing) =
    Just $ InputSetup <$> Gen.shrink (const [False]) (pure True)

  exec (InputSetup x) = liftIO $ putStrLn $ "setup: " ++ show x

  callbacks = [Update updateState]
  updateState _ _ _ = SMState $ Just ()

newtype InputValidate (v :: Type -> Type) = InputValidate ()
  deriving stock Show
instance HTraversable InputValidate where
  htraverse _ (InputValidate a) = pure $ InputValidate a

validate :: Command Gen (PropertyT IO) SMState
validate = Command gen exec callbacks where
  gen (SMState (Just v)) = Just $ pure $ InputValidate v
  gen (SMState Nothing ) = Nothing

  exec (InputValidate x) = liftIO $ putStrLn $ "validate: " ++ show x

  callbacks = [Ensure postCondition]
  postCondition _ _ _ _ = fail "validate always fails"

What I'd expect here is that it runs [Setup True, Validate ()], which fails. Then it runs through all possible shrinks of that, discarding [Setup True] and [Validate ()] because they have length 1, testing [Setup False, Validate ()] which fails, shrinking again, getting back to [Setup False, Validate ()] and looping like that.

What actually happens is that it spins, eating up my CPU and memory until I kill it. The output is simply

SMExample
---
setup: True
validate: ()

If I remove the shrink, it behaves as I'd expect; the only shrinks of the initial sequence have length 1, so it just runs that one test and then fails.

If I remove the filter and add a Requires check that the state is Just, it also behaves as I'd expect: getting into a loop of [Setup False, Validate ()], [], [Setup False], [Setup False, Validate ()], ...

---
setup: False
validate: ()
---
---
setup: False
---
setup: False
validate: ()

But I don't understand why it hangs when I have both the filter and the shrink, with or without the Requires.

I can get the filter to work if I replace it with

mapGenT (filterT $ (1 <) . length . sequentialActions)

using Hedgehog.Internal.{Gen,Tree}. If I do that, I get an infinite loop of constantly checking [Setup False, Validate ()]. This still eats memory and CPU, but I at least understand why.

[ChickenProp]

Quick update: I've now tried my actual codebase many times with mapGenT/filterT, and haven't yet hit an infinite shrink loop. It's conceivable I just haven't run into it (the same seed gives different values compared to filter), but I think it's most likely that the spinning here can show up without an infinite shrink loop.

(Edit: but that can sometimes apparently cause me to get GaveUp, where if I remove it all tests pass. I don't know what's going on there.)