git.iko.soy/typeable/generic-arbitrary
on master help sign in
Merge pull request #16 from typeable/merging
c43267fAlexey Uimanov
.github/workflows/haskell-ci.ymlnew file+16
compare with master
unifiedsplit
@@ -0,0 +1,16 @@
1+name: Haskell-CI
2+on: [push]
3+jobs:
4+ linux:
5+ name: ${{ matrix.stack-yaml }}
6+ runs-on: ubuntu-latest
7+ strategy:
8+ matrix:
9+ stack-yaml: [stack.yaml, lts-18.18.yaml, lts-13.21.yaml]
10+ steps:
11+ - uses: actions/checkout@v3
12+ - uses: haskell/actions/setup@v2
13+ with:
14+ enable-stack: true
15+ stack-version: 'latest'
16+ - run: stack --stack-yaml ${{ matrix.stack-yaml }} --install-ghc test --fast --haddock
.gitignore+2
@@ -3,3 +3,5 @@ dist
3.stack-work
3.stack-work
4.cabal-sandbox/
4.cabal-sandbox/
5cabal.sandbox.config
5cabal.sandbox.config
6+dist-newstyle
7+TAGS
.travis.yml+1
@@ -107,6 +107,7 @@ install:
107 - rm cabal.project.freeze
107 - rm cabal.project.freeze
108 - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all
108 - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all
109 - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all
109 - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all
110+ - travis_wait 40 ${CABAL} v2-install $WITHCOMPILER --disable-tests --disable-benchmarks -j2 tasty-discover
110script:
111script:
111 - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
112 - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX)
112 # Packaging...
113 # Packaging...
CHANGELOG.md+7
@@ -1,3 +1,10 @@
1+1.0.0
2+-----
3+
4+* Fixed issue with too big terms in case of recursive types
5+* Recpect the `size` argument
6+* Types with parameters require `Arg` now
7+
10.2.2
80.2.2
2-----
9-----
3
10
README.md+135−1
@@ -1,3 +1,137 @@
1# generic-arbitrary
1# generic-arbitrary
2
2
3−[![Build Status](https://travis-ci.org/typeable/generic-arbitrary.svg?branch=master)](https://travis-ci.org/typeable/generic-arbitrary)
3+[![GitHub CI](https://github.com/typeable/generic-arbitrary/workflows/haskell-ci/badge.svg)](https://github.com/typeable/generic-arbitrary/actions)
4+
5+# What?
6+
7+Package for deriving `Arbitrary` via `Generic`.
8+
9+``` haskell
10+import GHC.Generics (Generic)
11+import Test.QuickCheck
12+import Test.QuickCheck.Arbitrary.Generic
13+
14+data Expr
15+ = Lit Int
16+ | Add Expr Expr
17+ | Mul Expr Expr
18+ deriving (Eq, Show, Generic)
19+ deriving Arbitrary via (GenericArbitrary Expr)
20+```
21+
22+Older versions of this package had a problem with hanging `arbitrary`
23+method. Since `1.0.0` this problem almost solved.
24+
25+For `QuickCheck` older than `2.14.0` the `GenericArbitrary` is not available, so
26+you will need to write instances more verbosely
27+
28+``` haskell
29+data Expr
30+ = Lit Int
31+ | Add Expr Expr
32+ | Mul Expr Expr
33+ deriving (Eq, Show, Generic)
34+
35+instance Arbitrary Expr where
36+ arbitrary = genericArbitrary
37+ shrink = genericShrink
38+```
39+
40+Which is generally the same.
41+
42+# Infinite terms problem
43+
44+The `generic-arbitrary` can partially handle the problem with recursive
45+types. Assume the type `R`
46+
47+``` haskell
48+data R = R R
49+ deriving Generic
50+```
51+
52+there is no instance
53+
54+``` haskell
55+instance Arbitrary R where
56+ arbitrary = genericArbitrary
57+ shrink = genericShrink
58+```
59+
60+If you try to compile this you will get a type level error
61+
62+> • R refers to itself in all constructors
63+
64+Which means that there is no finite term for `R` because it is recursive in all
65+it's constructors. But, if you correct the definition of `R` like this.
66+
67+``` haskell
68+data R = R R | F
69+ deriving Generic
70+```
71+
72+Then it will compile. And the `arbitrary` generated will not hang forever,
73+because it respects the `size` parameter.
74+
75+## Limitation
76+
77+There is a limitation of recursion detection:
78+
79+``` haskell
80+data R1 = R1 R2
81+ deriving (Eq, Ord, Show, Generic)
82+ deriving anyclass NFData
83+ deriving Arbitrary via (GenericArbitrary R1)
84+
85+data R2 = R2 R1
86+ deriving (Eq, Ord, Show, Generic)
87+ deriving anyclass NFData
88+ deriving Arbitrary via (GenericArbitrary R2)
89+```
90+
91+This code will compile and the `arbitrary` generated will always hang. Yes,
92+there is a problem with mutually recursive types.
93+
94+# Type parameters
95+
96+Now lets see an example of datatype with parameters
97+
98+``` haskell
99+data A a = A a
100+ deriving (Eq, Ord, Show)
101+ deriving anyclass NFData
102+ deriving (Generic)
103+
104+instance (Arbitrary a) => Arbitrary (A a) where
105+ arbitrary = genericArbitrary
106+ shrink = genericShrink
107+```
108+
109+It should work from first glance, but when compile it will throw an error:
110+
111+> • Could not deduce (Test.QuickCheck.Arbitrary.Generic.GArbitrary
112+> (A a)
113+> (GHC.Generics.D1
114+> ('GHC.Generics.MetaData "A" "ParametersTest" "main" 'False)
115+> (GHC.Generics.C1
116+> ('GHC.Generics.MetaCons "A" 'GHC.Generics.PrefixI 'False)
117+> (GHC.Generics.S1
118+> ('GHC.Generics.MetaSel
119+> 'Nothing
120+> 'GHC.Generics.NoSourceUnpackedness
121+> 'GHC.Generics.NoSourceStrictness
122+> 'GHC.Generics.DecidedLazy)
123+> (GHC.Generics.Rec0 a))))
124+> (TypesDiffer (A a) a))
125+> arising from a use of ‘genericArbitrary’
126+
127+Here the `TypesDiffer` is a type familty dealing with recursive types and
128+helping us to eliminate inproper instances. To convince the compiller, that the
129+`a` parameter is not an `A a` we must fix the instance with additional constraint
130+
131+``` haskell
132+instance (Arg (A a) a, Arbitrary a) => Arbitrary (A a) where
133+ arbitrary = genericArbitrary
134+ shrink = genericShrink
135+```
136+
137+Now everything compiles and works as expected.
generic-arbitrary.cabal+74−9
@@ -1,10 +1,10 @@
1name: generic-arbitrary
1name: generic-arbitrary
2−version: 0.2.2
2+version: 1.0.0
3synopsis: Generic implementation for QuickCheck's Arbitrary
3synopsis: Generic implementation for QuickCheck's Arbitrary
4description:
4description:
5 Generic implementations of methods of the 'Arbitrary' class from the
5 Generic implementations of methods of the 'Arbitrary' class from the
6 QuickCheck library. The approach taken here can lead to diverging instances
6 QuickCheck library. The approach taken here can lead to diverging instances
7− for recursive types but is safe for non-recursive ones and guarantees
7+ for mutually recursive types but is safe for simply recursive ones and guarantees
8 flat distribution for constructors of sum-types.
8 flat distribution for constructors of sum-types.
9
9
10license: MIT
10license: MIT
@@ -16,16 +16,81 @@ category: Generic
16build-type: Simple
16build-type: Simple
17extra-source-files: CHANGELOG.md
17extra-source-files: CHANGELOG.md
18cabal-version: 1.22
18cabal-version: 1.22
19−tested-with: GHC == 7.10.3
19+tested-with: GHC == 8.10.7
20− , GHC == 8.0.2
21− , GHC == 8.2.2
22− , GHC == 8.4.1
23− , GHC == 8.6.5
24− , GHC == 8.10.1
25 , GHC == 9.0.2
20 , GHC == 9.0.2
26
21
22+source-repository head
23+ type: git
24+ location: https://github.com/typeable/generic-arbitrary.git
25+
27library
26library
28 exposed-modules: Test.QuickCheck.Arbitrary.Generic
27 exposed-modules: Test.QuickCheck.Arbitrary.Generic
29− build-depends: QuickCheck >= 2.14, base >=4.8 && <5
28+ build-depends: base >=4.8 && <5
29+ , QuickCheck
30 hs-source-dirs: src
30 hs-source-dirs: src
31 default-language: Haskell2010
31 default-language: Haskell2010
32+ default-extensions: AllowAmbiguousTypes
33+ , CPP
34+ , ConstraintKinds
35+ , DataKinds
36+ , DeriveGeneric
37+ , FlexibleContexts
38+ , FlexibleInstances
39+ , GeneralizedNewtypeDeriving
40+ , LambdaCase
41+ , MultiParamTypeClasses
42+ , PolyKinds
43+ , RankNTypes
44+ , ScopedTypeVariables
45+ , TypeFamilies
46+ , TypeOperators
47+ , TypeSynonymInstances
48+ , UndecidableInstances
49+ , ViewPatterns
50+
51+
52+test-suite test
53+ type: exitcode-stdio-1.0
54+ hs-source-dirs: test
55+ main-is: Test.hs
56+ default-language: Haskell2010
57+ build-depends: base >= 4.8 && <5
58+ , QuickCheck
59+ , deepseq
60+ , generic-arbitrary
61+ , tasty
62+ , tasty-discover
63+ , tasty-hunit
64+ , tasty-quickcheck
65+ other-modules: Aux
66+ , LimitationDemo
67+ , NoTypecheckTest
68+ , ParametersTest
69+ , RecursiveTest
70+ default-extensions: AllowAmbiguousTypes
71+ , CPP
72+ , DataKinds
73+ , DeriveAnyClass
74+ , DeriveGeneric
75+ , DerivingStrategies
76+ , DerivingVia
77+ , FlexibleContexts
78+ , FlexibleInstances
79+ , GeneralizedNewtypeDeriving
80+ , LambdaCase
81+ , MultiParamTypeClasses
82+ , PolyKinds
83+ , RankNTypes
84+ , ScopedTypeVariables
85+ , TypeApplications
86+ , TypeFamilies
87+ , TypeOperators
88+ , TypeSynonymInstances
89+ , UndecidableInstances
90+ , ViewPatterns
91+ build-tools: tasty-discover
92+ ghc-options: -Wall
93+ -threaded
94+ -rtsopts
95+ "-with-rtsopts=-N -A64m -qb0 -n4m -T -I1"
96+ default-extensions: DeriveGeneric
lts-13.21.yamlnew file+1
@@ -0,0 +1 @@
1+resolver: lts-13.21
lts-13.21.yaml.locknew file+12
@@ -0,0 +1,12 @@
1+# This file was autogenerated by Stack.
2+# You should not edit this file by hand.
3+# For more information, please see the documentation at:
4+# https://docs.haskellstack.org/en/stable/lock_files
5+
6+packages: []
7+snapshots:
8+- completed:
9+ sha256: eff2de19a6d4691ccbf6edc1fba858f1918683047dce0f09adede874bbd2a8f3
10+ size: 498180
11+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/21.yaml
12+ original: lts-13.21
lts-18.18.yamlnew file+1
@@ -0,0 +1 @@
1+resolver: lts-18.18
lts-18.18.yaml.locknew file+12
@@ -0,0 +1,12 @@
1+# This file was autogenerated by Stack.
2+# You should not edit this file by hand.
3+# For more information, please see the documentation at:
4+# https://docs.haskellstack.org/en/stable/lock_files
5+
6+packages: []
7+snapshots:
8+- completed:
9+ sha256: 63539429076b7ebbab6daa7656cfb079393bf644971156dc349d7c0453694ac2
10+ size: 586296
11+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/18.yaml
12+ original: lts-18.18
src/Test/QuickCheck/Arbitrary/Generic.hs+308−36
@@ -1,8 +1,7 @@
1−{-# LANGUAGE FlexibleContexts, UndecidableInstances, TypeOperators, DataKinds, TypeFamilies, ScopedTypeVariables#-}
1+{-|
2
2
3−{- |
4−
5−Generic implementation of the 'arbitrary' method. Example usage:
3+This module is a generic implementation of the 'arbitrary' method. Example
4+usage:
6
5
7@
6@
8data Foo = Foo
7data Foo = Foo
@@ -27,54 +26,201 @@ data Foo = Foo
27
26
28The generated 'arbitrary' method is equivalent to
27The generated 'arbitrary' method is equivalent to
29
28
29+@
30−@Foo <$> arbitrary <*> arbitrary@.
30+Foo <$> arbitrary <*> arbitrary
31+@.
32+
33+It can also handle a recursive types problem. Assuming a type
34+
35+@
36+data R = R R
37+ deriving Generic
38+@
39+
40+there is no instance
41+
42+@
43+instance Arbitrary R where
44+ arbitrary = genericArbitrary
45+ shrink = genericShrink
46+@
47+
48+If you try to compile this you will get a type level error
49+
50+> • R refers to itself in all constructors
51+
52+Which means that there is no finite term for @R@ because it is recursive. But,
53+if you correct the definition of @R@ like this.
54+
55+@
56+data R = R R | F
57+ deriving Generic
58+@
59+
60+Then it will compile. And the @arbitrary@ generated will not hang forever, because
61+it respects the @size@ parameter.
62+
63+There is a limitation of recursion detection:
64+
65+@
66+data R1 = R1 R2
67+ deriving (Eq, Ord, Show, Generic)
68+ deriving anyclass NFData
69+ deriving Arbitrary via (GenericArbitrary R1)
70+
71+data R2 = R2 R1
72+ deriving (Eq, Ord, Show, Generic)
73+ deriving anyclass NFData
74+ deriving Arbitrary via (GenericArbitrary R2)
75+@
76+
77+This code will compile and the @arbitrary@ generated will always hang. Yes,
78+there is a problem with mutually recursive types.
79+
80+Now lets see an example of datatype with parameters
81+
82+@
83+data A a = A a
84+ deriving (Eq, Ord, Show)
85+ deriving anyclass NFData
86+ deriving (Generic)
87+
88+instance (Arbitrary a) => Arbitrary (A a) where
89+ arbitrary = genericArbitrary
90+ shrink = genericShrink
91+@
92+
93+It should work from first glance, but when compile it will throw an error:
94+
95+@
96+ • Could not deduce (Test.QuickCheck.Arbitrary.Generic.GArbitrary
97+ (A a)
98+ (GHC.Generics.D1
99+ ('GHC.Generics.MetaData "A" "ParametersTest" "main" 'False)
100+ (GHC.Generics.C1
101+ ('GHC.Generics.MetaCons "A" 'GHC.Generics.PrefixI 'False)
102+ (GHC.Generics.S1
103+ ('GHC.Generics.MetaSel
104+ 'Nothing
105+ 'GHC.Generics.NoSourceUnpackedness
106+ 'GHC.Generics.NoSourceStrictness
107+ 'GHC.Generics.DecidedLazy)
108+ (GHC.Generics.Rec0 a))))
109+ (TypesDiffer (A a) a))
110+ arising from a use of ‘genericArbitrary’
111+@
112+
113+Here the @TypesDiffer@ is a type familty dealing with recursive types and
114+helping us to eliminate inproper instances. To convince the compiller, that the
115+@a@ parameter is not an @A a@ we must fix the instance with additional constraint
116+
117+@
118+instance (Arg (A a) a, Arbitrary a) => Arbitrary (A a) where
119+ arbitrary = genericArbitrary
120+ shrink = genericShrink
121+@
122+
123+Now everything compiles and works as expected.
31
124
32-}
125-}
33
126
34module Test.QuickCheck.Arbitrary.Generic
127module Test.QuickCheck.Arbitrary.Generic
35− ( GenericArbitrary(..)
128+ ( -- * Main
36− , Arbitrary(..)
37− , genericArbitrary
129+ genericArbitrary
38 , genericShrink
130 , genericShrink
131+#if MIN_VERSION_QuickCheck(2, 14, 0)
132+ , GenericArbitrary(..)
133+#endif
134+ , Arg
135+ -- * Internal
136+ , GArbitrary
137+ , FiniteSum
138+ , FiniteSumElem
139+ , Finite
140+ , AllFieldsFinal
141+ , TypesDiffer
142+ , ArgumentsCount
143+ , SumLen
144+ -- * Reexports
145+ , Arbitrary(..)
39 ) where
146 ) where
40
147
41−import Control.Applicative
148+import Control.Applicative
42−import Data.Coerce (coerce)
149+import Data.Coerce (coerce)
43−import Data.Proxy
150+import Data.Proxy
151+import Data.Type.Bool
44−import GHC.Generics as G
152+import GHC.Generics as G
45−import GHC.TypeLits
153+import GHC.TypeLits
46−import Test.QuickCheck as QC
154+import Test.QuickCheck as QC
155+#if MIN_VERSION_QuickCheck(2, 14, 0)
47−import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
156+import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
157+
48
158
159+
160+-- | Newtype for @DerivingVia@
161+--
162+-- Usage:
163+--
164+-- @
165+-- data Foo = Foo
166+-- { _fooX :: X
167+-- , _fooY :: Y
168+-- } deriving (Generic)
169+-- deriving (Arbitrary) via GenericArbitrary Foo
170+-- @
171+--
172+-- @since 1.0.0
49newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
173newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
50 deriving (Show, Eq)
174 deriving (Show, Eq)
51
175
52instance
176instance
53 ( Generic a,
177 ( Generic a,
54− GArbitrary (Rep a),
178+ GArbitrary a (Rep a) some,
55 RecursivelyShrink (Rep a),
179 RecursivelyShrink (Rep a),
56 GSubterms (Rep a) a
180 GSubterms (Rep a) a
57 ) => Arbitrary (GenericArbitrary a) where
181 ) => Arbitrary (GenericArbitrary a) where
58 arbitrary = coerce (genericArbitrary :: Gen a)
182 arbitrary = coerce (genericArbitrary :: Gen a)
59 shrink = coerce (genericShrink :: a -> [a])
183 shrink = coerce (genericShrink :: a -> [a])
184+#endif
60
185
61−class GArbitrary a where
186+-- | Constraint helper for types with parameters
62− gArbitrary :: QC.Gen (a x)
187+--
188+-- Usage:
189+--
190+-- @
191+-- data A a = A a
192+-- deriving (Generic)
193+-- instance (Arg (A a) a, Arbitrary a) => Arbitrary (A a) where
194+-- arbitrary = genericArbitrary
195+-- shrink = genericShrink
196+-- @
197+--
198+-- @since 1.0.0
63
199
64−instance GArbitrary G.U1 where
200+type Arg self field = (TypesDiffer self field ~ 'True)
65− gArbitrary = pure G.U1
66
201
67−instance Arbitrary c => GArbitrary (G.K1 i c) where
202+type family TypesDiffer a b where
68− gArbitrary = G.K1 <$> scale predNat arbitrary
203+ TypesDiffer a a = 'False
69− where
204+ TypesDiffer a b = 'True
70− predNat 0 = 0
205+
71− predNat n = pred n
206+type family AllFieldsFinal self (a :: * -> *) :: Bool where
207+ AllFieldsFinal self U1 = 'True
208+ AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b
209+ AllFieldsFinal self (M1 S t (K1 R field)) = TypesDiffer self field
72
210
73−instance GArbitrary f => GArbitrary (G.M1 i c f) where
211+type family Finite self (a :: * -> *) :: Bool where
74− gArbitrary = G.M1 <$> gArbitrary
212+ Finite self U1 = 'True
213+ Finite self (K1 R field) = TypesDiffer self field
214+ Finite self (a :*: b) = Finite self a && Finite self b
215+ Finite self (M1 D t f) = Finite self f
216+ Finite self (a :+: b) = Finite self a || Finite self b
217+ Finite self (M1 C c f) = AllFieldsFinal self f
218+ Finite self (M1 S s f) = Finite self f
75
219
76−instance (GArbitrary a, GArbitrary b) => GArbitrary (a G.:*: b) where
220+type family ArgumentsCount (a :: * -> *) :: Nat where
77− gArbitrary = liftA2 (G.:*:) gArbitrary gArbitrary
221+ ArgumentsCount U1 = 1
222+ ArgumentsCount (M1 S s f) = 1
223+ ArgumentsCount (a :*: b) = (ArgumentsCount a) + (ArgumentsCount b)
78
224
79-- | Calculates count of constructors encoded by particular ':+:'.
225-- | Calculates count of constructors encoded by particular ':+:'.
80-- Internal use only.
226-- Internal use only.
@@ -82,14 +228,140 @@ type family SumLen a :: Nat where
82 SumLen (a G.:+: b) = (SumLen a) + (SumLen b)
228 SumLen (a G.:+: b) = (SumLen a) + (SumLen b)
83 SumLen a = 1
229 SumLen a = 1
84
230
231+-- | Generic arbitrary.
232+--
233+-- Parameters are:
234+-- * self: the ADT we generating instance for
235+-- * a: some part of the `Rep self`
236+-- * finite: Is `a` finite? Infinite type has no finite values (like Stream)
237+class (Finite self a ~ finite) => GArbitrary self a (finite :: Bool) where
238+ gArbitrary :: Proxy self -> QC.Gen (a x)
239+
240+instance
241+ ( GArbitrary self (M1 C c f) 'True
242+ ) => GArbitrary self (M1 D t (M1 C c f)) 'True where
243+ gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)
244+
245+-- | The constructor meta information
246+instance
247+ ( GArbitrary self f some
248+ , KnownNat (ArgumentsCount f)
249+ , AllFieldsFinal self f ~ some
250+ ) => GArbitrary self (M1 C c f) some where
251+ gArbitrary _ = M1 <$> scale predNat (gArbitrary (Proxy :: Proxy self))
252+ where
253+ argumentsCount = fromIntegral $ natVal (Proxy :: Proxy (ArgumentsCount f))
254+ predNat n = max 0 $ if argumentsCount > 1
255+ then n `div` argumentsCount
256+ else pred n
257+
258+-- | Unit type instance
259+instance GArbitrary self U1 'True where
260+ gArbitrary _ = pure U1
261+
262+-- | Constructor field meta information
263+instance GArbitrary self f some => GArbitrary self (M1 S t f) some where
264+ gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)
265+
266+-- | Data of the constructor field
267+instance
268+ ( Arbitrary t
269+ , Finite self (K1 R t) ~ some
270+ ) => GArbitrary self (K1 R t) some where
271+ gArbitrary _ = K1 <$> arbitrary
272+
273+-- | Product
274+instance
275+ ( GArbitrary self a af
276+ , GArbitrary self b bf
277+ , (af && bf) ~ some
278+ ) => GArbitrary self (a :*: b) some where
279+ gArbitrary _ = liftA2 (:*:)
280+ (gArbitrary (Proxy :: Proxy self)) (gArbitrary (Proxy :: Proxy self))
281+
282+#if __GLASGOW_HASKELL__ >= 800
283+instance
284+ ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
285+ , AllFieldsFinal self f ~ 'False
286+ ) => GArbitrary self (M1 D t (M1 C c f)) 'False where
287+ gArbitrary _ = error "Unreachable"
288+#endif
289+
290+-- | ADT declaration with multiple constructors
291+instance
292+ ( FiniteSum self a b af bf
293+ , GArbitrary self (a :+: b) 'True
294+ ) => GArbitrary self (M1 D t (a :+: b)) 'True where
295+ gArbitrary _ = sized $ \s -> M1 <$>
296+ if s > 1
297+ then gArbitrary (Proxy :: Proxy self)
298+ else oneof (finiteSum (Proxy :: Proxy self))
299+
300+-- | Any sum inside of declaration
301+instance
302+ ( GArbitrary self a af, GArbitrary self b bf
85−instance (GArbitrary a, GArbitrary b, KnownNat (SumLen a), KnownNat (SumLen b)
303+ , KnownNat (SumLen a), KnownNat (SumLen b)
304+ , (af || bf) ~ some
86− ) => GArbitrary (a G.:+: b) where
305+ ) => GArbitrary self (a :+: b) some where
87− gArbitrary = frequency
306+ gArbitrary _ = frequency
88− [ (lfreq, G.L1 <$> gArbitrary)
307+ [ (lfreq, G.L1 <$> gArbitrary (Proxy :: Proxy self))
89− , (rfreq, G.R1 <$> gArbitrary) ]
308+ , (rfreq, G.R1 <$> gArbitrary (Proxy :: Proxy self)) ]
90 where
309 where
91 lfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen a))
310 lfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen a))
92 rfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen b))
311 rfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen b))
93
312
313+class
314+ ( Finite self a ~ af, Finite self b ~ bf
315+ ) => FiniteSum self (a :: * -> *) (b :: * -> *) af bf where
316+ finiteSum :: Proxy self -> [Gen ((a :+: b) p)]
317+
318+instance
319+ ( FiniteSumElem self a, FiniteSumElem self b
320+ , Finite self a ~ 'True
321+ , Finite self b ~ 'True
322+ ) => FiniteSum self a b 'True 'True where
323+ finiteSum _ = concat
324+ [ fmap L1 <$> finiteElem (Proxy :: Proxy self)
325+ , fmap R1 <$> finiteElem (Proxy :: Proxy self)]
326+
327+instance
328+ ( FiniteSumElem self a
329+ , Finite self a ~ 'True
330+ , Finite self b ~ 'False
331+ ) => FiniteSum self a b 'True 'False where
332+ finiteSum _ = fmap L1 <$> finiteElem (Proxy :: Proxy self)
333+
334+instance
335+ ( FiniteSumElem self b
336+ , Finite self a ~ 'False
337+ , Finite self b ~ 'True
338+ ) => FiniteSum self a b 'False 'True where
339+ finiteSum _ = fmap R1 <$> finiteElem (Proxy :: Proxy self)
340+
341+class FiniteSumElem self a where
342+ finiteElem :: Proxy self -> [Gen (a p)]
343+
344+instance
345+ ( FiniteSum self a b af bf
346+ ) => FiniteSumElem self (a :+: b) where
347+ finiteElem _ = finiteSum (Proxy :: Proxy self)
348+
349+instance
350+ ( GArbitrary self (M1 C c f) 'True
351+ ) => FiniteSumElem self (M1 C c f) where
352+ finiteElem _ = [gArbitrary (Proxy :: Proxy self)]
353+
354+
355+#if __GLASGOW_HASKELL__ >= 800
356+instance
357+ ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
358+ , (Finite self a || Finite self b) ~ 'False
359+ ) => GArbitrary self (M1 D t (a :+: b)) 'False where
360+ gArbitrary _ = error "Unreachable"
361+#endif
362+
363+genericArbitrary
364+ :: forall a ga some
94−genericArbitrary :: (Generic a, GArbitrary ga, ga ~ G.Rep a) => Gen a
365+ . (Generic a, GArbitrary a ga some, ga ~ Rep a)
366+ => Gen a
95−genericArbitrary = G.to <$> gArbitrary
367+genericArbitrary = G.to <$> gArbitrary (Proxy :: Proxy a)
stack.yaml.locknew file+12
@@ -0,0 +1,12 @@
1+# This file was autogenerated by Stack.
2+# You should not edit this file by hand.
3+# For more information, please see the documentation at:
4+# https://docs.haskellstack.org/en/stable/lock_files
5+
6+packages: []
7+snapshots:
8+- completed:
9+ sha256: e7e57649a12f6178d1158e4b6f1f1885ed56d210ae6174385271cecc9b1ea974
10+ size: 617368
11+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/2.yaml
12+ original: lts-19.2
test/Aux.hsnew file+10
@@ -0,0 +1,10 @@
1+module Aux where
2+
3+import Control.Exception
4+import Test.QuickCheck
5+
6+failGeneration :: forall a. (Arbitrary a, Show a) => IO ()
7+failGeneration = do
8+ try (generate (arbitrary :: Gen a) >>= print) >>= \case
9+ Left (_ :: SomeException) -> pure ()
10+ Right _ -> error "Error expected"
test/LimitationDemo.hsnew file+37
@@ -0,0 +1,37 @@
1+module LimitationDemo where
2+
3+import Control.DeepSeq
4+import GHC.Generics (Generic)
5+import Test.QuickCheck
6+import Test.QuickCheck.Arbitrary.Generic
7+
8+-- As you can see, we have this instance generated, but it will definitely lead
9+-- to generating an infinite term (and the only term). The recursion detection
10+-- doesn't work here
11+data R1 = R1 R2
12+ deriving (Eq, Ord, Show, Generic)
13+ deriving anyclass NFData
14+#if MIN_VERSION_QuickCheck(2, 14, 0)
15+ deriving Arbitrary via (GenericArbitrary R1)
16+#else
17+instance Arbitrary R1 where
18+ arbitrary = genericArbitrary
19+ shrink = genericShrink
20+#endif
21+
22+data R2 = R2 R1
23+ deriving (Eq, Ord, Show, Generic)
24+ deriving anyclass NFData
25+#if MIN_VERSION_QuickCheck(2, 14, 0)
26+ deriving Arbitrary via (GenericArbitrary R2)
27+#else
28+instance Arbitrary R2 where
29+ arbitrary = genericArbitrary
30+ shrink = genericShrink
31+#endif
32+
33+-- To force the instance realy be generated
34+usage :: IO ()
35+usage = do
36+ r1 :: R1 <- generate arbitrary
37+ print r1 -- haha
test/NoTypecheckTest.hsnew file+23
@@ -0,0 +1,23 @@
1+{-# OPTIONS_GHC -fdefer-type-errors #-}
2+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
3+
4+-- | Test that infinite types has no Arbitrary instance
5+
6+module NoTypecheckTest where
7+
8+import Aux
9+import GHC.Generics (Generic)
10+import Test.QuickCheck
11+import Test.QuickCheck.Arbitrary.Generic
12+
13+-- | Recursive infinite type which can not have valid Arbitrary instance
14+data R = R R
15+ deriving (Eq, Show, Generic)
16+
17+-- | Instance which must not compile, but we are using deferred type errors
18+instance Arbitrary R where
19+ arbitrary = genericArbitrary
20+ shrink = genericShrink
21+
22+unit_mustFail :: IO ()
23+unit_mustFail = failGeneration @R
test/ParametersTest.hsnew file+34
@@ -0,0 +1,34 @@
1+{-# OPTIONS_GHC -fdefer-type-errors #-}
2+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
3+
4+module ParametersTest where
5+
6+import Aux
7+import Control.DeepSeq
8+import GHC.Generics (Generic)
9+import Test.QuickCheck
10+import Test.QuickCheck.Arbitrary.Generic
11+
12+data A a = A a
13+ deriving (Eq, Ord, Show)
14+ deriving anyclass NFData
15+ deriving (Generic)
16+
17+instance (Arbitrary a) => Arbitrary (A a) where
18+ arbitrary = genericArbitrary
19+ shrink = genericShrink
20+
21+data B a = B a
22+ deriving (Eq, Ord, Show)
23+ deriving anyclass NFData
24+ deriving (Generic)
25+
26+instance (Arg (B a) a, Arbitrary a) => Arbitrary (B a) where
27+ arbitrary = genericArbitrary
28+ shrink = genericShrink
29+
30+unit_argumentConstraintFail :: IO ()
31+unit_argumentConstraintFail = failGeneration @(A Int)
32+
33+prop_properArgumentConstraint :: B Int -> Property
34+prop_properArgumentConstraint = total
test/RecursiveTest.hsnew file+137
@@ -0,0 +1,137 @@
1+{-# LANGUAGE DerivingStrategies #-}
2+{-# LANGUAGE DerivingVia #-}
3+{-# LANGUAGE DeriveAnyClass #-}
4+
5+-- | Testing that our Arbitrary instances do not get stuck and respect the
6+-- `size` parameter while generating.
7+
8+module RecursiveTest where
9+
10+import Control.DeepSeq
11+import GHC.Generics (Generic)
12+import Test.QuickCheck
13+import Test.QuickCheck.Arbitrary.Generic
14+
15+data Unit = Unit
16+ deriving (Eq, Show, Generic)
17+ deriving anyclass NFData
18+#if MIN_VERSION_QuickCheck(2, 14, 0)
19+ deriving Arbitrary via (GenericArbitrary Unit)
20+#else
21+instance Arbitrary Unit where
22+ arbitrary = genericArbitrary
23+ shrink = genericShrink
24+#endif
25+
26+prop_unitTotal :: Unit -> Property
27+prop_unitTotal = total
28+
29+data Single = Single Int
30+ deriving (Eq, Show, Generic)
31+ deriving anyclass NFData
32+#if MIN_VERSION_QuickCheck(2, 14, 0)
33+ deriving Arbitrary via (GenericArbitrary Single)
34+#else
35+instance Arbitrary Single where
36+ arbitrary = genericArbitrary
37+ shrink = genericShrink
38+#endif
39+
40+prop_singleTotal :: Single -> Property
41+prop_singleTotal = total
42+
43+data Multiple = M1 | M2 | M3 Int
44+ deriving (Eq, Show, Generic)
45+ deriving anyclass NFData
46+#if MIN_VERSION_QuickCheck(2, 14, 0)
47+ deriving Arbitrary via (GenericArbitrary Multiple)
48+#else
49+instance Arbitrary Multiple where
50+ arbitrary = genericArbitrary
51+ shrink = genericShrink
52+#endif
53+
54+prop_multipleTotal :: Multiple -> Property
55+prop_multipleTotal = total
56+
57+data Rec = Rec
58+ { unit :: Unit
59+ , single :: Single
60+ , multiple :: Multiple
61+ } deriving (Eq, Show, Generic)
62+ deriving anyclass NFData
63+#if MIN_VERSION_QuickCheck(2, 14, 0)
64+ deriving Arbitrary via (GenericArbitrary Rec)
65+#else
66+instance Arbitrary Rec where
67+ arbitrary = genericArbitrary
68+ shrink = genericShrink
69+#endif
70+
71+prop_recTotal :: Rec -> Property
72+prop_recTotal = total
73+
74+data Expr
75+ = Lit Int
76+ | Add Expr Expr
77+ | Mul Expr Expr
78+ deriving (Eq, Show, Generic)
79+ deriving anyclass NFData
80+#if MIN_VERSION_QuickCheck(2, 14, 0)
81+ deriving Arbitrary via (GenericArbitrary Expr)
82+#else
83+instance Arbitrary Expr where
84+ arbitrary = genericArbitrary
85+ shrink = genericShrink
86+#endif
87+
88+prop_exprTotal :: Expr -> Property
89+prop_exprTotal = total
90+
91+data Recursive
92+ = R1 Recursive
93+ | R2 Recursive Int
94+ | N Int
95+ | R3 Recursive
96+ | R4 Recursive
97+ | R5 Recursive String
98+ deriving (Eq, Show, Generic)
99+ deriving anyclass NFData
100+#if MIN_VERSION_QuickCheck(2, 14, 0)
101+ deriving Arbitrary via (GenericArbitrary Recursive)
102+#else
103+instance Arbitrary Recursive where
104+ arbitrary = genericArbitrary
105+ shrink = genericShrink
106+#endif
107+
108+prop_recursiveTotal :: Recursive -> Property
109+prop_recursiveTotal = total
110+
111+data DeepRecursive
112+ = Deep DeepRecursive DeepRecursive DeepRecursive DeepRecursive DeepRecursive
113+ | Short
114+ deriving (Eq, Show, Generic)
115+ deriving anyclass NFData
116+#if MIN_VERSION_QuickCheck(2, 14, 0)
117+ deriving Arbitrary via (GenericArbitrary DeepRecursive)
118+#else
119+instance Arbitrary DeepRecursive where
120+ arbitrary = genericArbitrary
121+ shrink = genericShrink
122+#endif
123+
124+prop_deepRecursiveTotal :: DeepRecursive -> Property
125+prop_deepRecursiveTotal = total
126+
127+data P p = NoP | P p
128+ deriving (Eq, Show, Generic)
129+ deriving anyclass NFData
130+
131+-- Note that deriving via doesn't work for case with arguments
132+instance (Arg (P p) p, Arbitrary p) => Arbitrary (P p) where
133+ arbitrary = genericArbitrary
134+ shrink = genericShrink
135+
136+prop_Ptotal :: P (P Int) -> Property
137+prop_Ptotal = total
test/Test.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}