@@ -1,6 +1,14 @@
1−{- |
1+#if __GLASGOW_HASKELL__ >= 806
2+{-# OPTIONS_GHC -Wno-star-is-type #-}
4+#if __GLASGOW_HASKELL__ >= 800
5+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
3−Generic implementation of the 'arbitrary' method. Example usage:
10+This module is a generic implementation of the 'arbitrary' method. Example
6data Foo = Foo
14data Foo = Foo
@@ -25,54 +33,203 @@ data Foo = Foo
26The generated 'arbitrary' method is equivalent to
34The generated 'arbitrary' method is equivalent to
28−@Foo <$> arbitrary <*> arbitrary@.
37+Foo '<$>' arbitrary '<*>' arbitrary
40+It can also handle a recursive types problem. Assuming a type
50+instance Arbitrary R where
51+ arbitrary = genericArbitrary
52+ shrink = genericShrink
55+If you try to compile this you will get a type level error
57+> • R refers to itself in all constructors
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.
67+Then it will compile. And the @arbitrary@ generated will not hang forever, because
68+it respects the @size@ parameter.
70+There is a limitation of recursion detection:
74+ deriving (Eq, Ord, Show, Generic)
75+ deriving anyclass NFData
76+ deriving Arbitrary via (GenericArbitrary R1)
79+ deriving (Eq, Ord, Show, Generic)
80+ deriving anyclass NFData
81+ deriving Arbitrary via (GenericArbitrary R2)
84+This code will compile and the @arbitrary@ generated will always hang. Yes,
85+there is a problem with mutually recursive types.
87+Now lets see an example of datatype with parameters
91+ deriving (Eq, Ord, Show)
92+ deriving anyclass NFData
95+instance (Arbitrary a) => Arbitrary (A a) where
96+ arbitrary = genericArbitrary
97+ shrink = genericShrink
100+It should work from first glance, but when compile it will throw an error:
103+ • Could not deduce (Test.QuickCheck.Arbitrary.Generic.GArbitrary
106+ ('GHC.Generics.MetaData "A" "ParametersTest" "main" 'False)
108+ ('GHC.Generics.MetaCons "A" 'GHC.Generics.PrefixI 'False)
110+ ('GHC.Generics.MetaSel
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’
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
125+instance (Arg (A a) a, Arbitrary a) => Arbitrary (A a) where
126+ arbitrary = genericArbitrary
127+ shrink = genericShrink
130+Now everything compiles and works as expected.
32module Test.QuickCheck.Arbitrary.Generic
134module Test.QuickCheck.Arbitrary.Generic
137+#if MIN_VERSION_QuickCheck(2, 14, 0)
33− ( GenericArbitrary(..)
138+ , GenericArbitrary(..)
34 , Arbitrary(..)
151 , Arbitrary(..)
36 , genericShrink
152 , genericShrink
39import Control.Applicative
155import Control.Applicative
40−import Data.Coerce (coerce)
41import Data.Proxy
156import Data.Proxy
42import Data.Type.Bool
157import Data.Type.Bool
43import GHC.Generics as G
158import GHC.Generics as G
44import GHC.TypeLits
159import GHC.TypeLits
45import Test.QuickCheck as QC
161import Test.QuickCheck as QC
162+#if MIN_VERSION_QuickCheck(2, 14, 0)
163+import Data.Coerce (coerce)
46import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
164import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
168+-- | Newtype for @DerivingVia@
176+-- } deriving (Generic)
177+-- deriving (Arbitrary) via GenericArbitrary Foo
48newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
181newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
49 deriving (Show, Eq)
182 deriving (Show, Eq)
52 ( Generic a,
185 ( Generic a,
53− GArbitrary a (Rep a) 'True,
186+ GArbitrary a (Rep a) some,
54 RecursivelyShrink (Rep a),
187 RecursivelyShrink (Rep a),
55 GSubterms (Rep a) a
188 GSubterms (Rep a) a
56 ) => Arbitrary (GenericArbitrary a) where
189 ) => Arbitrary (GenericArbitrary a) where
57 arbitrary = coerce (genericArbitrary :: Gen a)
190 arbitrary = coerce (genericArbitrary :: Gen a)
58 shrink = coerce (genericShrink :: a -> [a])
191 shrink = coerce (genericShrink :: a -> [a])
194+-- | Constraint helper for types with parameters
200+-- deriving (Generic)
201+-- instance (Arg (A a) a, Arbitrary a) => Arbitrary (A a) where
202+-- arbitrary = genericArbitrary
203+-- shrink = genericShrink
208+type Arg self field = (TypesDiffer self field ~ 'True)
210+type family TypesDiffer a b where
211+ TypesDiffer a a = 'False
212+ TypesDiffer a b = 'True
60type family AllFieldsFinal self (a :: * -> *) :: Bool where
214type family AllFieldsFinal self (a :: * -> *) :: Bool where
61 AllFieldsFinal self U1 = 'True
215 AllFieldsFinal self U1 = 'True
62 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b
216 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b
63− AllFieldsFinal self (M1 S t (K1 R self)) = 'False
217+ AllFieldsFinal self (M1 S t (K1 R field)) = TypesDiffer self field
64− AllFieldsFinal self (M1 S t (K1 R other)) = 'True
66type family Finite self (a :: * -> *) :: Bool where
219type family Finite self (a :: * -> *) :: Bool where
67 Finite self U1 = 'True
220 Finite self U1 = 'True
68− Finite self (K1 R self) = 'False
221+ Finite self (K1 R field) = TypesDiffer self field
69− Finite self (K1 R other) = 'True
70 Finite self (a :*: b) = Finite self a && Finite self b
222 Finite self (a :*: b) = Finite self a && Finite self b
71 Finite self (M1 D t f) = Finite self f
223 Finite self (M1 D t f) = Finite self f
72 Finite self (a :+: b) = Finite self a || Finite self b
224 Finite self (a :+: b) = Finite self a || Finite self b
73 Finite self (M1 C c f) = AllFieldsFinal self f
225 Finite self (M1 C c f) = AllFieldsFinal self f
74 Finite self (M1 S s f) = Finite self f
226 Finite self (M1 S s f) = Finite self f
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)
76-- | Calculates count of constructors encoded by particular ':+:'.
233-- | Calculates count of constructors encoded by particular ':+:'.
77-- Internal use only.
234-- Internal use only.
78type family SumLen a :: Nat where
235type family SumLen a :: Nat where
@@ -86,37 +243,40 @@ type family SumLen a :: Nat where
86-- * a: some part of the `Rep self`
243-- * a: some part of the `Rep self`
87-- * finite: Is `a` finite? Infinite type has no finite values (like Stream)
244-- * finite: Is `a` finite? Infinite type has no finite values (like Stream)
88class (Finite self a ~ finite) => GArbitrary self a (finite :: Bool) where
245class (Finite self a ~ finite) => GArbitrary self a (finite :: Bool) where
89− gArbitrary :: QC.Gen (a x)
246+ gArbitrary :: Proxy self -> QC.Gen (a x)
92− ( GArbitrary self (C1 c f) 'True
249+ ( GArbitrary self (M1 C c f) 'True
93− ) => GArbitrary self (D1 t (C1 c f)) 'True where
250+ ) => GArbitrary self (M1 D t (M1 C c f)) 'True where
94− gArbitrary = M1 <$> gArbitrary @self
251+ gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)
96-- | The constructor meta information
253-- | The constructor meta information
98 ( GArbitrary self f some
255 ( GArbitrary self f some
256+ , KnownNat (ArgumentsCount f)
99 , AllFieldsFinal self f ~ some
257 , AllFieldsFinal self f ~ some
100− ) => GArbitrary self (C1 c f) some where
258+ ) => GArbitrary self (M1 C c f) some where
101− gArbitrary = M1 <$> scale predNat (gArbitrary @self)
259+ gArbitrary _ = M1 <$> scale predNat (gArbitrary (Proxy :: Proxy self))
261+ argumentsCount = fromIntegral $ natVal (Proxy :: Proxy (ArgumentsCount f))
103− predNat 0 = 0
262+ predNat n = max 0 $ if argumentsCount > 1
263+ then n `div` argumentsCount
104− predNat n = pred n
264+ else pred n
106-- | Unit type instance
266-- | Unit type instance
107instance GArbitrary self U1 'True where
267instance GArbitrary self U1 'True where
108− gArbitrary = pure U1
268+ gArbitrary _ = pure U1
110-- | Constructor field meta information
270-- | Constructor field meta information
111−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
112− gArbitrary = M1 <$> gArbitrary @self
272+ gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)
114-- | Data of the constructor field
274-- | Data of the constructor field
116 ( Arbitrary t
276 ( Arbitrary t
117− , Finite self (Rec0 t) ~ some
277+ , Finite self (K1 R t) ~ some
118− ) => GArbitrary self (Rec0 t) some where
278+ ) => GArbitrary self (K1 R t) some where
119− gArbitrary = K1 <$> arbitrary
279+ gArbitrary _ = K1 <$> arbitrary
121-- | Product
281-- | Product
@@ -124,21 +284,26 @@ instance
124 , GArbitrary self b bf
284 , GArbitrary self b bf
125 , (af && bf) ~ some
285 , (af && bf) ~ some
126 ) => GArbitrary self (a :*: b) some where
286 ) => GArbitrary self (a :*: b) some where
287+ gArbitrary _ = liftA2 (:*:)
127− gArbitrary = liftA2 (:*:) (gArbitrary @self) (gArbitrary @self)
288+ (gArbitrary (Proxy :: Proxy self)) (gArbitrary (Proxy :: Proxy self))
290+#if __GLASGOW_HASKELL__ >= 800
130 ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
292 ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
131 , AllFieldsFinal self f ~ 'False
293 , AllFieldsFinal self f ~ 'False
132− ) => GArbitrary self (D1 t (C1 c f)) 'False where
294+ ) => GArbitrary self (M1 D t (M1 C c f)) 'False where
133− gArbitrary = error "Unreachable"
295+ gArbitrary _ = error "Unreachable"
135-- | ADT declaration with multiple constructors
298-- | ADT declaration with multiple constructors
137 ( FiniteSum self a b af bf
300 ( FiniteSum self a b af bf
138 , GArbitrary self (a :+: b) 'True
301 , GArbitrary self (a :+: b) 'True
139− ) => GArbitrary self (D1 t (a :+: b)) 'True where
302+ ) => GArbitrary self (M1 D t (a :+: b)) 'True where
140− gArbitrary = sized $ \s -> M1 <$>
303+ gArbitrary _ = sized $ \s -> M1 <$>
141− if s > 1 then gArbitrary @self else oneof (finiteSum @self @a @b)
305+ then gArbitrary (Proxy :: Proxy self)
306+ else oneof (finiteSum (Proxy :: Proxy self))
143-- | Any sum inside of declaration
308-- | Any sum inside of declaration
@@ -146,9 +311,9 @@ instance
146 , KnownNat (SumLen a), KnownNat (SumLen b)
311 , KnownNat (SumLen a), KnownNat (SumLen b)
147 , (af || bf) ~ some
312 , (af || bf) ~ some
148 ) => GArbitrary self (a :+: b) some where
313 ) => GArbitrary self (a :+: b) some where
149− gArbitrary = frequency
314+ gArbitrary _ = frequency
150− [ (lfreq, G.L1 <$> gArbitrary @self)
315+ [ (lfreq, G.L1 <$> gArbitrary (Proxy :: Proxy self))
151− , (rfreq, G.R1 <$> gArbitrary @self) ]
316+ , (rfreq, G.R1 <$> gArbitrary (Proxy :: Proxy self)) ]
153 lfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen a))
318 lfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen a))
154 rfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen b))
319 rfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen b))
@@ -156,52 +321,55 @@ instance
157 ( Finite self a ~ af, Finite self b ~ bf
322 ( Finite self a ~ af, Finite self b ~ bf
158 ) => FiniteSum self (a :: * -> *) (b :: * -> *) af bf where
323 ) => FiniteSum self (a :: * -> *) (b :: * -> *) af bf where
159− finiteSum :: [Gen ((a :+: b) p)]
324+ finiteSum :: Proxy self -> [Gen ((a :+: b) p)]
162 ( FiniteSumElem self a, FiniteSumElem self b
327 ( FiniteSumElem self a, FiniteSumElem self b
163 , Finite self a ~ 'True
328 , Finite self a ~ 'True
164 , Finite self b ~ 'True
329 , Finite self b ~ 'True
165 ) => FiniteSum self a b 'True 'True where
330 ) => FiniteSum self a b 'True 'True where
166− finiteSum = concat
331+ finiteSum _ = concat
167− [ fmap L1 <$> finiteElem @self @a
332+ [ fmap L1 <$> finiteElem (Proxy :: Proxy self)
168− , fmap R1 <$> finiteElem @self @b]
333+ , fmap R1 <$> finiteElem (Proxy :: Proxy self)]
171 ( FiniteSumElem self a
336 ( FiniteSumElem self a
172 , Finite self a ~ 'True
337 , Finite self a ~ 'True
173 , Finite self b ~ 'False
338 , Finite self b ~ 'False
174 ) => FiniteSum self a b 'True 'False where
339 ) => FiniteSum self a b 'True 'False where
175− finiteSum = fmap L1 <$> finiteElem @self @a
340+ finiteSum _ = fmap L1 <$> finiteElem (Proxy :: Proxy self)
178 ( FiniteSumElem self b
343 ( FiniteSumElem self b
179 , Finite self a ~ 'False
344 , Finite self a ~ 'False
180 , Finite self b ~ 'True
345 , Finite self b ~ 'True
181 ) => FiniteSum self a b 'False 'True where
346 ) => FiniteSum self a b 'False 'True where
182− finiteSum = fmap R1 <$> finiteElem @self @b
347+ finiteSum _ = fmap R1 <$> finiteElem (Proxy :: Proxy self)
184class FiniteSumElem self a where
349class FiniteSumElem self a where
185− finiteElem :: [Gen (a p)]
350+ finiteElem :: Proxy self -> [Gen (a p)]
188 ( FiniteSum self a b af bf
353 ( FiniteSum self a b af bf
189 ) => FiniteSumElem self (a :+: b) where
354 ) => FiniteSumElem self (a :+: b) where
190− finiteElem = finiteSum @self
355+ finiteElem _ = finiteSum (Proxy :: Proxy self)
193− ( GArbitrary self (C1 c f) 'True
358+ ( GArbitrary self (M1 C c f) 'True
194− ) => FiniteSumElem self (C1 c f) where
359+ ) => FiniteSumElem self (M1 C c f) where
195− finiteElem = [gArbitrary @self]
360+ finiteElem _ = [gArbitrary (Proxy :: Proxy self)]
363+#if __GLASGOW_HASKELL__ >= 800
198 ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
365 ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
199 , (Finite self a || Finite self b) ~ 'False
366 , (Finite self a || Finite self b) ~ 'False
200− ) => GArbitrary self (D1 t (a :+: b)) 'False where
367+ ) => GArbitrary self (M1 D t (a :+: b)) 'False where
201− gArbitrary = error "Unreachable"
368+ gArbitrary _ = error "Unreachable"
203genericArbitrary
371genericArbitrary
204 :: forall a ga some
372 :: forall a ga some
205 . (Generic a, GArbitrary a ga some, ga ~ Rep a)
373 . (Generic a, GArbitrary a ga some, ga ~ Rep a)
207−genericArbitrary = G.to <$> gArbitrary @a
375+genericArbitrary = G.to <$> gArbitrary (Proxy :: Proxy a)