Сжатие типов и значений вместе без экспоненциального увеличения

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 тип, который содержит как сокращенную схему, так и функцию для сжатия значений в соответствии с новой схемой:

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