@@ -1,6 +1,14 @@
1−{- |
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
27
3−Generic implementation of the 'arbitrary' method. Example usage:
8+{-|
9+
10+This module is a generic implementation of the 'arbitrary' method. Example
11+usage:
412
513@
614data Foo = Foo
@@ -26,7 +34,7 @@ data Foo = Foo
2634The generated 'arbitrary' method is equivalent to
2735
2836@
29−Foo <$> arbitrary <*> arbitrary
37+Foo '<$>' arbitrary '<*>' arbitrary
3038@.
3139
3240It can also handle a recursive types problem. Assuming a type
@@ -73,33 +81,103 @@ data R2 = R2 R1
7381 deriving Arbitrary via (GenericArbitrary R2)
7482@
7583
76−This code will compile and the @arbitrary@ generated will always hand. Yes,
77−there is a problem with mutually recursive types
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:
78101
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.
79131
80132-}
81133
82134module Test.QuickCheck.Arbitrary.Generic
83− ( Arbitrary(..)
135+ ( -- * Main
136+ genericArbitrary
84137#if MIN_VERSION_QuickCheck(2, 14, 0)
85138 , GenericArbitrary(..)
86139#endif
87140 , Arg
88− , genericArbitrary
141+ -- * Internal
142+ , GArbitrary
143+ , FiniteSum
144+ , FiniteSumElem
145+ , Finite
146+ , AllFieldsFinal
147+ , TypesDiffer
148+ , ArgumentsCount
149+ , SumLen
150+ -- * Reexports
151+ , Arbitrary(..)
89152 , genericShrink
90153 ) where
91154
92155import Control.Applicative
93−import Data.Coerce (coerce)
94156import Data.Proxy
95157import Data.Type.Bool
96158import GHC.Generics as G
97159import GHC.TypeLits
160+import Prelude
98161import Test.QuickCheck as QC
99162#if MIN_VERSION_QuickCheck(2, 14, 0)
163+import Data.Coerce (coerce)
100164import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
101165
166+
167+
102168-- | 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
103181newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
104182 deriving (Show, Eq)
105183
@@ -113,12 +191,26 @@ instance
113191 shrink = coerce (genericShrink :: a -> [a])
114192#endif
115193
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+
116210type family TypesDiffer a b where
117211 TypesDiffer a a = 'False
118212 TypesDiffer a b = 'True
119213
120−type Arg self field = (TypesDiffer self field ~ 'True)
121−
122214type family AllFieldsFinal self (a :: * -> *) :: Bool where
123215 AllFieldsFinal self U1 = 'True
124216 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b