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

-------------------------------------------------------------------------------
-- data-fix
-------------------------------------------------------------------------------

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)