{-# OPTIONS_GHC -fno-warn-orphans #-}
module Test.QuickCheck.Instances.DataFix () where
import Prelude ()
import Test.QuickCheck.Instances.CustomPrelude
import Data.Fix (Fix (..), Mu (..), Nu (..), unfoldMu, unfoldNu, foldMu, foldNu)
import Test.QuickCheck (Arbitrary (..), Arbitrary1 (..), Gen, sized)
import Math.NumberTheory.Logarithms (intLog2)
instance Arbitrary1 f => Arbitrary (Fix f) where
arbitrary :: Gen (Fix f)
arbitrary = forall a. (Int -> Gen a) -> Gen a
sized forall (f :: * -> *). Arbitrary1 f => Int -> Gen (Fix f)
arb where
arb :: Arbitrary1 f => Int -> Gen (Fix f)
arb :: forall (f :: * -> *). Arbitrary1 f => Int -> Gen (Fix f)
arb Int
n = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *). f (Fix f) -> Fix f
Fix forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Arbitrary1 f => Gen a -> Gen (f a)
liftArbitrary (forall (f :: * -> *). Arbitrary1 f => Int -> Gen (Fix f)
arb (Int -> Int
smaller Int
n))
smaller :: Int -> Int
smaller Int
n | Int
n forall a. Ord a => a -> a -> Bool
<= Int
0 = Int
0
| Bool
otherwise = Int -> Int
intLog2 Int
n
shrink :: Fix f -> [Fix f]
shrink = forall (f :: * -> *). Arbitrary1 f => Fix f -> [Fix f]
go where go :: Fix f -> [Fix f]
go (Fix f (Fix f)
f) = forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *). f (Fix f) -> Fix f
Fix (forall (f :: * -> *) a. Arbitrary1 f => (a -> [a]) -> f a -> [f a]
liftShrink Fix f -> [Fix f]
go f (Fix f)
f)
instance (Arbitrary1 f, Functor f) => Arbitrary (Mu f) where
arbitrary :: Gen (Mu f)
arbitrary = forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Mu f
unfoldMu forall (f :: * -> *). Fix f -> f (Fix f)
unFix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
shrink :: Mu f -> [Mu f]
shrink Mu f
mu = forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Mu f
unfoldMu forall (f :: * -> *). Fix f -> f (Fix f)
unFix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => a -> [a]
shrink (forall (f :: * -> *) a. (f a -> a) -> Mu f -> a
foldMu forall (f :: * -> *). f (Fix f) -> Fix f
Fix Mu f
mu)
instance (Arbitrary1 f, Functor f) => Arbitrary (Nu f) where
arbitrary :: Gen (Nu f)
arbitrary = forall a (f :: * -> *). (a -> f a) -> a -> Nu f
unfoldNu forall (f :: * -> *). Fix f -> f (Fix f)
unFix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary
shrink :: Nu f -> [Nu f]
shrink Nu f
nu = forall a (f :: * -> *). (a -> f a) -> a -> Nu f
unfoldNu forall (f :: * -> *). Fix f -> f (Fix f)
unFix forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => a -> [a]
shrink (forall (f :: * -> *) a. Functor f => (f a -> a) -> Nu f -> a
foldNu forall (f :: * -> *). f (Fix f) -> Fix f
Fix Nu f
nu)