@@ -1,14 +1,6 @@
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
1+{- |
72
8−{-|
9−
10−This module is a generic implementation of the 'arbitrary' method. Example
11−usage:
3+Generic implementation of the 'arbitrary' method. Example usage:
124
135@
146data Foo = Foo
@@ -33,203 +25,57 @@ data Foo = Foo
3325
3426The generated 'arbitrary' method is equivalent to
3527
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.
28+@Foo <$> arbitrary <*> arbitrary@.
13129
13230-}
13331
13432module Test.QuickCheck.Arbitrary.Generic
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
33+ ( GenericArbitrary(..)
15134 , Arbitrary(..)
35+ , genericArbitrary
15236 , genericShrink
15337 ) where
15438
15539import Control.Applicative
40+import Data.Coerce (coerce)
15641import Data.Proxy
15742import Data.Type.Bool
15843import GHC.Generics as G
15944import GHC.TypeLits
160−import Prelude
16145import Test.QuickCheck as QC
162−#if MIN_VERSION_QuickCheck(2, 14, 0)
163−import Data.Coerce (coerce)
16446import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
47+import TypeFun.Data.Eq
48+import TypeFun.Data.List
16549
166−
167−
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
18150newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
18251 deriving (Show, Eq)
18352
18453instance
18554 ( Generic a,
186− GArbitrary a (Rep a) some,
55+ GArbitrary a (Rep a) 'True,
18756 RecursivelyShrink (Rep a),
18857 GSubterms (Rep a) a
18958 ) => Arbitrary (GenericArbitrary a) where
19059 arbitrary = coerce (genericArbitrary :: Gen a)
19160 shrink = coerce (genericShrink :: a -> [a])
192−#endif
193−
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
207−
208−type Arg self field = (TypesDiffer self field ~ 'True)
209−
210−type family TypesDiffer a b where
211− TypesDiffer a a = 'False
212− TypesDiffer a b = 'True
21361
21462type family AllFieldsFinal self (a :: * -> *) :: Bool where
21563 AllFieldsFinal self U1 = 'True
21664 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b
217− AllFieldsFinal self (M1 S t (K1 R field)) = TypesDiffer self field
65+ AllFieldsFinal self (M1 S t (K1 R self)) = 'False
66+ AllFieldsFinal self (M1 S t (K1 R other)) = 'True
21867
21968type family Finite self (a :: * -> *) :: Bool where
22069 Finite self U1 = 'True
221− Finite self (K1 R field) = TypesDiffer self field
70+ -- | The constructor field is the ADT itself. Not finite.
71+ Finite self (K1 R self) = 'False
72+ Finite self (K1 R other) = 'True
22273 Finite self (a :*: b) = Finite self a && Finite self b
22374 Finite self (M1 D t f) = Finite self f
22475 Finite self (a :+: b) = Finite self a || Finite self b
22576 Finite self (M1 C c f) = AllFieldsFinal self f
22677 Finite self (M1 S s f) = Finite self f
22778
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)
232−
23379-- | Calculates count of constructors encoded by particular ':+:'.
23480-- Internal use only.
23581type family SumLen a :: Nat where
@@ -243,40 +89,37 @@ type family SumLen a :: Nat where
24389-- * a: some part of the `Rep self`
24490-- * finite: Is `a` finite? Infinite type has no finite values (like Stream)
24591class (Finite self a ~ finite) => GArbitrary self a (finite :: Bool) where
246− gArbitrary :: Proxy self -> QC.Gen (a x)
92+ gArbitrary :: QC.Gen (a x)
24793
24894instance
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)
95+ ( GArbitrary self (C1 c f) 'True
96+ ) => GArbitrary self (D1 t (C1 c f)) 'True where
97+ gArbitrary = M1 <$> gArbitrary @self
25298
25399-- | The constructor meta information
254100instance
255101 ( GArbitrary self f some
256− , KnownNat (ArgumentsCount f)
257102 , AllFieldsFinal self f ~ some
258− ) => GArbitrary self (M1 C c f) some where
259− gArbitrary _ = M1 <$> scale predNat (gArbitrary (Proxy :: Proxy self))
103+ ) => GArbitrary self (C1 c f) some where
104+ gArbitrary = M1 <$> scale predNat (gArbitrary @self)
260105 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
106+ predNat 0 = 0
107+ predNat n = pred n
265108
266109-- | Unit type instance
267110instance GArbitrary self U1 'True where
268− gArbitrary _ = pure U1
111+ gArbitrary = pure U1
269112
270113-- | 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)
114+instance GArbitrary self f some => GArbitrary self (S1 t f) some where
115+ gArbitrary = M1 <$> gArbitrary @self
273116
274117-- | Data of the constructor field
275118instance
276119 ( Arbitrary t
277− , Finite self (K1 R t) ~ some
278− ) => GArbitrary self (K1 R t) some where
279− gArbitrary _ = K1 <$> arbitrary
120+ , Finite self (Rec0 t) ~ some
121+ ) => GArbitrary self (Rec0 t) some where
122+ gArbitrary = K1 <$> arbitrary
280123
281124-- | Product
282125instance
@@ -284,26 +127,21 @@ instance
284127 , GArbitrary self b bf
285128 , (af && bf) ~ some
286129 ) => GArbitrary self (a :*: b) some where
287− gArbitrary _ = liftA2 (:*:)
288− (gArbitrary (Proxy :: Proxy self)) (gArbitrary (Proxy :: Proxy self))
130+ gArbitrary = liftA2 (:*:) (gArbitrary @self) (gArbitrary @self)
289131
290−#if __GLASGOW_HASKELL__ >= 800
291132instance
292133 ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
293134 , AllFieldsFinal self f ~ 'False
294− ) => GArbitrary self (M1 D t (M1 C c f)) 'False where
295− gArbitrary _ = error "Unreachable"
296−#endif
135+ ) => GArbitrary self (D1 t (C1 c f)) 'False where
136+ gArbitrary = error "Unreachable"
297137
298138-- | ADT declaration with multiple constructors
299139instance
300140 ( FiniteSum self a b af bf
301141 , 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))
142+ ) => GArbitrary self (D1 t (a :+: b)) 'True where
143+ gArbitrary = sized $ \s -> M1 <$>
144+ if s > 1 then gArbitrary @self else oneof (finiteSum @self @a @b)
307145
308146-- | Any sum inside of declaration
309147instance
@@ -311,9 +149,9 @@ instance
311149 , KnownNat (SumLen a), KnownNat (SumLen b)
312150 , (af || bf) ~ some
313151 ) => 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)) ]
152+ gArbitrary = frequency
153+ [ (lfreq, G.L1 <$> gArbitrary @self)
154+ , (rfreq, G.R1 <$> gArbitrary @self) ]
317155 where
318156 lfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen a))
319157 rfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen b))
@@ -321,55 +159,52 @@ instance
321159class
322160 ( Finite self a ~ af, Finite self b ~ bf
323161 ) => FiniteSum self (a :: * -> *) (b :: * -> *) af bf where
324− finiteSum :: Proxy self -> [Gen ((a :+: b) p)]
162+ finiteSum :: [Gen ((a :+: b) p)]
325163
326164instance
327165 ( FiniteSumElem self a, FiniteSumElem self b
328166 , Finite self a ~ 'True
329167 , Finite self b ~ 'True
330168 ) => FiniteSum self a b 'True 'True where
331− finiteSum _ = concat
332− [ fmap L1 <$> finiteElem (Proxy :: Proxy self)
333− , fmap R1 <$> finiteElem (Proxy :: Proxy self)]
169+ finiteSum = concat
170+ [ fmap L1 <$> finiteElem @self @a
171+ , fmap R1 <$> finiteElem @self @b]
334172
335173instance
336174 ( FiniteSumElem self a
337175 , Finite self a ~ 'True
338176 , Finite self b ~ 'False
339177 ) => FiniteSum self a b 'True 'False where
340− finiteSum _ = fmap L1 <$> finiteElem (Proxy :: Proxy self)
178+ finiteSum = fmap L1 <$> finiteElem @self @a
341179
342180instance
343181 ( FiniteSumElem self b
344182 , Finite self a ~ 'False
345183 , Finite self b ~ 'True
346184 ) => FiniteSum self a b 'False 'True where
347− finiteSum _ = fmap R1 <$> finiteElem (Proxy :: Proxy self)
185+ finiteSum = fmap R1 <$> finiteElem @self @b
348186
349187class FiniteSumElem self a where
350− finiteElem :: Proxy self -> [Gen (a p)]
188+ finiteElem :: [Gen (a p)]
351189
352190instance
353191 ( FiniteSum self a b af bf
354192 ) => FiniteSumElem self (a :+: b) where
355− finiteElem _ = finiteSum (Proxy :: Proxy self)
193+ finiteElem = finiteSum @self
356194
357195instance
358− ( GArbitrary self (M1 C c f) 'True
359− ) => FiniteSumElem self (M1 C c f) where
360− finiteElem _ = [gArbitrary (Proxy :: Proxy self)]
361−
196+ ( GArbitrary self (C1 c f) 'True
197+ ) => FiniteSumElem self (C1 c f) where
198+ finiteElem = [gArbitrary @self]
362199
363−#if __GLASGOW_HASKELL__ >= 800
364200instance
365201 ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
366202 , (Finite self a || Finite self b) ~ 'False
367− ) => GArbitrary self (M1 D t (a :+: b)) 'False where
368− gArbitrary _ = error "Unreachable"
369−#endif
203+ ) => GArbitrary self (D1 t (a :+: b)) 'False where
204+ gArbitrary = error "Unreachable"
370205
371206genericArbitrary
372207 :: forall a ga some
373208 . (Generic a, GArbitrary a ga some, ga ~ Rep a)
374209 => Gen a
375−genericArbitrary = G.to <$> gArbitrary (Proxy :: Proxy a)
210+genericArbitrary = G.to <$> gArbitrary @a