{-# LANGUAGE Safe #-} {-# OPTIONS_GHC -Wno-orphans #-} module Yaya.QuickCheck.Fold ( arbitrarySteppable, shrinkSteppable, ) where import qualified "QuickCheck" Test.QuickCheck as QC import "base" Control.Applicative (Applicative (pure, (<*>))) import "base" Data.Foldable (Foldable) import qualified "base" Data.Foldable as Foldable import "base" Data.Function (flip) import "base" Data.Functor (Functor, (<$>)) import "base" Data.Semigroup (Semigroup ((<>))) import "yaya" Yaya.Fold ( Mu, Nu, Projectable (project), Steppable (embed), ) import "yaya" Yaya.Fold.Native (Cofix, Fix) import "yaya" Yaya.Pattern (AndMaybe (Indeed, Only), XNor (Both, Neither)) arbitrarySteppable :: (Steppable (->) t f, Functor f) => (QC.Gen t -> QC.Gen (f t)) -> QC.Gen t arbitrarySteppable :: forall t (f :: * -> *). (Steppable (->) t f, Functor f) => (Gen t -> Gen (f t)) -> Gen t arbitrarySteppable Gen t -> Gen (f t) liftArbitraryF = Algebra (->) f t forall {k} (c :: k -> k -> *) (t :: k) (f :: k -> k). Steppable c t f => Algebra c f t embed Algebra (->) f t -> Gen (f t) -> Gen t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Gen t -> Gen (f t) liftArbitraryF ((Gen t -> Gen (f t)) -> Gen t forall t (f :: * -> *). (Steppable (->) t f, Functor f) => (Gen t -> Gen (f t)) -> Gen t arbitrarySteppable Gen t -> Gen (f t) liftArbitraryF) shrinkSteppable :: (Steppable (->) t f, Foldable f, Functor f) => ((t -> [t]) -> f t -> [f t]) -> t -> [t] shrinkSteppable :: forall t (f :: * -> *). (Steppable (->) t f, Foldable f, Functor f) => ((t -> [t]) -> f t -> [f t]) -> t -> [t] shrinkSteppable (t -> [t]) -> f t -> [f t] liftShrinkF t fix = let ft :: f t ft = Coalgebra (->) f t forall {k} {k1} (c :: k -> k1 -> *) (t :: k) (f :: k -> k1). Projectable c t f => Coalgebra c f t project t fix in f t -> [t] forall a. f a -> [a] forall (t :: * -> *) a. Foldable t => t a -> [a] Foldable.toList f t ft [t] -> [t] -> [t] forall a. Semigroup a => a -> a -> a <> (Algebra (->) f t forall {k} (c :: k -> k -> *) (t :: k) (f :: k -> k). Steppable c t f => Algebra c f t embed Algebra (->) f t -> [f t] -> [t] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (t -> [t]) -> f t -> [f t] liftShrinkF (((t -> [t]) -> f t -> [f t]) -> t -> [t] forall t (f :: * -> *). (Steppable (->) t f, Foldable f, Functor f) => ((t -> [t]) -> f t -> [f t]) -> t -> [t] shrinkSteppable (t -> [t]) -> f t -> [f t] liftShrinkF) f t ft) instance (Foldable f, Functor f, QC.Arbitrary1 f) => QC.Arbitrary (Cofix f) where arbitrary :: Gen (Cofix f) arbitrary = (Gen (Cofix f) -> Gen (f (Cofix f))) -> Gen (Cofix f) forall t (f :: * -> *). (Steppable (->) t f, Functor f) => (Gen t -> Gen (f t)) -> Gen t arbitrarySteppable Gen (Cofix f) -> Gen (f (Cofix f)) forall a. Gen a -> Gen (f a) forall (f :: * -> *) a. Arbitrary1 f => Gen a -> Gen (f a) QC.liftArbitrary shrink :: Cofix f -> [Cofix f] shrink = ((Cofix f -> [Cofix f]) -> f (Cofix f) -> [f (Cofix f)]) -> Cofix f -> [Cofix f] forall t (f :: * -> *). (Steppable (->) t f, Foldable f, Functor f) => ((t -> [t]) -> f t -> [f t]) -> t -> [t] shrinkSteppable (Cofix f -> [Cofix f]) -> f (Cofix f) -> [f (Cofix f)] forall a. (a -> [a]) -> f a -> [f a] forall (f :: * -> *) a. Arbitrary1 f => (a -> [a]) -> f a -> [f a] QC.liftShrink instance (Foldable f, Functor f, QC.Arbitrary1 f) => QC.Arbitrary (Fix f) where arbitrary :: Gen (Fix f) arbitrary = (Gen (Fix f) -> Gen (f (Fix f))) -> Gen (Fix f) forall t (f :: * -> *). (Steppable (->) t f, Functor f) => (Gen t -> Gen (f t)) -> Gen t arbitrarySteppable Gen (Fix f) -> Gen (f (Fix f)) forall a. Gen a -> Gen (f a) forall (f :: * -> *) a. Arbitrary1 f => Gen a -> Gen (f a) QC.liftArbitrary shrink :: Fix f -> [Fix f] shrink = ((Fix f -> [Fix f]) -> f (Fix f) -> [f (Fix f)]) -> Fix f -> [Fix f] forall t (f :: * -> *). (Steppable (->) t f, Foldable f, Functor f) => ((t -> [t]) -> f t -> [f t]) -> t -> [t] shrinkSteppable (Fix f -> [Fix f]) -> f (Fix f) -> [f (Fix f)] forall a. (a -> [a]) -> f a -> [f a] forall (f :: * -> *) a. Arbitrary1 f => (a -> [a]) -> f a -> [f a] QC.liftShrink instance (Foldable f, Functor f, QC.Arbitrary1 f) => QC.Arbitrary (Mu f) where arbitrary :: Gen (Mu f) arbitrary = (Gen (Mu f) -> Gen (f (Mu f))) -> Gen (Mu f) forall t (f :: * -> *). (Steppable (->) t f, Functor f) => (Gen t -> Gen (f t)) -> Gen t arbitrarySteppable Gen (Mu f) -> Gen (f (Mu f)) forall a. Gen a -> Gen (f a) forall (f :: * -> *) a. Arbitrary1 f => Gen a -> Gen (f a) QC.liftArbitrary shrink :: Mu f -> [Mu f] shrink = ((Mu f -> [Mu f]) -> f (Mu f) -> [f (Mu f)]) -> Mu f -> [Mu f] forall t (f :: * -> *). (Steppable (->) t f, Foldable f, Functor f) => ((t -> [t]) -> f t -> [f t]) -> t -> [t] shrinkSteppable (Mu f -> [Mu f]) -> f (Mu f) -> [f (Mu f)] forall a. (a -> [a]) -> f a -> [f a] forall (f :: * -> *) a. Arbitrary1 f => (a -> [a]) -> f a -> [f a] QC.liftShrink instance (Foldable f, Functor f, QC.Arbitrary1 f) => QC.Arbitrary (Nu f) where arbitrary :: Gen (Nu f) arbitrary = (Gen (Nu f) -> Gen (f (Nu f))) -> Gen (Nu f) forall t (f :: * -> *). (Steppable (->) t f, Functor f) => (Gen t -> Gen (f t)) -> Gen t arbitrarySteppable Gen (Nu f) -> Gen (f (Nu f)) forall a. Gen a -> Gen (f a) forall (f :: * -> *) a. Arbitrary1 f => Gen a -> Gen (f a) QC.liftArbitrary shrink :: Nu f -> [Nu f] shrink = ((Nu f -> [Nu f]) -> f (Nu f) -> [f (Nu f)]) -> Nu f -> [Nu f] forall t (f :: * -> *). (Steppable (->) t f, Foldable f, Functor f) => ((t -> [t]) -> f t -> [f t]) -> t -> [t] shrinkSteppable (Nu f -> [Nu f]) -> f (Nu f) -> [f (Nu f)] forall a. (a -> [a]) -> f a -> [f a] forall (f :: * -> *) a. Arbitrary1 f => (a -> [a]) -> f a -> [f a] QC.liftShrink instance (QC.Arbitrary a, QC.Arbitrary b) => QC.Arbitrary (XNor a b) where arbitrary :: Gen (XNor a b) arbitrary = Gen b -> Gen (XNor a b) forall a. Gen a -> Gen (XNor a a) forall (f :: * -> *) a. Arbitrary1 f => Gen a -> Gen (f a) QC.liftArbitrary Gen b forall a. Arbitrary a => Gen a QC.arbitrary shrink :: XNor a b -> [XNor a b] shrink = (b -> [b]) -> XNor a b -> [XNor a b] forall a. (a -> [a]) -> XNor a a -> [XNor a a] forall (f :: * -> *) a. Arbitrary1 f => (a -> [a]) -> f a -> [f a] QC.liftShrink b -> [b] forall a. Arbitrary a => a -> [a] QC.shrink instance (QC.Arbitrary a) => QC.Arbitrary1 (XNor a) where liftArbitrary :: forall a. Gen a -> Gen (XNor a a) liftArbitrary = Gen a -> Gen a -> Gen (XNor a a) forall a b. Gen a -> Gen b -> Gen (XNor a b) forall (f :: * -> * -> *) a b. Arbitrary2 f => Gen a -> Gen b -> Gen (f a b) QC.liftArbitrary2 Gen a forall a. Arbitrary a => Gen a QC.arbitrary liftShrink :: forall a. (a -> [a]) -> XNor a a -> [XNor a a] liftShrink = (a -> [a]) -> (a -> [a]) -> XNor a a -> [XNor a a] forall a b. (a -> [a]) -> (b -> [b]) -> XNor a b -> [XNor a b] forall (f :: * -> * -> *) a b. Arbitrary2 f => (a -> [a]) -> (b -> [b]) -> f a b -> [f a b] QC.liftShrink2 a -> [a] forall a. Arbitrary a => a -> [a] QC.shrink instance QC.Arbitrary2 XNor where liftArbitrary2 :: forall a b. Gen a -> Gen b -> Gen (XNor a b) liftArbitrary2 Gen a a Gen b b = [(Int, Gen (XNor a b))] -> Gen (XNor a b) forall a. [(Int, Gen a)] -> Gen a QC.frequency [(Int 1, XNor a b -> Gen (XNor a b) forall a. a -> Gen a forall (f :: * -> *) a. Applicative f => a -> f a pure XNor a b forall a b. XNor a b Neither), (Int 3, a -> b -> XNor a b forall a b. a -> b -> XNor a b Both (a -> b -> XNor a b) -> Gen a -> Gen (b -> XNor a b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Gen a a Gen (b -> XNor a b) -> Gen b -> Gen (XNor a b) forall a b. Gen (a -> b) -> Gen a -> Gen b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Gen b b)] liftShrink2 :: forall a b. (a -> [a]) -> (b -> [b]) -> XNor a b -> [XNor a b] liftShrink2 a -> [a] shrinkA b -> [b] shrinkB = \case XNor a b Neither -> [] Both a a b b -> XNor a b forall a b. XNor a b Neither XNor a b -> [XNor a b] -> [XNor a b] forall a. a -> [a] -> [a] : ((a -> b -> XNor a b) -> b -> a -> XNor a b forall a b c. (a -> b -> c) -> b -> a -> c flip a -> b -> XNor a b forall a b. a -> b -> XNor a b Both b b (a -> XNor a b) -> [a] -> [XNor a b] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> a -> [a] shrinkA a a) [XNor a b] -> [XNor a b] -> [XNor a b] forall a. Semigroup a => a -> a -> a <> (a -> b -> XNor a b forall a b. a -> b -> XNor a b Both a a (b -> XNor a b) -> [b] -> [XNor a b] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> b -> [b] shrinkB b b) instance (QC.Arbitrary a, QC.Arbitrary b) => QC.Arbitrary (AndMaybe a b) where arbitrary :: Gen (AndMaybe a b) arbitrary = Gen b -> Gen (AndMaybe a b) forall a. Gen a -> Gen (AndMaybe a a) forall (f :: * -> *) a. Arbitrary1 f => Gen a -> Gen (f a) QC.liftArbitrary Gen b forall a. Arbitrary a => Gen a QC.arbitrary shrink :: AndMaybe a b -> [AndMaybe a b] shrink = (b -> [b]) -> AndMaybe a b -> [AndMaybe a b] forall a. (a -> [a]) -> AndMaybe a a -> [AndMaybe a a] forall (f :: * -> *) a. Arbitrary1 f => (a -> [a]) -> f a -> [f a] QC.liftShrink b -> [b] forall a. Arbitrary a => a -> [a] QC.shrink instance (QC.Arbitrary a) => QC.Arbitrary1 (AndMaybe a) where liftArbitrary :: forall a. Gen a -> Gen (AndMaybe a a) liftArbitrary = Gen a -> Gen a -> Gen (AndMaybe a a) forall a b. Gen a -> Gen b -> Gen (AndMaybe a b) forall (f :: * -> * -> *) a b. Arbitrary2 f => Gen a -> Gen b -> Gen (f a b) QC.liftArbitrary2 Gen a forall a. Arbitrary a => Gen a QC.arbitrary liftShrink :: forall a. (a -> [a]) -> AndMaybe a a -> [AndMaybe a a] liftShrink = (a -> [a]) -> (a -> [a]) -> AndMaybe a a -> [AndMaybe a a] forall a b. (a -> [a]) -> (b -> [b]) -> AndMaybe a b -> [AndMaybe a b] forall (f :: * -> * -> *) a b. Arbitrary2 f => (a -> [a]) -> (b -> [b]) -> f a b -> [f a b] QC.liftShrink2 a -> [a] forall a. Arbitrary a => a -> [a] QC.shrink instance QC.Arbitrary2 AndMaybe where liftArbitrary2 :: forall a b. Gen a -> Gen b -> Gen (AndMaybe a b) liftArbitrary2 Gen a a Gen b b = [(Int, Gen (AndMaybe a b))] -> Gen (AndMaybe a b) forall a. [(Int, Gen a)] -> Gen a QC.frequency [(Int 1, a -> AndMaybe a b forall a b. a -> AndMaybe a b Only (a -> AndMaybe a b) -> Gen a -> Gen (AndMaybe a b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Gen a a), (Int 3, a -> b -> AndMaybe a b forall a b. a -> b -> AndMaybe a b Indeed (a -> b -> AndMaybe a b) -> Gen a -> Gen (b -> AndMaybe a b) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Gen a a Gen (b -> AndMaybe a b) -> Gen b -> Gen (AndMaybe a b) forall a b. Gen (a -> b) -> Gen a -> Gen b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Gen b b)] liftShrink2 :: forall a b. (a -> [a]) -> (b -> [b]) -> AndMaybe a b -> [AndMaybe a b] liftShrink2 a -> [a] shrinkA b -> [b] shrinkB = \case Only a a -> a -> AndMaybe a b forall a b. a -> AndMaybe a b Only (a -> AndMaybe a b) -> [a] -> [AndMaybe a b] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> a -> [a] shrinkA a a Indeed a a b b -> (a -> AndMaybe a b forall a b. a -> AndMaybe a b Only (a -> AndMaybe a b) -> [a] -> [AndMaybe a b] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> a -> [a] shrinkA a a) [AndMaybe a b] -> [AndMaybe a b] -> [AndMaybe a b] forall a. Semigroup a => a -> a -> a <> (a -> AndMaybe a b forall a b. a -> AndMaybe a b Only a a AndMaybe a b -> [AndMaybe a b] -> [AndMaybe a b] forall a. a -> [a] -> [a] : ((a -> b -> AndMaybe a b) -> b -> a -> AndMaybe a b forall a b c. (a -> b -> c) -> b -> a -> c flip a -> b -> AndMaybe a b forall a b. a -> b -> AndMaybe a b Indeed b b (a -> AndMaybe a b) -> [a] -> [AndMaybe a b] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> a -> [a] shrinkA a a) [AndMaybe a b] -> [AndMaybe a b] -> [AndMaybe a b] forall a. Semigroup a => a -> a -> a <> (a -> b -> AndMaybe a b forall a b. a -> b -> AndMaybe a b Indeed a a (b -> AndMaybe a b) -> [b] -> [AndMaybe a b] forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> b -> [b] shrinkB b b))