{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE TypeSynonymInstances #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.Arbitrary
-- Copyright   :  (c) 2011 Patrick Bahr
-- License     :  BSD3
-- Maintainer  :  Patrick Bahr <paba@diku.dk>
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- This module defines generation of arbitrary values for signatures, which
-- lifts to generating arbitrary terms.
--
--------------------------------------------------------------------------------

module Data.Comp.Arbitrary
    ( ArbitraryF(..)
    )where

import Data.Comp.Derive
import Data.Comp.Derive.Utils
import Data.Comp.Ops
import Data.Comp.Term
import Test.QuickCheck

{-| This lifts instances of 'ArbitraryF' to instances of 'Arbitrary'
for the corresponding term type. -}

instance (ArbitraryF f) => Arbitrary (Term f) where
    arbitrary :: Gen (Term f)
arbitrary = f (Term f) -> Term f
forall (f :: * -> *) h a. f (Cxt h f a) -> Cxt h f a
Term (f (Term f) -> Term f) -> Gen (f (Term f)) -> Gen (Term f)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (f (Term f))
forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => Gen (f v)
arbitraryF
    shrink :: Term f -> [Term f]
shrink (Term f (Term f)
expr) = (f (Term f) -> Term f) -> [f (Term f)] -> [Term f]
forall a b. (a -> b) -> [a] -> [b]
map f (Term f) -> Term f
forall (f :: * -> *) h a. f (Cxt h f a) -> Cxt h f a
Term ([f (Term f)] -> [Term f]) -> [f (Term f)] -> [Term f]
forall a b. (a -> b) -> a -> b
$ f (Term f) -> [f (Term f)]
forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => f v -> [f v]
shrinkF f (Term f)
expr

instance (ArbitraryF f, Arbitrary p) => ArbitraryF (f :&: p) where
    arbitraryF' :: [(Int, Gen ((:&:) f p v))]
arbitraryF' = ((Int, Gen (f v)) -> (Int, Gen ((:&:) f p v)))
-> [(Int, Gen (f v))] -> [(Int, Gen ((:&:) f p v))]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Gen (f v)) -> (Int, Gen ((:&:) f p v))
forall a a (f :: * -> *) e.
Arbitrary a =>
(a, Gen (f e)) -> (a, Gen ((:&:) f a e))
addP [(Int, Gen (f v))]
forall (f :: * -> *) v.
(ArbitraryF f, Arbitrary v) =>
[(Int, Gen (f v))]
arbitraryF'
        where addP :: (a, Gen (f e)) -> (a, Gen ((:&:) f a e))
