在QuickCheck中缩小记录的惯用法

Question

假设我有一个记录类型:

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

编写Arbitrary实例的一种巧妙方法是使用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}.

但现在缩小(Foo 0 0 0)将返回[Foo 0 0 0],这意味着收缩将永远不会终止.所以这也不起作用.

看起来在这里应该使用<*>以外的其他东西,但我看不出是什么.

Answer 1

如果你想要一个可以缩小到一个位置的应用程序仿函数,你可能会喜欢我刚刚创建的那个正好抓住它的那个:

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包上传.

Answer 2

我不知道什么是惯用的,但是如果你想确保每次缩小都会减少至少一个字段而不增加其他字段,

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

也许有人想出一个更好的方法来做到这一点.