{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
#if HAVE_QUANTIFIED_CONSTRAINTS
{-# LANGUAGE QuantifiedConstraints #-}
#endif
{-# OPTIONS_GHC -Wall #-}

module Test.QuickCheck.Classes.Generic
  (
#if MIN_VERSION_base(4,5,0)
    genericLaws
#if HAVE_UNARY_LAWS
  , generic1Laws
#endif
#endif
  ) where

#if MIN_VERSION_base(4,5,0)
import Control.Applicative
import Data.Semigroup as SG
import Data.Monoid as MD
import GHC.Generics
#if HAVE_UNARY_LAWS
import Data.Functor.Classes
#endif
import Data.Proxy (Proxy(Proxy))
import Test.QuickCheck
import Test.QuickCheck.Property (Property)

import Test.QuickCheck.Classes.Internal (Laws(..), Apply(..))

-- | Tests the following properties:
--
-- [/From-To Inverse/]
--   @'from' '.' 'to' ≡  'id'@
-- [/To-From Inverse/]
--   @'to' '.' 'from' ≡  'id'@
--
-- /Note:/ This property test is only available when
-- using @base-4.5@ or newer.
--
-- /Note:/ 'from' and 'to' don't actually care about
-- the type variable @x@ in @'Rep' a x@, so here we instantiate
-- it to @'()'@ by default. If you would like to instantiate @x@
-- as something else, please file a bug report.
genericLaws :: (Generic a, Eq a, Arbitrary a, Show a, Show (Rep a ()), Arbitrary (Rep a ()), Eq (Rep a ())) => Proxy a -> Laws
genericLaws :: Proxy a -> Laws
genericLaws Proxy a
pa = String -> [(String, Property)] -> Laws
Laws String
"Generic"
  [ (String
"From-To inverse", Proxy a -> Proxy () -> Property
forall (proxy :: * -> *) a x.
(Generic a, Show (Rep a x), Arbitrary (Rep a x), Eq (Rep a x)) =>
proxy a -> proxy x -> Property
fromToInverse Proxy a
pa (Proxy ()
forall k (t :: k). Proxy t
Proxy :: Proxy ()))
  , (String
"To-From inverse", Proxy a -> Property
forall (proxy :: * -> *) a.
(Generic a, Eq a, Arbitrary a, Show a) =>
proxy a -> Property
toFromInverse Proxy a
pa)
  ]

toFromInverse :: forall proxy a. (Generic a, Eq a, Arbitrary a, Show a) => proxy a -> Property
toFromInverse :: proxy a -> Property
toFromInverse proxy a
_ = (a -> Bool) -> Property
forall prop. Testable prop => prop -> Property
property ((a -> Bool) -> Property) -> (a -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \(a
v :: a) -> (Rep a Any -> a
forall a x. Generic a => Rep a x -> a
to (Rep a Any -> a) -> (a -> Rep a Any) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Rep a Any
forall a x. Generic a => a -> Rep a x
from (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
v) a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
v

fromToInverse ::
     forall proxy a x.
     (Generic a, Show (Rep a x), Arbitrary (Rep a x), Eq (Rep a x))
  => proxy a
  -> proxy x
  -> Property
fromToInverse :: proxy a -> proxy x -> Property
fromToInverse proxy a
_ proxy x
_ = (Rep a x -> Bool) -> Property
forall prop. Testable prop => prop -> Property
property ((Rep a x -> Bool) -> Property) -> (Rep a x -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \(Rep a x
r :: Rep a x) -> Rep a x
r Rep a x -> Rep a x -> Bool
forall a. Eq a => a -> a -> Bool
== (a -> Rep a x
forall a x. Generic a => a -> Rep a x
from (Rep a x -> a
forall a x. Generic a => Rep a x -> a
to Rep a x
r :: a)) 

#if HAVE_UNARY_LAWS
-- | Tests the following properties:
--
-- [/From-To Inverse/]
--   @'from1' '.' 'to1' ≡  'id'@
-- [/To-From Inverse/]
--   @'to1' '.' 'from1' ≡  'id'@
--
-- /Note:/ This property test is only available when
-- using @base-4.9@ or newer.
generic1Laws :: (Generic1 f, Eq1 f, Arbitrary1 f, Show1 f, Eq1 (Rep1 f), Show1 (Rep1 f), Arbitrary1 (Rep1 f))
  => proxy f -> Laws
generic1Laws :: proxy f -> Laws
generic1Laws proxy f
p = String -> [(String, Property)] -> Laws
Laws String
"Generic1"
  [ (String
"From1-To1 inverse", proxy f -> Property
forall (proxy :: (* -> *) -> *) (f :: * -> *).
(Generic1 f, Eq1 (Rep1 f), Arbitrary1 (Rep1 f), Show1 (Rep1 f)) =>
proxy f -> Property
fromToInverse1 proxy f
p)
  , (String
"To1-From1 inverse", proxy f -> Property
forall (proxy :: (* -> *) -> *) (f :: * -> *).
(Generic1 f, Eq1 f, Arbitrary1 f, Show1 f) =>
proxy f -> Property
toFromInverse1 proxy f
p)
  ]

-- hack for quantified constraints: under base >= 4.12,
-- our usual 'Apply' wrapper has Eq, Show, and Arbitrary
-- instances that are incompatible.
newtype GApply f a = GApply { GApply f a -> f a
getGApply :: f a }

instance (Applicative f, Semigroup a) => Semigroup (GApply f a) where
  GApply f a
x <> :: GApply f a -> GApply f a -> GApply f a
<> GApply f a
y = f a -> GApply f a
forall (f :: * -> *) a. f a -> GApply f a
GApply (f a -> GApply f a) -> f a -> GApply f a
forall a b. (a -> b) -> a -> b
$ (a -> a -> a) -> f a -> f a -> f a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(SG.<>) f a
x f a
y

instance (Applicative f, Monoid a) => Monoid (GApply f a) where
  mempty :: GApply f a
mempty = f a -> GApply f a
forall (f :: * -> *) a. f a -> GApply f a
GApply (f a -> GApply f a) -> f a -> GApply f a
forall a b. (a -> b) -> a -> b
$ a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
forall a. Monoid a => a
mempty
  mappend :: GApply f a -> GApply f a -> GApply f a
mappend (GApply f a
x) (GApply f a
y) = f a -> GApply f a
forall (f :: * -> *) a. f a -> GApply f a
GApply (f a -> GApply f a) -> f a -> GApply f a
forall a b. (a -> b) -> a -> b
$ (a -> a -> a) -> f a -> f a -> f a
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 a -> a -> a
forall a. Semigroup a => a -> a -> a
(MD.<>) f a
x f a
y

instance (Eq1 f, Eq a) => Eq (GApply f a) where
  GApply f a
a == :: GApply f a -> GApply f a -> Bool
== GApply f a
b = f a -> f a -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1 f a
a f a
b

instance (Show1 f, Show a) => Show (GApply f a) where
  showsPrec :: Int -> GApply f a -> ShowS
showsPrec Int
p = Int -> f a -> ShowS
forall (f :: * -> *) a. (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1 Int
p (f a -> ShowS) -> (GApply f a -> f a) -> GApply f a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GApply f a -> f a
forall (f :: * -> *) a. GApply f a -> f a
getGApply

instance (Arbitrary1 f, Arbitrary a) => Arbitrary (GApply f a) where
  arbitrary :: Gen (GApply f a)
arbitrary = (f a -> GApply f a) -> Gen (f a) -> Gen (GApply f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> GApply f a
forall (f :: * -> *) a. f a -> GApply f a
GApply Gen (f a)
forall (f :: * -> *) a. (Arbitrary1 f, Arbitrary a) => Gen (f a)
arbitrary1
  shrink :: GApply f a -> [GApply f a]
shrink = (f a -> GApply f a) -> [f a] -> [GApply f a]
forall a b. (a -> b) -> [a] -> [b]
map f a -> GApply f a
forall (f :: * -> *) a. f a -> GApply f a
GApply ([f a] -> [GApply f a])
-> (GApply f a -> [f a]) -> GApply f a -> [GApply f a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> [f a]
forall (f :: * -> *) a. (Arbitrary1 f, Arbitrary a) => f a -> [f a]
shrink1 (f a -> [f a]) -> (GApply f a -> f a) -> GApply f a -> [f a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GApply f a -> f a
forall (f :: * -> *) a. GApply f a -> f a
getGApply

toFromInverse1 :: forall proxy f. (Generic1 f, Eq1 f, Arbitrary1 f, Show1 f) => proxy f -> Property
toFromInverse1 :: proxy f -> Property
toFromInverse1 proxy f
_ = (GApply f Integer -> Bool) -> Property
forall prop. Testable prop => prop -> Property
property ((GApply f Integer -> Bool) -> Property)
-> (GApply f Integer -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \(GApply (f Integer
v :: f Integer)) -> f Integer -> f Integer -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1 f Integer
v (Rep1 f Integer -> f Integer
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Rep1 f Integer -> f Integer)
-> (f Integer -> Rep1 f Integer) -> f Integer -> f Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f Integer -> Rep1 f Integer
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 (f Integer -> f Integer) -> f Integer -> f Integer
forall a b. (a -> b) -> a -> b
$ f Integer
v)

fromToInverse1 :: forall proxy f. (Generic1 f, Eq1 (Rep1 f), Arbitrary1 (Rep1 f), Show1 (Rep1 f)) => proxy f -> Property
fromToInverse1 :: proxy f -> Property
fromToInverse1 proxy f
_ = (GApply (Rep1 f) Integer -> Bool) -> Property
forall prop. Testable prop => prop -> Property
property ((GApply (Rep1 f) Integer -> Bool) -> Property)
-> (GApply (Rep1 f) Integer -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \(GApply (r :: Rep1 f Integer)) -> Rep1 f Integer -> Rep1 f Integer -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1 Rep1 f Integer
r (f Integer -> Rep1 f Integer
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 ((Rep1 f Integer -> f Integer
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (Rep1 f Integer -> f Integer) -> Rep1 f Integer -> f Integer
forall a b. (a -> b) -> a -> b
$ Rep1 f Integer
r) :: f Integer))

#endif

#endif