@@ -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,151 +25,30 @@ 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
135− ( -- * Main
33+ ( Arbitrary(..)
137#if MIN_VERSION_QuickCheck(2, 14, 0)
34#if MIN_VERSION_QuickCheck(2, 14, 0)
138 , GenericArbitrary(..)
35 , GenericArbitrary(..)
141− -- * Internal
38+ , genericArbitrary
152 , genericShrink
39 , genericShrink
155import Control.Applicative
42import Control.Applicative
43+import Data.Coerce (coerce)
156import Data.Proxy
44import Data.Proxy
157import Data.Type.Bool
45import Data.Type.Bool
158import GHC.Generics as G
46import GHC.Generics as G
159import GHC.TypeLits
47import GHC.TypeLits
161import Test.QuickCheck as QC
48import Test.QuickCheck as QC
162#if MIN_VERSION_QuickCheck(2, 14, 0)
49#if MIN_VERSION_QuickCheck(2, 14, 0)
163−import Data.Coerce (coerce)
164import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
50import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
168−-- | Newtype for @DerivingVia@
176−-- } deriving (Generic)
177−-- deriving (Arbitrary) via GenericArbitrary Foo
181newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
52newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
182 deriving (Show, Eq)
53 deriving (Show, Eq)
@@ -191,26 +62,12 @@ instance
191 shrink = coerce (genericShrink :: a -> [a])
62 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)
210type family TypesDiffer a b where
65type family TypesDiffer a b where
211 TypesDiffer a a = 'False
66 TypesDiffer a a = 'False
212 TypesDiffer a b = 'True
67 TypesDiffer a b = 'True
69+type Arg self field = (TypesDiffer self field ~ 'True)
214type family AllFieldsFinal self (a :: * -> *) :: Bool where
71type family AllFieldsFinal self (a :: * -> *) :: Bool where
215 AllFieldsFinal self U1 = 'True
72 AllFieldsFinal self U1 = 'True
216 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b
73 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b