@@ -1,8 +1,14 @@
1−{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeOperators, DataKinds, TypeFamilies, ScopedTypeVariables#-}
1+#if __GLASGOW_HASKELL__ >= 806
2+{-# OPTIONS_GHC -Wno-star-is-type #-}
3+#endif
4+#if __GLASGOW_HASKELL__ >= 800
5+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
6+#endif
27
3−{- |
8+{-|
49
5−Generic implementation of the 'arbitrary' method. Example usage:
10+This module is a generic implementation of the 'arbitrary' method. Example
11+usage:
612
713@
814data Foo = Foo
@@ -27,45 +33,184 @@ data Foo = Foo
2733
2834The generated 'arbitrary' method is equivalent to
2935
30−@Foo <$> arbitrary <*> arbitrary@.
36+@
37+Foo '<$>' arbitrary '<*>' arbitrary
38+@.
39+
40+It can also handle a recursive types problem. Assuming a type
41+
42+@
43+data R = R R
44+ deriving Generic
45+@
46+
47+there is no instance
48+
49+@
50+instance Arbitrary R where
51+ arbitrary = genericArbitrary
52+ shrink = genericShrink
53+@
54+
55+If you try to compile this you will get a type level error
56+
57+> • R refers to itself in all constructors
58+
59+Which means that there is no finite term for @R@ because it is recursive. But,
60+if you correct the definition of @R@ like this.
61+
62+@
63+data R = R R | F
64+ deriving Generic
65+@
66+
67+Then it will compile. And the @arbitrary@ generated will not hang forever, because
68+it respects the @size@ parameter.
69+
70+There is a limitation of recursion detection:
71+
72+@
73+data R1 = R1 R2
74+ deriving (Eq, Ord, Show, Generic)
75+ deriving anyclass NFData
76+ deriving Arbitrary via (GenericArbitrary R1)
77+
78+data R2 = R2 R1
79+ deriving (Eq, Ord, Show, Generic)
80+ deriving anyclass NFData
81+ deriving Arbitrary via (GenericArbitrary R2)
82+@
83+
84+This code will compile and the @arbitrary@ generated will always hang. Yes,
85+there is a problem with mutually recursive types.
86+
87+Now lets see an example of datatype with parameters
88+
89+@
90+data A a = A a
91+ deriving (Eq, Ord, Show)
92+ deriving anyclass NFData
93+ deriving (Generic)
94+
95+instance (Arbitrary a) => Arbitrary (A a) where
96+ arbitrary = genericArbitrary
97+ shrink = genericShrink
98+@
99+
100+It should work from first glance, but when compile it will throw an error:
101+
102+@
103+ • Could not deduce (Test.QuickCheck.Arbitrary.Generic.GArbitrary
104+ (A a)
105+ (GHC.Generics.D1
106+ ('GHC.Generics.MetaData "A" "ParametersTest" "main" 'False)
107+ (GHC.Generics.C1
108+ ('GHC.Generics.MetaCons "A" 'GHC.Generics.PrefixI 'False)
109+ (GHC.Generics.S1
110+ ('GHC.Generics.MetaSel
111+ 'Nothing
112+ 'GHC.Generics.NoSourceUnpackedness
113+ 'GHC.Generics.NoSourceStrictness
114+ 'GHC.Generics.DecidedLazy)
115+ (GHC.Generics.Rec0 a))))
116+ (TypesDiffer (A a) a))
117+ arising from a use of ‘genericArbitrary’
118+@
119+
120+Here the @TypesDiffer@ is a type familty dealing with recursive types and
121+helping us to eliminate inproper instances. To convince the compiller, that the
122+@a@ parameter is not an @A a@ we must fix the instance with additional constraint
123+
124+@
125+instance (Arg (A a) a, Arbitrary a) => Arbitrary (A a) where
126+ arbitrary = genericArbitrary
127+ shrink = genericShrink
128+@
129+
130+Now everything compiles and works as expected.
31131
32132-}
33133
34134module Test.QuickCheck.Arbitrary.Generic
35− ( GenericArbitrary(..)
36− , Arbitrary(..)
135+ ( -- * Main
136+ genericArbitrary
137+#if MIN_VERSION_QuickCheck(2, 14, 0)
138+ , GenericArbitrary(..)
139+#endif
37140 , Arg
38− , genericArbitrary
141+ -- * Internal
142+ , GArbitrary
143+ , FiniteSum
144+ , FiniteSumElem
145+ , Finite
146+ , AllFieldsFinal
147+ , TypesDiffer
148+ , ArgumentsCount
149+ , SumLen
150+ -- * Reexports
151+ , Arbitrary(..)
39152 , genericShrink
40153 ) where
41154
42155import Control.Applicative
43−import Data.Coerce (coerce)
44156import Data.Proxy
45157import Data.Type.Bool
46158import GHC.Generics as G
47159import GHC.TypeLits
160+import Prelude
48161import Test.QuickCheck as QC
162+#if MIN_VERSION_QuickCheck(2, 14, 0)
163+import Data.Coerce (coerce)
49164import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
50165
166+
167+
168+-- | Newtype for @DerivingVia@
169+--
170+-- Usage:
171+--
172+-- @
173+-- data Foo = Foo
174+-- { _fooX :: X
175+-- , _fooY :: Y
176+-- } deriving (Generic)
177+-- deriving (Arbitrary) via GenericArbitrary Foo
178+-- @
179+--
180+-- @since 1.0.0
51181newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
52182 deriving (Show, Eq)
53183
54184instance
55185 ( Generic a,
56− GArbitrary a (Rep a) 'True,
186+ GArbitrary a (Rep a) some,
57187 RecursivelyShrink (Rep a),
58188 GSubterms (Rep a) a
59189 ) => Arbitrary (GenericArbitrary a) where
60190 arbitrary = coerce (genericArbitrary :: Gen a)
61191 shrink = coerce (genericShrink :: a -> [a])
192+#endif
193+
194+-- | Constraint helper for types with parameters
195+--
196+-- Usage:
197+--
198+-- @
199+-- data A a = A a
200+-- deriving (Generic)
201+-- instance (Arg (A a) a, Arbitrary a) => Arbitrary (A a) where
202+-- arbitrary = genericArbitrary
203+-- shrink = genericShrink
204+-- @
205+--
206+-- @since 1.0.0
207+
208+type Arg self field = (TypesDiffer self field ~ 'True)
62209
63210type family TypesDiffer a b where
64211 TypesDiffer a a = 'False
65212 TypesDiffer a b = 'True
66213
67−type Arg self field = (TypesDiffer self field ~ 'True)
68−
69214type family AllFieldsFinal self (a :: * -> *) :: Bool where
70215 AllFieldsFinal self U1 = 'True
71216 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b
@@ -101,8 +246,8 @@ class (Finite self a ~ finite) => GArbitrary self a (finite :: Bool) where
101246 gArbitrary :: Proxy self -> QC.Gen (a x)
102247
103248instance
104− ( GArbitrary self (C1 c f) 'True
105− ) => GArbitrary self (D1 t (C1 c f)) 'True where
249+ ( GArbitrary self (M1 C c f) 'True
250+ ) => GArbitrary self (M1 D t (M1 C c f)) 'True where
106251 gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)
107252
108253-- | The constructor meta information
@@ -110,7 +255,7 @@ instance
110255 ( GArbitrary self f some
111256 , KnownNat (ArgumentsCount f)
112257 , AllFieldsFinal self f ~ some
113− ) => GArbitrary self (C1 c f) some where
258+ ) => GArbitrary self (M1 C c f) some where
114259 gArbitrary _ = M1 <$> scale predNat (gArbitrary (Proxy :: Proxy self))
115260 where
116261 argumentsCount = fromIntegral $ natVal (Proxy :: Proxy (ArgumentsCount f))
@@ -123,14 +268,14 @@ instance GArbitrary self U1 'True where
123268 gArbitrary _ = pure U1
124269
125270-- | Constructor field meta information
126−instance GArbitrary self f some => GArbitrary self (S1 t f) some where
271+instance GArbitrary self f some => GArbitrary self (M1 S t f) some where
127272 gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)
128273
129274-- | Data of the constructor field
130275instance
131276 ( Arbitrary t
132− , Finite self (Rec0 t) ~ some
133− ) => GArbitrary self (Rec0 t) some where
277+ , Finite self (K1 R t) ~ some
278+ ) => GArbitrary self (K1 R t) some where
134279 gArbitrary _ = K1 <$> arbitrary
135280
136281-- | Product
@@ -146,7 +291,7 @@ instance
146291instance
147292 ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
148293 , AllFieldsFinal self f ~ 'False
149− ) => GArbitrary self (D1 t (C1 c f)) 'False where
294+ ) => GArbitrary self (M1 D t (M1 C c f)) 'False where
150295 gArbitrary _ = error "Unreachable"
151296#endif
152297
@@ -154,7 +299,7 @@ instance
154299instance
155300 ( FiniteSum self a b af bf
156301 , GArbitrary self (a :+: b) 'True
157− ) => GArbitrary self (D1 t (a :+: b)) 'True where
302+ ) => GArbitrary self (M1 D t (a :+: b)) 'True where
158303 gArbitrary _ = sized $ \s -> M1 <$>
159304 if s > 1
160305 then gArbitrary (Proxy :: Proxy self)
@@ -210,8 +355,8 @@ instance
210355 finiteElem _ = finiteSum (Proxy :: Proxy self)
211356
212357instance
213− ( GArbitrary self (C1 c f) 'True
214− ) => FiniteSumElem self (C1 c f) where
358+ ( GArbitrary self (M1 C c f) 'True
359+ ) => FiniteSumElem self (M1 C c f) where
215360 finiteElem _ = [gArbitrary (Proxy :: Proxy self)]
216361
217362
@@ -219,7 +364,7 @@ instance
219364instance
220365 ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
221366 , (Finite self a || Finite self b) ~ 'False
222− ) => GArbitrary self (D1 t (a :+: b)) 'False where
367+ ) => GArbitrary self (M1 D t (a :+: b)) 'False where
223368 gArbitrary _ = error "Unreachable"
224369#endif
225370