@@ -1,6 +1,14 @@
1−{- |
1+#if __GLASGOW_HASKELL__ >= 806
2+{-# OPTIONS_GHC -Wno-star-is-type #-}
4+#if __GLASGOW_HASKELL__ >= 800
5+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
3−Generic implementation of the 'arbitrary' method. Example usage:
10+This module is a generic implementation of the 'arbitrary' method. Example
6data Foo = Foo
14data Foo = Foo
@@ -25,30 +33,151 @@ data Foo = Foo
26The generated 'arbitrary' method is equivalent to
34The generated 'arbitrary' method is equivalent to
28−@Foo <$> arbitrary <*> arbitrary@.
37+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.
32module Test.QuickCheck.Arbitrary.Generic
134module Test.QuickCheck.Arbitrary.Generic
33− ( Arbitrary(..)
135+ ( -- * Main
34#if MIN_VERSION_QuickCheck(2, 14, 0)
137#if MIN_VERSION_QuickCheck(2, 14, 0)
35 , GenericArbitrary(..)
138 , GenericArbitrary(..)
38− , genericArbitrary
141+ -- * Internal
39 , genericShrink
152 , genericShrink
42import Control.Applicative
155import Control.Applicative
43−import Data.Coerce (coerce)
44import Data.Proxy
156import Data.Proxy
45import Data.Type.Bool
157import Data.Type.Bool
46import GHC.Generics as G
158import GHC.Generics as G
47import GHC.TypeLits
159import GHC.TypeLits
48import Test.QuickCheck as QC
161import Test.QuickCheck as QC
49#if MIN_VERSION_QuickCheck(2, 14, 0)
162#if MIN_VERSION_QuickCheck(2, 14, 0)
163+import Data.Coerce (coerce)
50import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
164import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
168+-- | Newtype for @DerivingVia@
176+-- } deriving (Generic)
177+-- deriving (Arbitrary) via GenericArbitrary Foo
52newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
181newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
53 deriving (Show, Eq)
182 deriving (Show, Eq)
@@ -62,12 +191,26 @@ instance
62 shrink = coerce (genericShrink :: a -> [a])
191 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)
65type family TypesDiffer a b where
210type family TypesDiffer a b where
66 TypesDiffer a a = 'False
211 TypesDiffer a a = 'False
67 TypesDiffer a b = 'True
212 TypesDiffer a b = 'True
69−type Arg self field = (TypesDiffer self field ~ 'True)
71type family AllFieldsFinal self (a :: * -> *) :: Bool where
214type family AllFieldsFinal self (a :: * -> *) :: Bool where
72 AllFieldsFinal self U1 = 'True
215 AllFieldsFinal self U1 = 'True
73 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b
216 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b