@@ -1,8 +1,14 @@
1−{-# LANGUAGE 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
@@ -15,38 +21,214 @@ instance Arbitrary Foo where
1521 shrink = genericShrink
1622@
1723
24+This instance can also be derived using DerivingVia language extension
25+
26+@
27+data Foo = Foo
28+ { _fooX :: X
29+ , _fooY :: Y
30+ } deriving (Generic)
31+ deriving (Arbitrary) via GenericArbitrary Foo
32+@
33+
1834The generated 'arbitrary' method is equivalent to
1935
20−@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.
21131
22132-}
23133
24134module Test.QuickCheck.Arbitrary.Generic
25− ( Arbitrary(..)
26− , genericArbitrary
135+ ( -- * Main
136+ genericArbitrary
137+#if MIN_VERSION_QuickCheck(2, 14, 0)
138+ , GenericArbitrary(..)
139+#endif
140+ , Arg
141+ -- * Internal
142+ , GArbitrary
143+ , FiniteSum
144+ , FiniteSumElem
145+ , Finite
146+ , AllFieldsFinal
147+ , TypesDiffer
148+ , ArgumentsCount
149+ , SumLen
150+ -- * Reexports
151+ , Arbitrary(..)
27152 , genericShrink
28153 ) where
29154
30−import Control.Applicative
31−import Data.Proxy
32−import GHC.Generics as G
33−import GHC.TypeLits
34−import Test.QuickCheck as QC
155+import Control.Applicative
156+import Data.Proxy
157+import Data.Type.Bool
158+import GHC.Generics as G
159+import GHC.TypeLits
160+import Prelude
161+import Test.QuickCheck as QC
162+#if MIN_VERSION_QuickCheck(2, 14, 0)
163+import Data.Coerce (coerce)
164+import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
165+
166+
35167
36−class GArbitrary a where
37− gArbitrary :: QC.Gen (a x)
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
181+newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
182+ deriving (Show, Eq)
38183
39−instance GArbitrary G.U1 where
40− gArbitrary = pure G.U1
184+instance
185+ ( Generic a,
186+ GArbitrary a (Rep a) some,
187+ RecursivelyShrink (Rep a),
188+ GSubterms (Rep a) a
189+ ) => Arbitrary (GenericArbitrary a) where
190+ arbitrary = coerce (genericArbitrary :: Gen a)
191+ shrink = coerce (genericShrink :: a -> [a])
192+#endif
41193
42−instance Arbitrary c => GArbitrary (G.K1 i c) where
43− gArbitrary = G.K1 <$> arbitrary
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
44207
45−instance GArbitrary f => GArbitrary (G.M1 i c f) where
46− gArbitrary = G.M1 <$> gArbitrary
208+type Arg self field = (TypesDiffer self field ~ 'True)
47209
48−instance (GArbitrary a, GArbitrary b) => GArbitrary (a G.:*: b) where
49− gArbitrary = liftA2 (G.:*:) gArbitrary gArbitrary
210+type family TypesDiffer a b where
211+ TypesDiffer a a = 'False
212+ TypesDiffer a b = 'True
213+
214+type family AllFieldsFinal self (a :: * -> *) :: Bool where
215+ AllFieldsFinal self U1 = 'True
216+ AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b
217+ AllFieldsFinal self (M1 S t (K1 R field)) = TypesDiffer self field
218+
219+type family Finite self (a :: * -> *) :: Bool where
220+ Finite self U1 = 'True
221+ Finite self (K1 R field) = TypesDiffer self field
222+ Finite self (a :*: b) = Finite self a && Finite self b
223+ Finite self (M1 D t f) = Finite self f
224+ Finite self (a :+: b) = Finite self a || Finite self b
225+ Finite self (M1 C c f) = AllFieldsFinal self f
226+ Finite self (M1 S s f) = Finite self f
227+
228+type family ArgumentsCount (a :: * -> *) :: Nat where
229+ ArgumentsCount U1 = 1
230+ ArgumentsCount (M1 S s f) = 1
231+ ArgumentsCount (a :*: b) = (ArgumentsCount a) + (ArgumentsCount b)
50232
51233-- | Calculates count of constructors encoded by particular ':+:'.
52234-- Internal use only.
@@ -54,14 +236,140 @@ type family SumLen a :: Nat where
54236 SumLen (a G.:+: b) = (SumLen a) + (SumLen b)
55237 SumLen a = 1
56238
57−instance (GArbitrary a, GArbitrary b, KnownNat (SumLen a), KnownNat (SumLen b)
58− ) => GArbitrary (a G.:+: b) where
59− gArbitrary = frequency
60− [ (lfreq, G.L1 <$> gArbitrary)
61− , (rfreq, G.R1 <$> gArbitrary) ]
239+-- | Generic arbitrary.
240+--
241+-- Parameters are:
242+-- * self: the ADT we generating instance for
243+-- * a: some part of the `Rep self`
244+-- * finite: Is `a` finite? Infinite type has no finite values (like Stream)
245+class (Finite self a ~ finite) => GArbitrary self a (finite :: Bool) where
246+ gArbitrary :: Proxy self -> QC.Gen (a x)
247+
248+instance
249+ ( GArbitrary self (M1 C c f) 'True
250+ ) => GArbitrary self (M1 D t (M1 C c f)) 'True where
251+ gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)
252+
253+-- | The constructor meta information
254+instance
255+ ( GArbitrary self f some
256+ , KnownNat (ArgumentsCount f)
257+ , AllFieldsFinal self f ~ some
258+ ) => GArbitrary self (M1 C c f) some where
259+ gArbitrary _ = M1 <$> scale predNat (gArbitrary (Proxy :: Proxy self))
260+ where
261+ argumentsCount = fromIntegral $ natVal (Proxy :: Proxy (ArgumentsCount f))
262+ predNat n = max 0 $ if argumentsCount > 1
263+ then n `div` argumentsCount
264+ else pred n
265+
266+-- | Unit type instance
267+instance GArbitrary self U1 'True where
268+ gArbitrary _ = pure U1
269+
270+-- | Constructor field meta information
271+instance GArbitrary self f some => GArbitrary self (M1 S t f) some where
272+ gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)
273+
274+-- | Data of the constructor field
275+instance
276+ ( Arbitrary t
277+ , Finite self (K1 R t) ~ some
278+ ) => GArbitrary self (K1 R t) some where
279+ gArbitrary _ = K1 <$> arbitrary
280+
281+-- | Product
282+instance
283+ ( GArbitrary self a af
284+ , GArbitrary self b bf
285+ , (af && bf) ~ some
286+ ) => GArbitrary self (a :*: b) some where
287+ gArbitrary _ = liftA2 (:*:)
288+ (gArbitrary (Proxy :: Proxy self)) (gArbitrary (Proxy :: Proxy self))
289+
290+#if __GLASGOW_HASKELL__ >= 800
291+instance
292+ ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
293+ , AllFieldsFinal self f ~ 'False
294+ ) => GArbitrary self (M1 D t (M1 C c f)) 'False where
295+ gArbitrary _ = error "Unreachable"
296+#endif
297+
298+-- | ADT declaration with multiple constructors
299+instance
300+ ( FiniteSum self a b af bf
301+ , GArbitrary self (a :+: b) 'True
302+ ) => GArbitrary self (M1 D t (a :+: b)) 'True where
303+ gArbitrary _ = sized $ \s -> M1 <$>
304+ if s > 1
305+ then gArbitrary (Proxy :: Proxy self)
306+ else oneof (finiteSum (Proxy :: Proxy self))
307+
308+-- | Any sum inside of declaration
309+instance
310+ ( GArbitrary self a af, GArbitrary self b bf
311+ , KnownNat (SumLen a), KnownNat (SumLen b)
312+ , (af || bf) ~ some
313+ ) => GArbitrary self (a :+: b) some where
314+ gArbitrary _ = frequency
315+ [ (lfreq, G.L1 <$> gArbitrary (Proxy :: Proxy self))
316+ , (rfreq, G.R1 <$> gArbitrary (Proxy :: Proxy self)) ]
62317 where
63318 lfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen a))
64319 rfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen b))
65320
66−genericArbitrary :: (Generic a, GArbitrary ga, ga ~ G.Rep a) => Gen a
67−genericArbitrary = G.to <$> gArbitrary
321+class
322+ ( Finite self a ~ af, Finite self b ~ bf
323+ ) => FiniteSum self (a :: * -> *) (b :: * -> *) af bf where
324+ finiteSum :: Proxy self -> [Gen ((a :+: b) p)]
325+
326+instance
327+ ( FiniteSumElem self a, FiniteSumElem self b
328+ , Finite self a ~ 'True
329+ , Finite self b ~ 'True
330+ ) => FiniteSum self a b 'True 'True where
331+ finiteSum _ = concat
332+ [ fmap L1 <$> finiteElem (Proxy :: Proxy self)
333+ , fmap R1 <$> finiteElem (Proxy :: Proxy self)]
334+
335+instance
336+ ( FiniteSumElem self a
337+ , Finite self a ~ 'True
338+ , Finite self b ~ 'False
339+ ) => FiniteSum self a b 'True 'False where
340+ finiteSum _ = fmap L1 <$> finiteElem (Proxy :: Proxy self)
341+
342+instance
343+ ( FiniteSumElem self b
344+ , Finite self a ~ 'False
345+ , Finite self b ~ 'True
346+ ) => FiniteSum self a b 'False 'True where
347+ finiteSum _ = fmap R1 <$> finiteElem (Proxy :: Proxy self)
348+
349+class FiniteSumElem self a where
350+ finiteElem :: Proxy self -> [Gen (a p)]
351+
352+instance
353+ ( FiniteSum self a b af bf
354+ ) => FiniteSumElem self (a :+: b) where
355+ finiteElem _ = finiteSum (Proxy :: Proxy self)
356+
357+instance
358+ ( GArbitrary self (M1 C c f) 'True
359+ ) => FiniteSumElem self (M1 C c f) where
360+ finiteElem _ = [gArbitrary (Proxy :: Proxy self)]
361+
362+
363+#if __GLASGOW_HASKELL__ >= 800
364+instance
365+ ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
366+ , (Finite self a || Finite self b) ~ 'False
367+ ) => GArbitrary self (M1 D t (a :+: b)) 'False where
368+ gArbitrary _ = error "Unreachable"
369+#endif
370+
371+genericArbitrary
372+ :: forall a ga some
373+ . (Generic a, GArbitrary a ga some, ga ~ Rep a)
374+ => Gen a
375+genericArbitrary = G.to <$> gArbitrary (Proxy :: Proxy a)