@@ -1,14 +1,6 @@
1−#if __GLASGOW_HASKELL__ >= 806
1+{- |
2−{-# OPTIONS_GHC -Wno-star-is-type #-}
4−#if __GLASGOW_HASKELL__ >= 800
5−{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
10−This module is a generic implementation of the 'arbitrary' method. Example
3+Generic implementation of the 'arbitrary' method. Example usage:
14data Foo = Foo
6data Foo = Foo
@@ -33,192 +25,48 @@ data Foo = Foo
34The generated 'arbitrary' method is equivalent to
26The generated 'arbitrary' method is equivalent to
37−Foo '<$>' arbitrary '<*>' arbitrary
28+@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.
134module Test.QuickCheck.Arbitrary.Generic
32module Test.QuickCheck.Arbitrary.Generic
137−#if MIN_VERSION_QuickCheck(2, 14, 0)
138− , GenericArbitrary(..)
33+ ( GenericArbitrary(..)
151 , Arbitrary(..)
34 , Arbitrary(..)
152 , genericShrink
36 , genericShrink
155import Control.Applicative
39import Control.Applicative
40+import Data.Coerce (coerce)
156import Data.Proxy
41import Data.Proxy
157import Data.Type.Bool
42import Data.Type.Bool
158import GHC.Generics as G
43import GHC.Generics as G
159import GHC.TypeLits
44import GHC.TypeLits
161import Test.QuickCheck as QC
45import Test.QuickCheck as QC
162−#if MIN_VERSION_QuickCheck(2, 14, 0)
163−import Data.Coerce (coerce)
164import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
46import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
168−-- | Newtype for @DerivingVia@
176−-- } deriving (Generic)
177−-- deriving (Arbitrary) via GenericArbitrary Foo
181newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
48newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
182 deriving (Show, Eq)
49 deriving (Show, Eq)
185 ( Generic a,
52 ( Generic a,
186− GArbitrary a (Rep a) some,
53+ GArbitrary a (Rep a) 'True,
187 RecursivelyShrink (Rep a),
54 RecursivelyShrink (Rep a),
188 GSubterms (Rep a) a
55 GSubterms (Rep a) a
189 ) => Arbitrary (GenericArbitrary a) where
56 ) => Arbitrary (GenericArbitrary a) where
190 arbitrary = coerce (genericArbitrary :: Gen a)
57 arbitrary = coerce (genericArbitrary :: Gen a)
191 shrink = coerce (genericShrink :: a -> [a])
58 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
214type family AllFieldsFinal self (a :: * -> *) :: Bool where
60type family AllFieldsFinal self (a :: * -> *) :: Bool where
215 AllFieldsFinal self U1 = 'True
61 AllFieldsFinal self U1 = 'True
216 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b
62 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b
217− AllFieldsFinal self (M1 S t (K1 R field)) = TypesDiffer self field
63+ AllFieldsFinal self (M1 S t (K1 R self)) = 'False
64+ AllFieldsFinal self (M1 S t (K1 R other)) = 'True
219type family Finite self (a :: * -> *) :: Bool where
66type family Finite self (a :: * -> *) :: Bool where
220 Finite self U1 = 'True
67 Finite self U1 = 'True
221− Finite self (K1 R field) = TypesDiffer self field
68+ Finite self (K1 R self) = 'False
69+ Finite self (K1 R other) = 'True
222 Finite self (a :*: b) = Finite self a && Finite self b
70 Finite self (a :*: b) = Finite self a && Finite self b
223 Finite self (M1 D t f) = Finite self f
71 Finite self (M1 D t f) = Finite self f
224 Finite self (a :+: b) = Finite self a || Finite self b
72 Finite self (a :+: b) = Finite self a || Finite self b
@@ -243,40 +91,40 @@ type family SumLen a :: Nat where
243-- * a: some part of the `Rep self`
91-- * a: some part of the `Rep self`
244-- * finite: Is `a` finite? Infinite type has no finite values (like Stream)
92-- * finite: Is `a` finite? Infinite type has no finite values (like Stream)
245class (Finite self a ~ finite) => GArbitrary self a (finite :: Bool) where
93class (Finite self a ~ finite) => GArbitrary self a (finite :: Bool) where
246− gArbitrary :: Proxy self -> QC.Gen (a x)
94+ gArbitrary :: QC.Gen (a x)
249− ( GArbitrary self (M1 C c f) 'True
97+ ( GArbitrary self (C1 c f) 'True
250− ) => GArbitrary self (M1 D t (M1 C c f)) 'True where
98+ ) => GArbitrary self (D1 t (C1 c f)) 'True where
251− gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)
99+ gArbitrary = M1 <$> gArbitrary @self
253-- | The constructor meta information
101-- | The constructor meta information
255 ( GArbitrary self f some
103 ( GArbitrary self f some
256 , KnownNat (ArgumentsCount f)
104 , KnownNat (ArgumentsCount f)
257 , AllFieldsFinal self f ~ some
105 , AllFieldsFinal self f ~ some
258− ) => GArbitrary self (M1 C c f) some where
106+ ) => GArbitrary self (C1 c f) some where
259− gArbitrary _ = M1 <$> scale predNat (gArbitrary (Proxy :: Proxy self))
107+ gArbitrary = M1 <$> scale predNat (gArbitrary @self)
261− argumentsCount = fromIntegral $ natVal (Proxy :: Proxy (ArgumentsCount f))
109+ argumentsCount = fromIntegral $ natVal (Proxy @(ArgumentsCount f))
262 predNat n = max 0 $ if argumentsCount > 1
110 predNat n = max 0 $ if argumentsCount > 1
263 then n `div` argumentsCount
111 then n `div` argumentsCount
264 else pred n
112 else pred n
266-- | Unit type instance
114-- | Unit type instance
267instance GArbitrary self U1 'True where
115instance GArbitrary self U1 'True where
268− gArbitrary _ = pure U1
116+ gArbitrary = pure U1
270-- | Constructor field meta information
118-- | Constructor field meta information
271−instance GArbitrary self f some => GArbitrary self (M1 S t f) some where
119+instance GArbitrary self f some => GArbitrary self (S1 t f) some where
272− gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)
120+ gArbitrary = M1 <$> gArbitrary @self
274-- | Data of the constructor field
122-- | Data of the constructor field
276 ( Arbitrary t
124 ( Arbitrary t
277− , Finite self (K1 R t) ~ some
125+ , Finite self (Rec0 t) ~ some
278− ) => GArbitrary self (K1 R t) some where
126+ ) => GArbitrary self (Rec0 t) some where
279− gArbitrary _ = K1 <$> arbitrary
127+ gArbitrary = K1 <$> arbitrary
281-- | Product
129-- | Product
@@ -284,26 +132,21 @@ instance
284 , GArbitrary self b bf
132 , GArbitrary self b bf
285 , (af && bf) ~ some
133 , (af && bf) ~ some
286 ) => GArbitrary self (a :*: b) some where
134 ) => GArbitrary self (a :*: b) some where
287− gArbitrary _ = liftA2 (:*:)
135+ gArbitrary = liftA2 (:*:) (gArbitrary @self) (gArbitrary @self)
288− (gArbitrary (Proxy :: Proxy self)) (gArbitrary (Proxy :: Proxy self))
290−#if __GLASGOW_HASKELL__ >= 800
292 ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
138 ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
293 , AllFieldsFinal self f ~ 'False
139 , AllFieldsFinal self f ~ 'False
294− ) => GArbitrary self (M1 D t (M1 C c f)) 'False where
140+ ) => GArbitrary self (D1 t (C1 c f)) 'False where
295− gArbitrary _ = error "Unreachable"
141+ gArbitrary = error "Unreachable"
298-- | ADT declaration with multiple constructors
143-- | ADT declaration with multiple constructors
300 ( FiniteSum self a b af bf
145 ( FiniteSum self a b af bf
301 , GArbitrary self (a :+: b) 'True
146 , GArbitrary self (a :+: b) 'True
302− ) => GArbitrary self (M1 D t (a :+: b)) 'True where
147+ ) => GArbitrary self (D1 t (a :+: b)) 'True where
303− gArbitrary _ = sized $ \s -> M1 <$>
148+ gArbitrary = sized $ \s -> M1 <$>
305− then gArbitrary (Proxy :: Proxy self)
306− else oneof (finiteSum (Proxy :: Proxy self))
149+ if s > 1 then gArbitrary @self else oneof (finiteSum @self @a @b)
308-- | Any sum inside of declaration
151-- | Any sum inside of declaration
@@ -311,9 +154,9 @@ instance
311 , KnownNat (SumLen a), KnownNat (SumLen b)
154 , KnownNat (SumLen a), KnownNat (SumLen b)
312 , (af || bf) ~ some
155 , (af || bf) ~ some
313 ) => GArbitrary self (a :+: b) some where
156 ) => GArbitrary self (a :+: b) some where
314− gArbitrary _ = frequency
157+ gArbitrary = frequency
315− [ (lfreq, G.L1 <$> gArbitrary (Proxy :: Proxy self))
158+ [ (lfreq, G.L1 <$> gArbitrary @self)
316− , (rfreq, G.R1 <$> gArbitrary (Proxy :: Proxy self)) ]
159+ , (rfreq, G.R1 <$> gArbitrary @self) ]
318 lfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen a))
161 lfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen a))
319 rfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen b))
162 rfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen b))
@@ -321,55 +164,52 @@ instance
322 ( Finite self a ~ af, Finite self b ~ bf
165 ( Finite self a ~ af, Finite self b ~ bf
323 ) => FiniteSum self (a :: * -> *) (b :: * -> *) af bf where
166 ) => FiniteSum self (a :: * -> *) (b :: * -> *) af bf where
324− finiteSum :: Proxy self -> [Gen ((a :+: b) p)]
167+ finiteSum :: [Gen ((a :+: b) p)]
327 ( FiniteSumElem self a, FiniteSumElem self b
170 ( FiniteSumElem self a, FiniteSumElem self b
328 , Finite self a ~ 'True
171 , Finite self a ~ 'True
329 , Finite self b ~ 'True
172 , Finite self b ~ 'True
330 ) => FiniteSum self a b 'True 'True where
173 ) => FiniteSum self a b 'True 'True where
331− finiteSum _ = concat
174+ finiteSum = concat
332− [ fmap L1 <$> finiteElem (Proxy :: Proxy self)
175+ [ fmap L1 <$> finiteElem @self @a
333− , fmap R1 <$> finiteElem (Proxy :: Proxy self)]
176+ , fmap R1 <$> finiteElem @self @b]
336 ( FiniteSumElem self a
179 ( FiniteSumElem self a
337 , Finite self a ~ 'True
180 , Finite self a ~ 'True
338 , Finite self b ~ 'False
181 , Finite self b ~ 'False
339 ) => FiniteSum self a b 'True 'False where
182 ) => FiniteSum self a b 'True 'False where
340− finiteSum _ = fmap L1 <$> finiteElem (Proxy :: Proxy self)
183+ finiteSum = fmap L1 <$> finiteElem @self @a
343 ( FiniteSumElem self b
186 ( FiniteSumElem self b
344 , Finite self a ~ 'False
187 , Finite self a ~ 'False
345 , Finite self b ~ 'True
188 , Finite self b ~ 'True
346 ) => FiniteSum self a b 'False 'True where
189 ) => FiniteSum self a b 'False 'True where
347− finiteSum _ = fmap R1 <$> finiteElem (Proxy :: Proxy self)
190+ finiteSum = fmap R1 <$> finiteElem @self @b
349class FiniteSumElem self a where
192class FiniteSumElem self a where
350− finiteElem :: Proxy self -> [Gen (a p)]
193+ finiteElem :: [Gen (a p)]
353 ( FiniteSum self a b af bf
196 ( FiniteSum self a b af bf
354 ) => FiniteSumElem self (a :+: b) where
197 ) => FiniteSumElem self (a :+: b) where
355− finiteElem _ = finiteSum (Proxy :: Proxy self)
198+ finiteElem = finiteSum @self
358− ( GArbitrary self (M1 C c f) 'True
201+ ( GArbitrary self (C1 c f) 'True
359− ) => FiniteSumElem self (M1 C c f) where
202+ ) => FiniteSumElem self (C1 c f) where
360− finiteElem _ = [gArbitrary (Proxy :: Proxy self)]
203+ finiteElem = [gArbitrary @self]
363−#if __GLASGOW_HASKELL__ >= 800
365 ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
206 ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
366 , (Finite self a || Finite self b) ~ 'False
207 , (Finite self a || Finite self b) ~ 'False
367− ) => GArbitrary self (M1 D t (a :+: b)) 'False where
208+ ) => GArbitrary self (D1 t (a :+: b)) 'False where
368− gArbitrary _ = error "Unreachable"
209+ gArbitrary = error "Unreachable"
371genericArbitrary
211genericArbitrary
372 :: forall a ga some
212 :: forall a ga some
373 . (Generic a, GArbitrary a ga some, ga ~ Rep a)
213 . (Generic a, GArbitrary a ga some, ga ~ Rep a)
375−genericArbitrary = G.to <$> gArbitrary (Proxy :: Proxy a)
215+genericArbitrary = G.to <$> gArbitrary @a