将类型和值收缩在一起而不出现指数膨胀

假设我有一对数据结构;一个表示类型,另一个表示值:

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 实例,以便我可以在快速检查测试中使用它们。 这个 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 类型,其中包含 二者都 A. 架构和收缩值以匹配新架构的函数:

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)
    ]

但这种方法的问题是,由于调用 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