15

假设我有一个记录类型：

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}.

但是现在shrink (Foo 0 0 0) 将返回[Foo 0 0 0]，这意味着收缩永远不会终止。所以这也行不通。

看起来这里应该使用除了 <*> 以外的其他东西，但我看不到是什么。

4

2 回答 2

11

如果你想要一个可以在一个位置收缩的应用函子，你可能会喜欢我刚刚创建的这个函数，它可以精确地刮擦那个痒：

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 包上传了。

于 2017-01-30T20:07:50.657 回答
7

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

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

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

于 2012-12-22T21:05:31.317 回答