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