{-# 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 = forall (b :: * -> *) a c. b (Cxt a b c) -> Cxt a b c
Term forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => Gen (f v)
arbitraryF
    shrink :: Term f -> [Term f]
shrink (Term f (Term f)
expr) = forall a b. (a -> b) -> [a] -> [b]
map forall (b :: * -> *) a c. b (Cxt a b c) -> Cxt a b c
Term forall a b. (a -> b) -> a -> b
$ 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' :: forall v. Arbitrary v => [(Int, Gen ((:&:) f p v))]
arbitraryF' = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a} {f :: * -> *} {e}.
Arbitrary a =>
(a, Gen (f e)) -> (a, Gen ((:&:) f a e))
addP 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,forall {k} (f :: k -> *) a (e :: k). f e -> a -> (:&:) f a e
(:&:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen (f e)
gen forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary)
    arbitraryF :: forall v. Arbitrary v => Gen ((:&:) f p v)
arbitraryF = forall {k} (f :: k -> *) a (e :: k). f e -> a -> (:&:) f a e
(:&:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => Gen (f v)
arbitraryF forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Arbitrary a => Gen a
arbitrary
    shrinkF :: forall v. Arbitrary v => (:&:) f p v -> [(:&:) f p v]
shrinkF (f v
v :&: p
p) = forall a. Int -> [a] -> [a]
drop Int
1 [f v
v' forall {k} (f :: k -> *) a (e :: k). f e -> a -> (:&:) f a e
:&: p
p'| f v
v' <- f v
vforall a. a -> [a] -> [a]
: forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => f v -> [f v]
shrinkF f v
v, p
p' <- p
p forall a. a -> [a] -> [a]
: 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 :: forall v. Arbitrary v => Gen (Context f v)
arbitraryF = forall a. [Gen a] -> Gen a
oneof [forall (b :: * -> *) a c. b (Cxt a b c) -> Cxt a b c
Term forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => Gen (f v)
arbitraryF , forall c (b :: * -> *). c -> Cxt Hole b c
Hole forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Arbitrary a => Gen a
arbitrary]
    shrinkF :: forall v. Arbitrary v => Context f v -> [Context f v]
shrinkF (Term f (Cxt Hole f v)
expr) = forall a b. (a -> b) -> [a] -> [b]
map forall (b :: * -> *) a c. b (Cxt a b c) -> Cxt a b c
Term forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => f v -> [f v]
shrinkF f (Cxt Hole f v)
expr
    shrinkF (Hole v
a) = forall a b. (a -> b) -> [a] -> [b]
map forall c (b :: * -> *). c -> Cxt Hole b c
Hole forall a b. (a -> b) -> a -> b
$ 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 = forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => Gen (f v)
arbitraryF
    shrink :: Context f a -> [Context f a]
shrink = 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' :: forall v. Arbitrary v => [(Int, Gen ((:+:) f g v))]
arbitraryF' = forall a b. (a -> b) -> [a] -> [b]
map forall {f :: * -> *} {a} {f :: * -> *} {e} {g :: * -> *}.
Functor f =>
(a, f (f e)) -> (a, f ((:+:) f g e))
inl forall (f :: * -> *) v.
(ArbitraryF f, Arbitrary v) =>
[(Int, Gen (f v))]
arbitraryF' forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall {f :: * -> *} {a} {g :: * -> *} {e} {f :: * -> *}.
Functor f =>
(a, f (g e)) -> (a, f ((:+:) f g e))
inr 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,forall {k} (f :: k -> *) (g :: k -> *) (e :: k). f e -> (:+:) f g e
Inl 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,forall {k} (f :: k -> *) (g :: k -> *) (e :: k). g e -> (:+:) f g e
Inr forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (g e)
gen)
    shrinkF :: forall v. Arbitrary v => (:+:) f g v -> [(:+:) f g v]
shrinkF (Inl f v
val) = forall a b. (a -> b) -> [a] -> [b]
map forall {k} (f :: k -> *) (g :: k -> *) (e :: k). f e -> (:+:) f g e
Inl (forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => f v -> [f v]
shrinkF f v
val)
    shrinkF (Inr g v
val) = forall a b. (a -> b) -> [a] -> [b]
map forall {k} (f :: k -> *) (g :: k -> *) (e :: k). g e -> (:+:) f g e
Inr (forall (f :: * -> *) v. (ArbitraryF f, Arbitrary v) => f v -> [f v]
shrinkF g v
val)


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