addP (a
i,Gen (f e)
gen) =  (a
i,f e -> a -> (:&:) f a e
forall k (f :: k -> *) a (e :: k). f e -> a -> (:&:) f a e
(:&:) (f e -> a -> (:&:) f a e) -> Gen (f e) -> Gen (a -> (:&:) f a e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (f e)
gen Gen (a -> (:&:) f a e) -> Gen a -> Gen ((:&:) f a e)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen a
forall a. Arbitrary a => Gen a
arbitrary)
    arbitraryF :: Gen ((:&:) f p v)
arbitraryF = f v -> p -> (:&:) f p v
forall k (f :: k -> *) a (e :: k). f e -> a -> (:&:) f a e
(:&:) (f v -> p -> (:&:) f p v) -> Gen (f v) -> Gen (p -> (:&:) f p v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (f v)
forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => Gen (f v)
arbitraryF Gen (p -> (:&:) f p v) -> Gen p -> Gen ((:&:) f p v)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Gen p
forall a. Arbitrary a => Gen a
arbitrary
    shrinkF :: (:&:) f p v -> [(:&:) f p v]
shrinkF (f v
v :&: p
p) = [(:&:) f p v] -> [(:&:) f p v]
forall a. [a] -> [a]
tail [f v
v' f v -> p -> (:&:) f p v
forall k (f :: k -> *) a (e :: k). f e -> a -> (:&:) f a e
:&: p
p'| f v
v' <- f v
vf v -> [f v] -> [f v]
forall a. a -> [a] -> [a]
: f v -> [f v]
forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => f v -> [f v]
shrinkF f v
v, p
p' <- p
p p -> [p] -> [p]
forall a. a -> [a] -> [a]
: p -> [p]
forall a. Arbitrary a => a -> [a]
shrink p
p ]

{-|
  This lifts instances of 'ArbitraryF' to instances of 'ArbitraryF' for
  the corresponding context functor.
-}
instance (ArbitraryF f) => ArbitraryF (Context f) where
    arbitraryF :: Gen (Context f v)
arbitraryF = [Gen (Context f v)] -> Gen (Context f v)
forall a. [Gen a] -> Gen a
oneof [f (Context f v) -> Context f v
forall (f :: * -> *) h a. f (Cxt h f a) -> Cxt h f a
Term (f (Context f v) -> Context f v)
-> Gen (f (Context f v)) -> Gen (Context f v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (f (Context f v))
forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => Gen (f v)
arbitraryF , v -> Context f v
forall a (f :: * -> *). a -> Cxt Hole f a
Hole (v -> Context f v) -> Gen v -> Gen (Context f v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen v
forall a. Arbitrary a => Gen a
arbitrary]
    shrinkF :: Context f v -> [Context f v]
shrinkF (Term f (Context f v)
expr) = (f (Context f v) -> Context f v)
-> [f (Context f v)] -> [Context f v]
forall a b. (a -> b) -> [a] -> [b]
map f (Context f v) -> Context f v
forall (f :: * -> *) h a. f (Cxt h f a) -> Cxt h f a
Term ([f (Context f v)] -> [Context f v])
-> [f (Context f v)] -> [Context f v]
forall a b. (a -> b) -> a -> b
$ f (Context f v) -> [f (Context f v)]
forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => f v -> [f v]
shrinkF f (Context f v)
expr
    shrinkF (Hole v
a) = (v -> Context f v) -> [v] -> [Context f v]
forall a b. (a -> b) -> [a] -> [b]
map v -> Context f v
forall a (f :: * -> *). a -> Cxt Hole f a
Hole ([v] -> [Context f v]) -> [v] -> [Context f v]
forall a b. (a -> b) -> a -> b
$ v -> [v]
forall a. Arbitrary a => a -> [a]
shrink v
a


{-| This lifts instances of 'ArbitraryF' to instances of 'Arbitrary'
for the corresponding context type.  -}

instance (ArbitraryF f, Arbitrary a) => Arbitrary (Context f a) where
    arbitrary :: Gen (Context f a)
arbitrary = Gen (Context f a)
forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => Gen (f v)
arbitraryF
    shrink :: Context f a -> [Context f a]
shrink = Context f a -> [Context f a]
forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => f v -> [f v]
shrinkF


{-| Instances of 'ArbitraryF' are closed under forming sums.  -}

instance (ArbitraryF f , ArbitraryF g) => ArbitraryF (f :+: g) where
    arbitraryF' :: [(Int, Gen ((:+:) f g v))]
arbitraryF' = ((Int, Gen (f v)) -> (Int, Gen ((:+:) f g v)))
-> [(Int, Gen (f v))] -> [(Int, Gen ((:+:) f g v))]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Gen (f v)) -> (Int, Gen ((:+:) f g v))
forall (f :: * -> *) a (f :: * -> *) e (g :: * -> *).
Functor f =>
(a, f (f e)) -> (a, f ((:+:) f g e))
inl [(Int, Gen (f v))]
forall (f :: * -> *) v.
(ArbitraryF f, Arbitrary v) =>
[(Int, Gen (f v))]
arbitraryF' [(Int, Gen ((:+:) f g v))]
-> [(Int, Gen ((:+:) f g v))] -> [(Int, Gen ((:+:) f g v))]
forall a. [a] -> [a] -> [a]
++ ((Int, Gen (g v)) -> (Int, Gen ((:+:) f g v)))
-> [(Int, Gen (g v))] -> [(Int, Gen ((:+:) f g v))]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Gen (g v)) -> (Int, Gen ((:+:) f g v))
forall (f :: * -> *) a (g :: * -> *) e (f :: * -> *).
Functor f =>
(a, f (g e)) -> (a, f ((:+:) f g e))
inr [(Int, Gen (g v))]
forall (f :: * -> *) v.
(ArbitraryF f, Arbitrary v) =>
[(Int, Gen (f v))]
arbitraryF'
        where inl :: (a, f (f e)) -> (a, f ((:+:) f g e))
inl (a
i,f (f e)
gen) = (a
i,f e -> (:+:) f g e
forall k (f :: k -> *) (g :: k -> *) (e :: k). f e -> (:+:) f g e
Inl (f e -> (:+:) f g e) -> f (f e) -> f ((:+:) f g e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (f e)
gen)
              inr :: (a, f (g e)) -> (a, f ((:+:) f g e))
inr (a
i,f (g e)
gen) = (a
i,g e -> (:+:) f g e
forall k (f :: k -> *) (g :: k -> *) (e :: k). g e -> (:+:) f g e
Inr (g e -> (:+:) f g e) -> f (g e) -> f ((:+:) f g e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (g e)
gen)
    shrinkF :: (:+:) f g v -> [(:+:) f g v]
shrinkF (Inl f v
val) = (f v -> (:+:) f g v) -> [f v] -> [(:+:) f g v]
forall a b. (a -> b) -> [a] -> [b]
map f v -> (:+:) f g v
forall k (f :: k -> *) (g :: k -> *) (e :: k). f e -> (:+:) f g e
Inl (f v -> [f v]
forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => f v -> [f v]
shrinkF f v
val)
    shrinkF (Inr g v
val) = (g v -> (:+:) f g v) -> [g v] -> [(:+:) f g v]
forall a b. (a -> b) -> [a] -> [b]
map g v -> (:+:) f g v
forall k (f :: k -> *) (g :: k -> *) (e :: k). g e -> (:+:) f g e
Inr (g v -> [g v]
forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => f v -> [f v]
shrinkF g v
val)


$(derive [makeArbitraryF] $ [''Maybe,''[]] ++ tupleTypes 2 10)