1{-# LANGUAGE BangPatterns #-} 2{-# LANGUAGE CPP #-} 3{-# LANGUAGE FlexibleContexts #-} 4{-# LANGUAGE ScopedTypeVariables #-} 5#if HAVE_QUANTIFIED_CONSTRAINTS 6{-# LANGUAGE QuantifiedConstraints #-} 7#endif 8{-# OPTIONS_GHC -Wall #-} 9 10module Test.QuickCheck.Classes.Generic 11 ( 12#if MIN_VERSION_base(4,5,0) 13 genericLaws 14#if HAVE_UNARY_LAWS 15 , generic1Laws 16#endif 17#endif 18 ) where 19 20#if MIN_VERSION_base(4,5,0) 21import Control.Applicative 22import Data.Semigroup as SG 23import Data.Monoid as MD 24import GHC.Generics 25#if HAVE_UNARY_LAWS 26import Data.Functor.Classes 27#endif 28import Data.Proxy (Proxy(Proxy)) 29import Test.QuickCheck 30import Test.QuickCheck.Property (Property) 31 32import Test.QuickCheck.Classes.Common (Laws(..), Apply(..)) 33 34-- | Tests the following properties: 35-- 36-- [/From-To Inverse/] 37-- @'from' '.' 'to' ≡ 'id'@ 38-- [/To-From Inverse/] 39-- @'to' '.' 'from' ≡ 'id'@ 40-- 41-- /Note:/ This property test is only available when 42-- using @base-4.5@ or newer. 43-- 44-- /Note:/ 'from' and 'to' don't actually care about 45-- the type variable @x@ in @'Rep' a x@, so here we instantiate 46-- it to @'()'@ by default. If you would like to instantiate @x@ 47-- as something else, please file a bug report. 48genericLaws :: (Generic a, Eq a, Arbitrary a, Show a, Show (Rep a ()), Arbitrary (Rep a ()), Eq (Rep a ())) => Proxy a -> Laws 49genericLaws pa = Laws "Generic" 50 [ ("From-To inverse", fromToInverse pa (Proxy :: Proxy ())) 51 , ("To-From inverse", toFromInverse pa) 52 ] 53 54toFromInverse :: forall proxy a. (Generic a, Eq a, Arbitrary a, Show a) => proxy a -> Property 55toFromInverse _ = property $ \(v :: a) -> (to . from $ v) == v 56 57fromToInverse :: 58 forall proxy a x. 59 (Generic a, Show (Rep a x), Arbitrary (Rep a x), Eq (Rep a x)) 60 => proxy a 61 -> proxy x 62 -> Property 63fromToInverse _ _ = property $ \(r :: Rep a x) -> r == (from (to r :: a)) 64 65#if HAVE_UNARY_LAWS 66-- | Tests the following properties: 67-- 68-- [/From-To Inverse/] 69-- @'from1' '.' 'to1' ≡ 'id'@ 70-- [/To-From Inverse/] 71-- @'to1' '.' 'from1' ≡ 'id'@ 72-- 73-- /Note:/ This property test is only available when 74-- using @base-4.9@ or newer. 75generic1Laws :: (Generic1 f, Eq1 f, Arbitrary1 f, Show1 f, Eq1 (Rep1 f), Show1 (Rep1 f), Arbitrary1 (Rep1 f)) 76 => proxy f -> Laws 77generic1Laws p = Laws "Generic1" 78 [ ("From1-To1 inverse", fromToInverse1 p) 79 , ("To1-From1 inverse", toFromInverse1 p) 80 ] 81 82-- hack for quantified constraints: under base >= 4.12, 83-- our usual 'Apply' wrapper has Eq, Show, and Arbitrary 84-- instances that are incompatible. 85newtype GApply f a = GApply { getGApply :: f a } 86 87instance (Applicative f, Semigroup a) => Semigroup (GApply f a) where 88 GApply x <> GApply y = GApply $ liftA2 (SG.<>) x y 89 90instance (Applicative f, Monoid a) => Monoid (GApply f a) where 91 mempty = GApply $ pure mempty 92 mappend (GApply x) (GApply y) = GApply $ liftA2 (MD.<>) x y 93 94instance (Eq1 f, Eq a) => Eq (GApply f a) where 95 GApply a == GApply b = eq1 a b 96 97instance (Show1 f, Show a) => Show (GApply f a) where 98 showsPrec p = showsPrec1 p . getGApply 99 100instance (Arbitrary1 f, Arbitrary a) => Arbitrary (GApply f a) where 101 arbitrary = fmap GApply arbitrary1 102 shrink = map GApply . shrink1 . getGApply 103 104toFromInverse1 :: forall proxy f. (Generic1 f, Eq1 f, Arbitrary1 f, Show1 f) => proxy f -> Property 105toFromInverse1 _ = property $ \(GApply (v :: f Integer)) -> eq1 v (to1 . from1 $ v) 106 107fromToInverse1 :: forall proxy f. (Generic1 f, Eq1 (Rep1 f), Arbitrary1 (Rep1 f), Show1 (Rep1 f)) => proxy f -> Property 108fromToInverse1 _ = property $ \(GApply (r :: Rep1 f Integer)) -> eq1 r (from1 ((to1 $ r) :: f Integer)) 109 110#endif 111 112#endif 113