{-# 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 = (Int -> Gen (Fix f)) -> Gen (Fix f)
forall a. (Int -> Gen a) -> Gen a
sized Int -> Gen (Fix f)
forall (f :: * -> *). Arbitrary1 f => Int -> Gen (Fix f)
arb where
        arb :: Arbitrary1 f => Int -> Gen (Fix f)
        arb :: Int -> Gen (Fix f)
arb Int
n = (f (Fix f) -> Fix f) -> Gen (f (Fix f)) -> Gen (Fix f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix (Gen (f (Fix f)) -> Gen (Fix f)) -> Gen (f (Fix f)) -> Gen (Fix f)
forall a b. (a -> b) -> a -> b
$ Gen (Fix f) -> Gen (f (Fix f))
forall (f :: * -> *) a. Arbitrary1 f => Gen a -> Gen (f a)
liftArbitrary (Int -> Gen (Fix f)
forall (f :: * -> *). Arbitrary1 f => Int -> Gen (Fix f)
arb (Int -> Int
smaller Int
n))

        smaller :: Int -> Int
smaller Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    = Int
0
                  | Bool
otherwise = Int -> Int
intLog2 Int
n

    shrink :: Fix f -> [Fix f]
shrink = Fix f -> [Fix f]
forall (f :: * -> *). Arbitrary1 f => Fix f -> [Fix f]
go where go :: Fix f -> [Fix f]
go (Fix f (Fix f)
f) = (f (Fix f) -> Fix f) -> [f (Fix f)] -> [Fix f]
forall a b. (a -> b) -> [a] -> [b]
map f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix ((Fix f -> [Fix f]) -> f (Fix f) -> [f (Fix f)]
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 = (Fix f -> f (Fix f)) -> Fix f -> Mu f
forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Mu f
unfoldMu Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix (Fix f -> Mu f) -> Gen (Fix f) -> Gen (Mu f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Fix f)
forall a. Arbitrary a => Gen a
arbitrary
    shrink :: Mu f -> [Mu f]
shrink Mu f
mu = (Fix f -> f (Fix f)) -> Fix f -> Mu f
forall (f :: * -> *) a. Functor f => (a -> f a) -> a -> Mu f
unfoldMu Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix (Fix f -> Mu f) -> [Fix f] -> [Mu f]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fix f -> [Fix f]
forall a. Arbitrary a => a -> [a]
shrink ((f (Fix f) -> Fix f) -> Mu f -> Fix f
forall (f :: * -> *) a. (f a -> a) -> Mu f -> a
foldMu f (Fix f) -> Fix f
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 = (Fix f -> f (Fix f)) -> Fix f -> Nu f
forall a (f :: * -> *). (a -> f a) -> a -> Nu f
unfoldNu Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix (Fix f -> Nu f) -> Gen (Fix f) -> Gen (Nu f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (Fix f)
forall a. Arbitrary a => Gen a
arbitrary
    shrink :: Nu f -> [Nu f]
shrink Nu f
nu = (Fix f -> f (Fix f)) -> Fix f -> Nu f
forall a (f :: * -> *). (a -> f a) -> a -> Nu f
unfoldNu Fix f -> f (Fix f)
forall (f :: * -> *). Fix f -> f (Fix f)
unFix (Fix f -> Nu f) -> [Fix f] -> [Nu f]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Fix f -> [Fix f]
forall a. Arbitrary a => a -> [a]
shrink ((f (Fix f) -> Fix f) -> Nu f -> Fix f
forall (f :: * -> *) a. Functor f => (f a -> a) -> Nu f -> a
foldNu f (Fix f) -> Fix f
forall (f :: * -> *). f (Fix f) -> Fix f
Fix Nu f
nu)