Идиоматический способ уменьшить запись в QuickCheck

Я не знаю, что можно считать идиоматическим, но если вы хотите, чтобы каждое сжатие уменьшало хотя бы одно поле, не увеличивая другие,

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

сделал бы это. Экземпляр Applicative для списков таков, что исходное значение является первым в списке результатов, поэтому простое удаление приводит к тому, что список значений действительно сокращается, поэтому сжатие прекращается.

Если вы хотите, чтобы все поля были сжаты, если это возможно, и только несжимаемые поля сохранялись как есть, это немного сложнее, вам нужно сообщить, получили ли вы уже успешное сжатие или нет, и в случае, если вы не получили ни одного в конце вернуть пустой список. То, что упало с моей головы,

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

может быть, кто-то придумает более приятный способ сделать это.

Если вам нужен аппликативный функтор, который сжимается ровно в одной позиции, вам может понравиться вот этот, который я только что создал, чтобы избавиться именно от этого зуда:

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

Я использую его в коде, который выглядит так, чтобы уменьшить либо левый элемент кортежа, либо одно из полей правого элемента кортежа:

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

Отлично работает до сих пор!

На самом деле, он работает так хорошо, что я загрузил его как хакер пакет.