Idiomatic way to shrink a record in QuickCheck

Question

Suppose I have a record type:

data Foo = Foo {x, y, z :: Integer}

A neat way of writing an Arbitrary instance uses Control.Applicative like this:

instance Arbitrary Foo where
   arbitrary = Foo <$> arbitrary <*> arbitrary <*> arbitrary
   shrink f = Foo <$> shrink (x f) <*> shrink (y f) <*> shrink (z f)

The list of shrinks for a Foo is thus the cartesian product of all the shrinks of its members.

But if one of these shrinks returns [ ] then there will be no shrinks for the Foo as a whole. So this doesn't work.

I could try saving it by including the original value in the shrink list:

   shrink f = Foo <$> ((x f) : shrink (x f)) <*> ... {and so on}.

But now shrink (Foo 0 0 0) will return [Foo 0 0 0], which means that shrinking will never terminate. So that doesn't work either.

It looks like there should be something other than <*> being used here, but I can't see what.

Answer 1

I don't know what would be considered idiomatic, but if you want to ensure that every shrinking reduces at least one field without increasing the others,

shrink f = tail $ Foo <$> shrink' (x f) <*> shrink' (y f) <*> shrink' (z f)
  where
    shrink' a = a : shrink a

would do that. The Applicative instance for lists is such that the original value is the first in the result list, so just dropping that gets you a list of values really shrunk, hence shrinking terminates.

If you want all fields shrunk if possible, and only unshrinkable fields to be retained as is, it is a bit more complicated, you need to communicate whether you have already gotten a successful shrink or not, and in case you haven't gotten any at the end, return an empty list. What fell off the top of my head is

data Fallback a
    = Fallback a
    | Many [a]

unFall :: Fallback a -> [a]
unFall (Fallback _) = []
unFall (Many xs)    = xs

fall :: a -> [a] -> Fallback a
fall u [] = Fallback u
fall _ xs = Many xs

instance Functor Fallback where
    fmap f (Fallback u) = Fallback (f u)
    fmap f (Many xs)    = Many (map f xs)

instance Applicative Fallback where
    pure u = Many [u]
    (Fallback f) <*> (Fallback u) = Fallback (f u)
    (Fallback f) <*> (Many xs)    = Many (map f xs)
    (Many fs)    <*> (Fallback u) = Many (map ($ u) fs)
    (Many fs)    <*> (Many xs)    = Many (fs <*> xs)

instance Arbitrary Foo where
    arbitrary = Foo <$> arbitrary <*> arbitrary <*> arbitrary
    shrink f = unFall $ Foo <$> shrink' (x f) <*> shrink' (y f) <*> shrink' (z f)
      where
        shrink' a = fall a $ shrink a

maybe someone comes up with a nicer way to do that.