@@ -1,8 +1,7 @@
1−{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeOperators, DataKinds, TypeFamilies, ScopedTypeVariables#-}
1+{-|
22
3−{- |
4−
5−Generic implementation of the 'arbitrary' method. Example usage:
3+This module is a generic implementation of the 'arbitrary' method. Example
4+usage:
65
76@
87data Foo = Foo
@@ -27,54 +26,201 @@ data Foo = Foo
2726
2827The generated 'arbitrary' method is equivalent to
2928
30−@Foo <$> arbitrary <*> arbitrary@.
29+@
30+Foo <$> arbitrary <*> arbitrary
31+@.
32+
33+It can also handle a recursive types problem. Assuming a type
34+
35+@
36+data R = R R
37+ deriving Generic
38+@
39+
40+there is no instance
41+
42+@
43+instance Arbitrary R where
44+ arbitrary = genericArbitrary
45+ shrink = genericShrink
46+@
47+
48+If you try to compile this you will get a type level error
49+
50+> • R refers to itself in all constructors
51+
52+Which means that there is no finite term for @R@ because it is recursive. But,
53+if you correct the definition of @R@ like this.
54+
55+@
56+data R = R R | F
57+ deriving Generic
58+@
59+
60+Then it will compile. And the @arbitrary@ generated will not hang forever, because
61+it respects the @size@ parameter.
62+
63+There is a limitation of recursion detection:
64+
65+@
66+data R1 = R1 R2
67+ deriving (Eq, Ord, Show, Generic)
68+ deriving anyclass NFData
69+ deriving Arbitrary via (GenericArbitrary R1)
70+
71+data R2 = R2 R1
72+ deriving (Eq, Ord, Show, Generic)
73+ deriving anyclass NFData
74+ deriving Arbitrary via (GenericArbitrary R2)
75+@
76+
77+This code will compile and the @arbitrary@ generated will always hang. Yes,
78+there is a problem with mutually recursive types.
79+
80+Now lets see an example of datatype with parameters
81+
82+@
83+data A a = A a
84+ deriving (Eq, Ord, Show)
85+ deriving anyclass NFData
86+ deriving (Generic)
87+
88+instance (Arbitrary a) => Arbitrary (A a) where
89+ arbitrary = genericArbitrary
90+ shrink = genericShrink
91+@
92+
93+It should work from first glance, but when compile it will throw an error:
94+
95+@
96+ • Could not deduce (Test.QuickCheck.Arbitrary.Generic.GArbitrary
97+ (A a)
98+ (GHC.Generics.D1
99+ ('GHC.Generics.MetaData "A" "ParametersTest" "main" 'False)
100+ (GHC.Generics.C1
101+ ('GHC.Generics.MetaCons "A" 'GHC.Generics.PrefixI 'False)
102+ (GHC.Generics.S1
103+ ('GHC.Generics.MetaSel
104+ 'Nothing
105+ 'GHC.Generics.NoSourceUnpackedness
106+ 'GHC.Generics.NoSourceStrictness
107+ 'GHC.Generics.DecidedLazy)
108+ (GHC.Generics.Rec0 a))))
109+ (TypesDiffer (A a) a))
110+ arising from a use of ‘genericArbitrary’
111+@
112+
113+Here the @TypesDiffer@ is a type familty dealing with recursive types and
114+helping us to eliminate inproper instances. To convince the compiller, that the
115+@a@ parameter is not an @A a@ we must fix the instance with additional constraint
116+
117+@
118+instance (Arg (A a) a, Arbitrary a) => Arbitrary (A a) where
119+ arbitrary = genericArbitrary
120+ shrink = genericShrink
121+@
122+
123+Now everything compiles and works as expected.
31124
32125-}
33126
34127module Test.QuickCheck.Arbitrary.Generic
35− ( GenericArbitrary(..)
36− , Arbitrary(..)
37− , genericArbitrary
128+ ( -- * Main
129+ genericArbitrary
38130 , genericShrink
131+#if MIN_VERSION_QuickCheck(2, 14, 0)
132+ , GenericArbitrary(..)
133+#endif
134+ , Arg
135+ -- * Internal
136+ , GArbitrary
137+ , FiniteSum
138+ , FiniteSumElem
139+ , Finite
140+ , AllFieldsFinal
141+ , TypesDiffer
142+ , ArgumentsCount
143+ , SumLen
144+ -- * Reexports
145+ , Arbitrary(..)
39146 ) where
40147
41−import Control.Applicative
42−import Data.Coerce (coerce)
43−import Data.Proxy
44−import GHC.Generics as G
45−import GHC.TypeLits
46−import Test.QuickCheck as QC
47−import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
148+import Control.Applicative
149+import Data.Coerce (coerce)
150+import Data.Proxy
151+import Data.Type.Bool
152+import GHC.Generics as G
153+import GHC.TypeLits
154+import Test.QuickCheck as QC
155+#if MIN_VERSION_QuickCheck(2, 14, 0)
156+import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
157+
48158
159+
160+-- | Newtype for @DerivingVia@
161+--
162+-- Usage:
163+--
164+-- @
165+-- data Foo = Foo
166+-- { _fooX :: X
167+-- , _fooY :: Y
168+-- } deriving (Generic)
169+-- deriving (Arbitrary) via GenericArbitrary Foo
170+-- @
171+--
172+-- @since 1.0.0
49173newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
50174 deriving (Show, Eq)
51175
52176instance
53177 ( Generic a,
54− GArbitrary (Rep a),
178+ GArbitrary a (Rep a) some,
55179 RecursivelyShrink (Rep a),
56180 GSubterms (Rep a) a
57181 ) => Arbitrary (GenericArbitrary a) where
58182 arbitrary = coerce (genericArbitrary :: Gen a)
59183 shrink = coerce (genericShrink :: a -> [a])
184+#endif
60185
61−class GArbitrary a where
62− gArbitrary :: QC.Gen (a x)
186+-- | Constraint helper for types with parameters
187+--
188+-- Usage:
189+--
190+-- @
191+-- data A a = A a
192+-- deriving (Generic)
193+-- instance (Arg (A a) a, Arbitrary a) => Arbitrary (A a) where
194+-- arbitrary = genericArbitrary
195+-- shrink = genericShrink
196+-- @
197+--
198+-- @since 1.0.0
63199
64−instance GArbitrary G.U1 where
65− gArbitrary = pure G.U1
200+type Arg self field = (TypesDiffer self field ~ 'True)
66201
67−instance Arbitrary c => GArbitrary (G.K1 i c) where
68− gArbitrary = G.K1 <$> scale predNat arbitrary
69− where
70− predNat 0 = 0
71− predNat n = pred n
202+type family TypesDiffer a b where
203+ TypesDiffer a a = 'False
204+ TypesDiffer a b = 'True
205+
206+type family AllFieldsFinal self (a :: * -> *) :: Bool where
207+ AllFieldsFinal self U1 = 'True
208+ AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b
209+ AllFieldsFinal self (M1 S t (K1 R field)) = TypesDiffer self field
72210
73−instance GArbitrary f => GArbitrary (G.M1 i c f) where
74− gArbitrary = G.M1 <$> gArbitrary
211+type family Finite self (a :: * -> *) :: Bool where
212+ Finite self U1 = 'True
213+ Finite self (K1 R field) = TypesDiffer self field
214+ Finite self (a :*: b) = Finite self a && Finite self b
215+ Finite self (M1 D t f) = Finite self f
216+ Finite self (a :+: b) = Finite self a || Finite self b
217+ Finite self (M1 C c f) = AllFieldsFinal self f
218+ Finite self (M1 S s f) = Finite self f
75219
76−instance (GArbitrary a, GArbitrary b) => GArbitrary (a G.:*: b) where
77− gArbitrary = liftA2 (G.:*:) gArbitrary gArbitrary
220+type family ArgumentsCount (a :: * -> *) :: Nat where
221+ ArgumentsCount U1 = 1
222+ ArgumentsCount (M1 S s f) = 1
223+ ArgumentsCount (a :*: b) = (ArgumentsCount a) + (ArgumentsCount b)
78224
79225-- | Calculates count of constructors encoded by particular ':+:'.
80226-- Internal use only.
@@ -82,14 +228,140 @@ type family SumLen a :: Nat where
82228 SumLen (a G.:+: b) = (SumLen a) + (SumLen b)
83229 SumLen a = 1
84230
85−instance (GArbitrary a, GArbitrary b, KnownNat (SumLen a), KnownNat (SumLen b)
86− ) => GArbitrary (a G.:+: b) where
87− gArbitrary = frequency
88− [ (lfreq, G.L1 <$> gArbitrary)
89− , (rfreq, G.R1 <$> gArbitrary) ]
231+-- | Generic arbitrary.
232+--
233+-- Parameters are:
234+-- * self: the ADT we generating instance for
235+-- * a: some part of the `Rep self`
236+-- * finite: Is `a` finite? Infinite type has no finite values (like Stream)
237+class (Finite self a ~ finite) => GArbitrary self a (finite :: Bool) where
238+ gArbitrary :: Proxy self -> QC.Gen (a x)
239+
240+instance
241+ ( GArbitrary self (M1 C c f) 'True
242+ ) => GArbitrary self (M1 D t (M1 C c f)) 'True where
243+ gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)
244+
245+-- | The constructor meta information
246+instance
247+ ( GArbitrary self f some
248+ , KnownNat (ArgumentsCount f)
249+ , AllFieldsFinal self f ~ some
250+ ) => GArbitrary self (M1 C c f) some where
251+ gArbitrary _ = M1 <$> scale predNat (gArbitrary (Proxy :: Proxy self))
252+ where
253+ argumentsCount = fromIntegral $ natVal (Proxy :: Proxy (ArgumentsCount f))
254+ predNat n = max 0 $ if argumentsCount > 1
255+ then n `div` argumentsCount
256+ else pred n
257+
258+-- | Unit type instance
259+instance GArbitrary self U1 'True where
260+ gArbitrary _ = pure U1
261+
262+-- | Constructor field meta information
263+instance GArbitrary self f some => GArbitrary self (M1 S t f) some where
264+ gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)
265+
266+-- | Data of the constructor field
267+instance
268+ ( Arbitrary t
269+ , Finite self (K1 R t) ~ some
270+ ) => GArbitrary self (K1 R t) some where
271+ gArbitrary _ = K1 <$> arbitrary
272+
273+-- | Product
274+instance
275+ ( GArbitrary self a af
276+ , GArbitrary self b bf
277+ , (af && bf) ~ some
278+ ) => GArbitrary self (a :*: b) some where
279+ gArbitrary _ = liftA2 (:*:)
280+ (gArbitrary (Proxy :: Proxy self)) (gArbitrary (Proxy :: Proxy self))
281+
282+#if __GLASGOW_HASKELL__ >= 800
283+instance
284+ ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
285+ , AllFieldsFinal self f ~ 'False
286+ ) => GArbitrary self (M1 D t (M1 C c f)) 'False where
287+ gArbitrary _ = error "Unreachable"
288+#endif
289+
290+-- | ADT declaration with multiple constructors
291+instance
292+ ( FiniteSum self a b af bf
293+ , GArbitrary self (a :+: b) 'True
294+ ) => GArbitrary self (M1 D t (a :+: b)) 'True where
295+ gArbitrary _ = sized $ \s -> M1 <$>
296+ if s > 1
297+ then gArbitrary (Proxy :: Proxy self)
298+ else oneof (finiteSum (Proxy :: Proxy self))
299+
300+-- | Any sum inside of declaration
301+instance
302+ ( GArbitrary self a af, GArbitrary self b bf
303+ , KnownNat (SumLen a), KnownNat (SumLen b)
304+ , (af || bf) ~ some
305+ ) => GArbitrary self (a :+: b) some where
306+ gArbitrary _ = frequency
307+ [ (lfreq, G.L1 <$> gArbitrary (Proxy :: Proxy self))
308+ , (rfreq, G.R1 <$> gArbitrary (Proxy :: Proxy self)) ]
90309 where
91310 lfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen a))
92311 rfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen b))
93312
94−genericArbitrary :: (Generic a, GArbitrary ga, ga ~ G.Rep a) => Gen a
95−genericArbitrary = G.to <$> gArbitrary
313+class
314+ ( Finite self a ~ af, Finite self b ~ bf
315+ ) => FiniteSum self (a :: * -> *) (b :: * -> *) af bf where
316+ finiteSum :: Proxy self -> [Gen ((a :+: b) p)]
317+
318+instance
319+ ( FiniteSumElem self a, FiniteSumElem self b
320+ , Finite self a ~ 'True
321+ , Finite self b ~ 'True
322+ ) => FiniteSum self a b 'True 'True where
323+ finiteSum _ = concat
324+ [ fmap L1 <$> finiteElem (Proxy :: Proxy self)
325+ , fmap R1 <$> finiteElem (Proxy :: Proxy self)]
326+
327+instance
328+ ( FiniteSumElem self a
329+ , Finite self a ~ 'True
330+ , Finite self b ~ 'False
331+ ) => FiniteSum self a b 'True 'False where
332+ finiteSum _ = fmap L1 <$> finiteElem (Proxy :: Proxy self)
333+
334+instance
335+ ( FiniteSumElem self b
336+ , Finite self a ~ 'False
337+ , Finite self b ~ 'True
338+ ) => FiniteSum self a b 'False 'True where
339+ finiteSum _ = fmap R1 <$> finiteElem (Proxy :: Proxy self)
340+
341+class FiniteSumElem self a where
342+ finiteElem :: Proxy self -> [Gen (a p)]
343+
344+instance
345+ ( FiniteSum self a b af bf
346+ ) => FiniteSumElem self (a :+: b) where
347+ finiteElem _ = finiteSum (Proxy :: Proxy self)
348+
349+instance
350+ ( GArbitrary self (M1 C c f) 'True
351+ ) => FiniteSumElem self (M1 C c f) where
352+ finiteElem _ = [gArbitrary (Proxy :: Proxy self)]
353+
354+
355+#if __GLASGOW_HASKELL__ >= 800
356+instance
357+ ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
358+ , (Finite self a || Finite self b) ~ 'False
359+ ) => GArbitrary self (M1 D t (a :+: b)) 'False where
360+ gArbitrary _ = error "Unreachable"
361+#endif
362+
363+genericArbitrary
364+ :: forall a ga some
365+ . (Generic a, GArbitrary a ga some, ga ~ Rep a)
366+ => Gen a
367+genericArbitrary = G.to <$> gArbitrary (Proxy :: Proxy a)