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.

Answer 2

If you want an applicative functor that will shrink in exactly one position, you might enjoy this one which I just created to scratch precisely that itch:

data ShrinkOne a = ShrinkOne a [a]

instance Functor ShrinkOne where
    fmap f (ShrinkOne o s) = ShrinkOne (f o) (map f s)

instance Applicative ShrinkOne where
    pure x = ShrinkOne x []
    ShrinkOne f fs <*> ShrinkOne x xs = ShrinkOne (f x) (map ($x) fs ++ map f xs)

shrinkOne :: Arbitrary a => a -> ShrinkOne a
shrinkOne x = ShrinkOne x (shrink x)

unShrinkOne :: ShrinkOne t -> [t]
unShrinkOne (ShrinkOne _ xs) = xs

I am using it in code that looks like this, to shrink either in the left element of the tuple, or in one of the fields of the right element of the tuple:

shrink (tss,m) = unShrinkOne $
    ((,) <$> shrinkOne tss <*> traverse shrinkOne m)

Works great so far!

In fact, it works so good that I uploaded it as a hackage package.