Question

假设我有一对数据结构；一个代表一种类型，另一个代表一个值：

data Schema = Leaf | PairOf Schema Schema | ListOf Schema

data ValueOf (schema :: Schema) where
  LeafElem :: String -> ValueOf 'Leaf
  PairElem :: ValueOf x -> ValueOf y -> ValueOf ('PairOf x y)
  ListElem :: [ValueOf x] -> ValueOf ('ListOf x)

现在，我想为它们编写Arbitrary实例，以便可以在QuickCheck测试中使用它们。 Schema实例很简单：

instance Arbitrary Schema where
  arbitrary = sized $ \s -> if s <= 1
    then pure Leaf
    else oneof
      [ pure Leaf
      , scale (`quot` 2) $ PairOf <$> arbitrary <*> arbitrary
      , scale floorSqrt $ ListOf <$> arbitrary
      ]
  shrink = \case
    Leaf       -> empty
    PairOf x y -> asum
      [ pure x
      , pure y
      , PairOf <$> shrink x <*> pure y
      , PairOf <$> pure x <*> shrink y
      ]
    ListOf x -> asum [pure x, ListOf <$> shrink x]

floorSqrt :: Int -> Int
floorSqrt = floor . sqrt . (fromIntegral :: Int -> Float)

ValueOf实例比较棘手，但是使用singletons并不太糟：

$(genSingletons [''Schema])

instance SingI schema => Arbitrary (ValueOf schema) where
  arbitrary = case sing :: Sing schema of
    SLeaf -> LeafElem <$> arbitrary
    SPairOf (singInstance -> SingInstance) (singInstance -> SingInstance) ->
      scale (`quot` 2) $ PairElem <$> arbitrary <*> arbitrary
    SListOf (singInstance -> SingInstance) ->
      scale floorSqrt $ ListElem <$> arbitrary
  shrink = case sing :: Sing schema of
    SLeaf -> \case
      LeafElem x -> LeafElem <$> shrink x
    SPairOf (singInstance -> SingInstance) (singInstance -> SingInstance) ->
      \case
        PairElem x y -> asum
          [PairElem <$> shrink x <*> pure y, PairElem <$> pure x <*> shrink y]
    SListOf (singInstance -> SingInstance) -> \case
      ListElem xs -> ListElem <$> shrink xs

但是我真正想要的是一个类型和该类型的值的列表的实例。

data SchemaAndValues = forall schema.
  SchemaAndValues (SSchema schema) [ValueOf schema]

instance Arbitrary SchemaAndValues where
  arbitrary = arbitrarySchemaAndValues
  shrink = shrinkSchemaAndValues

arbitrary功能很简单；只需生成一个架构，然后生成一些值即可。

arbitrarySchemaAndValues :: Gen SchemaAndValues
arbitrarySchemaAndValues = scale floorSqrt $ do
  schema <- arbitrary
  withSomeSing schema
    $ \sschema -> SchemaAndValues sschema <$> withSingI sschema arbitrary

但是对于收缩功能，我需要一种将模式收缩操作映射到值收缩操作的方法。为此，我定义了一个Shrinker类型，该类型包含 both 和 sshunk 模式，以及用于缩小值以匹配新模式的函数：

shrinkSchemaAndValues :: SchemaAndValues -> [SchemaAndValues]
shrinkSchemaAndValues (SchemaAndValues sschema values) = asum
  [ do
    Shrinker stoSchema valShrink <- shrinkers sschema
    newValues                    <- traverse valShrink values
    pure $ SchemaAndValues stoSchema newValues
  , SchemaAndValues sschema <$> withSingI sschema shrink values
  ]

data Shrinker fromSchema = forall toSchema.
  Shrinker (SSchema toSchema) (ValueOf fromSchema -> [ValueOf toSchema])

shrinkers :: SSchema schema -> [Shrinker schema]
shrinkers = \case
  SLeaf         -> empty
  SPairOf sx sy -> asum
    [ pure (Shrinker sx (\(PairElem x _) -> pure x))
    , pure (Shrinker sy (\(PairElem _ y) -> pure y))
    , do
      Shrinker sx' xfn <- shrinkers sx
      pure $ Shrinker (SPairOf sx' sy)
                      (\(PairElem x y) -> PairElem <$> xfn x <*> pure y)
    , do
      Shrinker sy' yfn <- shrinkers sy
      pure $ Shrinker (SPairOf sx sy')
                      (\(PairElem x y) -> PairElem <$> pure x <*> yfn y)
    ]
  SListOf sx -> asum
    [ pure (Shrinker sx (\(ListElem xs) -> xs))
    , do
      Shrinker sx' xfn <- shrinkers sx
      pure $ Shrinker (SListOf sx')
                      (\(ListElem xs) -> ListElem <$> traverse xfn xs)
    ]

但是这种方法的问题在于，由于对列表monad中的traverse的调用，收缩列表会成倍增加。

特别是，如果我从一个小例子开始，例如

example :: SchemaAndValues
example = SchemaAndValues
  (SListOf (SListOf SLeaf))
  [ ListElem
    [ ListElem [LeafElem "a", LeafElem "b", LeafElem "c"]
    , ListElem [LeafElem "d", LeafElem "e", LeafElem "f", LeafElem "g"]
    ]
  , ListElem
    [ ListElem [LeafElem "h", LeafElem "i"]
    , ListElem [LeafElem "j", LeafElem "k", LeafElem "l"]
    , ListElem [LeafElem "m", LeafElem "n"]
    ]
  , ListElem
    [ ListElem [LeafElem "o", LeafElem "p", LeafElem "q"]
    , ListElem [LeafElem "r", LeafElem "s", LeafElem "t"]
    ]
  ]

这将立即产生1425个收缩。

在缩小到小的反例的同时，如何避免这种指数爆炸？

序言：

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}

module Lib where

import           Control.Applicative
import           Data.Foldable
import           Data.Singletons.TH
import           Test.QuickCheck

缩小类型和值，而不会发生指数爆炸

0 个答案: