Идиоматический способ сокращения записи в QuickCheck

Предположим, у меня есть тип записи:

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

В аккуратном способе записи произвольного экземпляра используется Control.Applicative следующим образом:

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

Список сокращений для Foo, таким образом, является декартовым произведением всех сокращений его членов.

Но если одна из этих сокращений вернется [], то для Foo в целом не будет никаких сокращений. Так что это не работает.

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

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

Но теперь shrink (Foo 0 0 0) вернет [Foo 0 0 0], что означает, что сжатие никогда не прекратится. Так что это тоже не работает.

Похоже, что здесь должно быть что-то другое, кроме < * > , но я не вижу, что.

Ответ 1

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

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

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

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

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

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

Ответ 2

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

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)

Прекрасно работает!

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