{-# 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))