@@ -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
@@ -34,7 +26,7 @@ data Foo = Foo
3426The generated 'arbitrary' method is equivalent to
3527
3628@
37−Foo '<$>' arbitrary '<*>' arbitrary
29+Foo <$> arbitrary <*> arbitrary
3830@.
3931
4032It can also handle a recursive types problem. Assuming a type
@@ -81,103 +73,33 @@ data R2 = R2 R1
8173 deriving Arbitrary via (GenericArbitrary R2)
8274@
8375
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:
76+This code will compile and the @arbitrary@ generated will always hand. Yes,
77+there is a problem with mutually recursive types
10178
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.
13179
13280-}
13381
13482module Test.QuickCheck.Arbitrary.Generic
135− ( -- * Main
136− genericArbitrary
83+ ( Arbitrary(..)
13784#if MIN_VERSION_QuickCheck(2, 14, 0)
13885 , GenericArbitrary(..)
13986#endif
14087 , Arg
141− -- * Internal
142− , GArbitrary
143− , FiniteSum
144− , FiniteSumElem
145− , Finite
146− , AllFieldsFinal
147− , TypesDiffer
148− , ArgumentsCount
149− , SumLen
150− -- * Reexports
151− , Arbitrary(..)
88+ , genericArbitrary
15289 , genericShrink
15390 ) where
15491
15592import Control.Applicative
93+import Data.Coerce (coerce)
15694import Data.Proxy
15795import Data.Type.Bool
15896import GHC.Generics as G
15997import GHC.TypeLits
160−import Prelude
16198import Test.QuickCheck as QC
16299#if MIN_VERSION_QuickCheck(2, 14, 0)
163−import Data.Coerce (coerce)
164100import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
165101
166−
167−
168102-- | 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
181103newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
182104 deriving (Show, Eq)
183105
@@ -191,26 +113,12 @@ instance
191113 shrink = coerce (genericShrink :: a -> [a])
192114#endif
193115
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−
210116type family TypesDiffer a b where
211117 TypesDiffer a a = 'False
212118 TypesDiffer a b = 'True
213119
120+type Arg self field = (TypesDiffer self field ~ 'True)
121+
214122type family AllFieldsFinal self (a :: * -> *) :: Bool where
215123 AllFieldsFinal self U1 = 'True
216124 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b