@@ -1,14 +1,8 @@
1−#if __GLASGOW_HASKELL__ >= 806
1+{-# LANGUAGE UndecidableInstances, TypeOperators, DataKinds, TypeFamilies, ScopedTypeVariables#-}
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
5+Generic implementation of the 'arbitrary' method. Example usage:
14data Foo = Foo
8data Foo = Foo
@@ -33,202 +27,54 @@ data Foo = Foo
34The generated 'arbitrary' method is equivalent to
28The generated 'arbitrary' method is equivalent to
37−Foo '<$>' arbitrary '<*>' arbitrary
30+@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
34module Test.QuickCheck.Arbitrary.Generic
137−#if MIN_VERSION_QuickCheck(2, 14, 0)
138− , GenericArbitrary(..)
35+ ( GenericArbitrary(..)
151 , Arbitrary(..)
36 , Arbitrary(..)
152 , genericShrink
38 , genericShrink
155−import Control.Applicative
41+import Control.Applicative
42+import Data.Coerce (coerce)
156−import Data.Proxy
43+import Data.Proxy
157−import Data.Type.Bool
158−import GHC.Generics as G
44+import GHC.Generics as G
159−import GHC.TypeLits
45+import GHC.TypeLits
161−import Test.QuickCheck as QC
46+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)
47+import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
168−-- | Newtype for @DerivingVia@
176−-- } deriving (Generic)
177−-- deriving (Arbitrary) via GenericArbitrary Foo
181newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
49newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
182 deriving (Show, Eq)
50 deriving (Show, Eq)
185 ( Generic a,
53 ( Generic a,
186− GArbitrary a (Rep a) some,
54+ GArbitrary (Rep a),
187 RecursivelyShrink (Rep a),
55 RecursivelyShrink (Rep a),
188 GSubterms (Rep a) a
56 GSubterms (Rep a) a
189 ) => Arbitrary (GenericArbitrary a) where
57 ) => Arbitrary (GenericArbitrary a) where
190 arbitrary = coerce (genericArbitrary :: Gen a)
58 arbitrary = coerce (genericArbitrary :: Gen a)
191 shrink = coerce (genericShrink :: a -> [a])
59 shrink = coerce (genericShrink :: a -> [a])
194−-- | Constraint helper for types with parameters
61+class GArbitrary a where
195−--
62+ gArbitrary :: QC.Gen (a x)
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)
64+instance GArbitrary G.U1 where
65+ gArbitrary = pure G.U1
210−type family TypesDiffer a b where
67+instance Arbitrary c => GArbitrary (G.K1 i c) where
211− TypesDiffer a a = 'False
68+ gArbitrary = G.K1 <$> scale predNat arbitrary
212− TypesDiffer a b = 'True
69+ where
214−type family AllFieldsFinal self (a :: * -> *) :: Bool where
71+ predNat n = pred n
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
219−type family Finite self (a :: * -> *) :: Bool where
73+instance GArbitrary f => GArbitrary (G.M1 i c f) where
220− Finite self U1 = 'True
74+ gArbitrary = G.M1 <$> gArbitrary
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
228−type family ArgumentsCount (a :: * -> *) :: Nat where
76+instance (GArbitrary a, GArbitrary b) => GArbitrary (a G.:*: b) where
229− ArgumentsCount U1 = 1
77+ gArbitrary = liftA2 (G.:*:) gArbitrary gArbitrary
230− ArgumentsCount (M1 S s f) = 1
231− ArgumentsCount (a :*: b) = (ArgumentsCount a) + (ArgumentsCount b)
233-- | Calculates count of constructors encoded by particular ':+:'.
79-- | Calculates count of constructors encoded by particular ':+:'.
234-- Internal use only.
80-- Internal use only.
@@ -236,140 +82,14 @@ type family SumLen a :: Nat where
236 SumLen (a G.:+: b) = (SumLen a) + (SumLen b)
82 SumLen (a G.:+: b) = (SumLen a) + (SumLen b)
237 SumLen a = 1
83 SumLen a = 1
239−-- | Generic arbitrary.
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)
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)
253−-- | The constructor meta information
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))
261− argumentsCount = fromIntegral $ natVal (Proxy :: Proxy (ArgumentsCount f))
262− predNat n = max 0 $ if argumentsCount > 1
263− then n `div` argumentsCount
266−-- | Unit type instance
267−instance GArbitrary self U1 'True where
268− gArbitrary _ = pure U1
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)
274−-- | Data of the constructor field
277− , Finite self (K1 R t) ~ some
278− ) => GArbitrary self (K1 R t) some where
279− gArbitrary _ = K1 <$> arbitrary
283− ( GArbitrary self a af
284− , GArbitrary self b bf
286− ) => GArbitrary self (a :*: b) some where
287− gArbitrary _ = liftA2 (:*:)
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")
293− , AllFieldsFinal self f ~ 'False
294− ) => GArbitrary self (M1 D t (M1 C c f)) 'False where
295− gArbitrary _ = error "Unreachable"
298−-- | ADT declaration with multiple constructors
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 <$>
305− then gArbitrary (Proxy :: Proxy self)
306− else oneof (finiteSum (Proxy :: Proxy self))
308−-- | Any sum inside of declaration
310− ( GArbitrary self a af, GArbitrary self b bf
311− , KnownNat (SumLen a), KnownNat (SumLen b)
85+instance (GArbitrary a, GArbitrary b, KnownNat (SumLen a), KnownNat (SumLen b)
313− ) => GArbitrary self (a :+: b) some where
86+ ) => GArbitrary (a G.:+: b) where
314− gArbitrary _ = frequency
87+ gArbitrary = frequency
315− [ (lfreq, G.L1 <$> gArbitrary (Proxy :: Proxy self))
88+ [ (lfreq, G.L1 <$> gArbitrary)
316− , (rfreq, G.R1 <$> gArbitrary (Proxy :: Proxy self)) ]
89+ , (rfreq, G.R1 <$> gArbitrary) ]
318 lfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen a))
91 lfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen a))
319 rfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen b))
92 rfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen b))
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)]
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)]
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)
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)
349−class FiniteSumElem self a where
350− finiteElem :: Proxy self -> [Gen (a p)]
353− ( FiniteSum self a b af bf
354− ) => FiniteSumElem self (a :+: b) where
355− finiteElem _ = finiteSum (Proxy :: Proxy self)
358− ( GArbitrary self (M1 C c f) 'True
359− ) => FiniteSumElem self (M1 C c f) where
360− finiteElem _ = [gArbitrary (Proxy :: Proxy self)]
363−#if __GLASGOW_HASKELL__ >= 800
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"
373− . (Generic a, GArbitrary a ga some, ga ~ Rep a)
94+genericArbitrary :: (Generic a, GArbitrary ga, ga ~ G.Rep a) => Gen a
375−genericArbitrary = G.to <$> gArbitrary (Proxy :: Proxy a)
95+genericArbitrary = G.to <$> gArbitrary