git.iko.soy/typeable/generic-arbitrary
on master help sign in
swap
ef7cead54 ahead, 0 behind
.github/workflows/haskell-ci.ymlnew file+29
since splitsnapshots
unifiedsplit
@@ -0,0 +1,29 @@
1+name: Haskell-CI
2+on: [push, pull_request]
3+jobs:
4+ linux:
5+ name: GHC-${{ matrix.ghc-version }}
6+ runs-on: ubuntu-latest
7+ strategy:
8+ matrix:
9+ ghc-version:
10+ - 8.6.5
11+ - 8.10.7
12+ - 9.0.2
13+ - 9.2.4
14+ - 9.4.3
15+ - 9.8.1
16+ steps:
17+ - uses: actions/checkout@v3
18+ - uses: haskell/actions/setup@v2
19+ with:
20+ enable-stack: true
21+ ghc-version: ${{ matrix.ghc-version }}
22+ stack-version: 'latest'
23+ - uses: actions/cache@v3
24+ with:
25+ path: |
26+ ~/.stack
27+ ./.stack-work
28+ key: ${{ matrix.ghc-version }}
29+ - run: stack --stack-yaml ghc-${{ matrix.ghc-version }}.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
CHANGELOG.md+33
@@ -1,3 +1,36 @@
1+1.0.1.2
2+-------
3+
4+* Fix dependency bounds (including retroactively), and compilation with warnings.
5+
6+1.0.1.1
7+-------
8+
9+* Fix compilation with GHC 9.8.3
10+
11+1.0.1
12+-----
13+
14+* Compillability by GHC-9.2.4
15+* Fix cabal `tested-with` field
16+
17+1.0.0
18+-----
19+
20+* Fixed issue with too big terms in case of recursive types
21+* Recpect the `size` argument
22+* Types with parameters require `Arg` now
23+
24+0.2.2
25+-----
26+
27+* Resolved an issue where the size of the generators could become negative
28+
29+0.2.1
30+-----
31+
32+* Added compatibility with GHC 9.2.1
33+
10.2.0
340.2.0
2-----
35-----
3
36
README.md+138−1
@@ -1,3 +1,140 @@
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+[![Haskell-CI](https://github.com/typeable/generic-arbitrary/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/typeable/generic-arbitrary/actions/workflows/haskell-ci.yml)
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 let's 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+```
112+• Could not deduce (Test.QuickCheck.Arbitrary.Generic.GArbitrary
113+ (A a)
114+ (GHC.Generics.D1
115+ ('GHC.Generics.MetaData "A" "ParametersTest" "main" 'False)
116+ (GHC.Generics.C1
117+ ('GHC.Generics.MetaCons "A" 'GHC.Generics.PrefixI 'False)
118+ (GHC.Generics.S1
119+ ('GHC.Generics.MetaSel
120+ 'Nothing
121+ 'GHC.Generics.NoSourceUnpackedness
122+ 'GHC.Generics.NoSourceStrictness
123+ 'GHC.Generics.DecidedLazy)
124+ (GHC.Generics.Rec0 a))))
125+ (TypesDiffer (A a) a))
126+ arising from a use of ‘genericArbitrary’
127+```
128+
129+Here the `TypesDiffer` is a type familty dealing with recursive types and
130+helping us to eliminate inproper instances. To convince the compiller, that the
131+`a` parameter is not an `A a` we must fix the instance with additional
132+constraint `Arg (A a) a`
133+
134+``` haskell
135+instance (Arg (A a) a, Arbitrary a) => Arbitrary (A a) where
136+ arbitrary = genericArbitrary
137+ shrink = genericShrink
138+```
139+
140+Now everything compiles and works as expected.
generic-arbitrary.cabal+31−18
@@ -1,10 +1,10 @@
1name: generic-arbitrary
1name: generic-arbitrary
2−version: 0.2.0
2+version: 1.0.1.2
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
@@ -15,22 +15,28 @@ homepage: http://github.com/typeable/generic-arbitrary#readme
15category: Generic
15category: Generic
16build-type: Simple
16build-type: Simple
17extra-source-files: CHANGELOG.md
17extra-source-files: CHANGELOG.md
18+ , README.md
18−cabal-version: 1.22
19+cabal-version: 2.0
19−tested-with: GHC == 7.10.3
20+tested-with: GHC == 8.6.5
20− , GHC == 8.0.2
21+ , GHC == 8.10.7
22+ , GHC == 9.0.2
23+ , GHC == 9.2.4
24+ , GHC == 9.4.3
21− , GHC == 8.2.2
25+ , GHC == 9.8.1
22− , GHC == 8.4.1
26+
23− , GHC == 8.6.5
27+source-repository head
24− , GHC == 8.10.1
28+ type: git
29+ location: https://github.com/typeable/generic-arbitrary.git
25
30
26library
31library
27 exposed-modules: Test.QuickCheck.Arbitrary.Generic
32 exposed-modules: Test.QuickCheck.Arbitrary.Generic
28 build-depends: base >=4.8 && <5
33 build-depends: base >=4.8 && <5
29− , QuickCheck >= 2.14
34+ , QuickCheck >=2.8
30 hs-source-dirs: src
35 hs-source-dirs: src
31 default-language: Haskell2010
36 default-language: Haskell2010
32 default-extensions: AllowAmbiguousTypes
37 default-extensions: AllowAmbiguousTypes
33 , CPP
38 , CPP
39+ , ConstraintKinds
34 , DataKinds
40 , DataKinds
35 , DeriveGeneric
41 , DeriveGeneric
36 , FlexibleContexts
42 , FlexibleContexts
@@ -53,20 +59,27 @@ test-suite test
53 hs-source-dirs: test
59 hs-source-dirs: test
54 main-is: Test.hs
60 main-is: Test.hs
55 default-language: Haskell2010
61 default-language: Haskell2010
56− build-depends: base >= 4.8 && <5
62+ build-depends: base >=4.12 && <5
57− , QuickCheck
63+ , QuickCheck >=2.10
58 , deepseq
64 , deepseq
59 , generic-arbitrary
65 , generic-arbitrary
60− , tasty
66+ , tasty >=1.4.2 || <1.4.0.1
61− , tasty-discover
67+ , tasty-discover >= 2.0.0
62− , tasty-hunit
68+ , tasty-hunit >= 0.9.2
63 , tasty-quickcheck
69 , tasty-quickcheck
70+ other-modules: Auxiliary
71+ , EnumTest
72+ , LimitationDemo
64− other-modules: NoTypecheckTest
73+ , NoTypecheckTest
74+ , ParametersTest
65 , RecursiveTest
75 , RecursiveTest
66 default-extensions: AllowAmbiguousTypes
76 default-extensions: AllowAmbiguousTypes
67 , CPP
77 , CPP
68 , DataKinds
78 , DataKinds
79+ , DeriveAnyClass
69 , DeriveGeneric
80 , DeriveGeneric
81+ , DerivingStrategies
82+ , DerivingVia
70 , FlexibleContexts
83 , FlexibleContexts
71 , FlexibleInstances
84 , FlexibleInstances
72 , GeneralizedNewtypeDeriving
85 , GeneralizedNewtypeDeriving
@@ -75,14 +88,14 @@ test-suite test
75 , PolyKinds
88 , PolyKinds
76 , RankNTypes
89 , RankNTypes
77 , ScopedTypeVariables
90 , ScopedTypeVariables
91+ , TypeApplications
78 , TypeFamilies
92 , TypeFamilies
79 , TypeOperators
93 , TypeOperators
80 , TypeSynonymInstances
94 , TypeSynonymInstances
81 , UndecidableInstances
95 , UndecidableInstances
82 , ViewPatterns
96 , ViewPatterns
83− build-tools: tasty-discover
97+ build-tool-depends: tasty-discover:tasty-discover
84 ghc-options: -Wall
98 ghc-options: -Wall
85 -threaded
99 -threaded
86 -rtsopts
100 -rtsopts
87 "-with-rtsopts=-N -A64m -qb0 -n4m -T -I1"
101 "-with-rtsopts=-N -A64m -qb0 -n4m -T -I1"
88− default-extensions: DeriveGeneric
ghc-8.10.7.yamlnew file+1
@@ -0,0 +1 @@
1+resolver: lts-18.18
ghc-8.10.7.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
ghc-8.6.5.yamlnew file+1
@@ -0,0 +1 @@
1+resolver: lts-13.21
ghc-8.6.5.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
ghc-9.0.2.yamlnew file+1
@@ -0,0 +1 @@
1+resolver: lts-19.20
ghc-9.0.2.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: be747117bed6d462806c883352c3206325b23480825103f5c87884e97e52819a
10+ size: 619173
11+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/20.yaml
12+ original: lts-19.20
ghc-9.2.4.yamlnew file+1
@@ -0,0 +1 @@
1+resolver: nightly-2022-08-24
ghc-9.2.4.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: ff431937a638ebfaa5e6fec13c7ae575f01e02744d6ca5e5b1554f78cb5f88ad
10+ size: 631953
11+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2022/8/24.yaml
12+ original: nightly-2022-08-24
ghc-9.4.3.yamlnew file+1
@@ -0,0 +1 @@
1+resolver: nightly-2022-12-26
ghc-9.4.3.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: bbe432b2abd6d866aa37f65a8129a5f858b7c6eaae9464f8bc2814ce92ac2d15
10+ size: 573163
11+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2022/12/26.yaml
12+ original: nightly-2022-12-26
ghc-9.8.1.yamlnew file+1
@@ -0,0 +1 @@
1+resolver: nightly-2024-01-12
ghc-9.8.1.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: 8f06e87750f95bc8620644ea22344ad023c3c5aa6efa854747aa70093898fd79
10+ size: 556465
11+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/nightly/2024/1/12.yaml
12+ original: nightly-2024-01-12
src/Test/QuickCheck/Arbitrary/Generic.hs+174−22
@@ -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
7+
8+{-|
2
9
3−Generic implementation of the 'arbitrary' method. Example usage:
10+This module is a generic implementation of the 'arbitrary' method. Example
11+usage:
4
12
5@
13@
6data Foo = Foo
14data Foo = Foo
@@ -25,48 +33,192 @@ data Foo = Foo
25
33
26The generated 'arbitrary' method is equivalent to
34The generated 'arbitrary' method is equivalent to
27
35
36+@
28−@Foo <$> arbitrary <*> arbitrary@.
37+Foo '<$>' arbitrary '<*>' arbitrary
38+@.
39+
40+It can also handle a recursive types problem. Assuming a type
41+
42+@
43+data R = R R
44+ deriving Generic
45+@
46+
47+there is no instance
48+
49+@
50+instance Arbitrary R where
51+ arbitrary = genericArbitrary
52+ shrink = genericShrink
53+@
54+
55+If you try to compile this you will get a type level error
56+
57+> • R refers to itself in all constructors
58+
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.
61+
62+@
63+data R = R R | F
64+ deriving Generic
65+@
66+
67+Then it will compile. And the @arbitrary@ generated will not hang forever, because
68+it respects the @size@ parameter.
69+
70+There is a limitation of recursion detection:
71+
72+@
73+data R1 = R1 R2
74+ deriving (Eq, Ord, Show, Generic)
75+ deriving anyclass NFData
76+ deriving Arbitrary via (GenericArbitrary R1)
77+
78+data R2 = R2 R1
79+ deriving (Eq, Ord, Show, Generic)
80+ deriving anyclass NFData
81+ deriving Arbitrary via (GenericArbitrary R2)
82+@
83+
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:
101+
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.
29
131
30-}
132-}
31
133
32module Test.QuickCheck.Arbitrary.Generic
134module Test.QuickCheck.Arbitrary.Generic
135+ ( -- * Main
136+ genericArbitrary
137+#if MIN_VERSION_QuickCheck(2, 14, 0)
33− ( GenericArbitrary(..)
138+ , GenericArbitrary(..)
139+#endif
140+ , Arg
141+ -- * Internal
142+ , GArbitrary
143+ , FiniteSum
144+ , FiniteSumElem
145+ , Finite
146+ , AllFieldsFinal
147+ , TypesDiffer
148+ , ArgumentsCount
149+ , SumLen
150+ -- * Reexports
34 , Arbitrary(..)
151 , Arbitrary(..)
35− , genericArbitrary
36 , genericShrink
152 , genericShrink
37 ) where
153 ) where
38
154
39import Control.Applicative
155import Control.Applicative
40−import Data.Coerce (coerce)
41import Data.Proxy
156import Data.Proxy
42import Data.Type.Bool
157import Data.Type.Bool
43import GHC.Generics as G
158import GHC.Generics as G
44import GHC.TypeLits
159import GHC.TypeLits
160+import Prelude
45import Test.QuickCheck as QC
161import Test.QuickCheck as QC
162+#if MIN_VERSION_QuickCheck(2, 14, 0)
163+import Data.Coerce (coerce)
46import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
164import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
47
165
166+
167+
168+-- | 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
48newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
181newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
49 deriving (Show, Eq)
182 deriving (Show, Eq)
50
183
51instance
184instance
52 ( Generic a,
185 ( Generic a,
53− GArbitrary a (Rep a) 'True,
186+ GArbitrary a (Rep a) some,
54 RecursivelyShrink (Rep a),
187 RecursivelyShrink (Rep a),
55 GSubterms (Rep a) a
188 GSubterms (Rep a) a
56 ) => Arbitrary (GenericArbitrary a) where
189 ) => Arbitrary (GenericArbitrary a) where
57 arbitrary = coerce (genericArbitrary :: Gen a)
190 arbitrary = coerce (genericArbitrary :: Gen a)
58 shrink = coerce (genericShrink :: a -> [a])
191 shrink = coerce (genericShrink :: a -> [a])
192+#endif
193+
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+
210+type family TypesDiffer a b where
211+ TypesDiffer a a = 'False
212+ TypesDiffer a b = 'True
59
213
60type family AllFieldsFinal self (a :: * -> *) :: Bool where
214type family AllFieldsFinal self (a :: * -> *) :: Bool where
61 AllFieldsFinal self U1 = 'True
215 AllFieldsFinal self U1 = 'True
62 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b
216 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b
63− AllFieldsFinal self (M1 S t (K1 R self)) = 'False
217+ AllFieldsFinal self (M1 S t (K1 R field)) = TypesDiffer self field
64− AllFieldsFinal self (M1 S t (K1 R other)) = 'True
65
218
66type family Finite self (a :: * -> *) :: Bool where
219type family Finite self (a :: * -> *) :: Bool where
67 Finite self U1 = 'True
220 Finite self U1 = 'True
68− Finite self (K1 R self) = 'False
221+ Finite self (K1 R field) = TypesDiffer self field
69− Finite self (K1 R other) = 'True
70 Finite self (a :*: b) = Finite self a && Finite self b
222 Finite self (a :*: b) = Finite self a && Finite self b
71 Finite self (M1 D t f) = Finite self f
223 Finite self (M1 D t f) = Finite self f
72 Finite self (a :+: b) = Finite self a || Finite self b
224 Finite self (a :+: b) = Finite self a || Finite self b
@@ -94,8 +246,8 @@ class (Finite self a ~ finite) => GArbitrary self a (finite :: Bool) where
94 gArbitrary :: Proxy self -> QC.Gen (a x)
246 gArbitrary :: Proxy self -> QC.Gen (a x)
95
247
96instance
248instance
97− ( GArbitrary self (C1 c f) 'True
249+ ( GArbitrary self (M1 C c f) 'True
98− ) => GArbitrary self (D1 t (C1 c f)) 'True where
250+ ) => GArbitrary self (M1 D t (M1 C c f)) 'True where
99 gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)
251 gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)
100
252
101-- | The constructor meta information
253-- | The constructor meta information
@@ -103,7 +255,7 @@ instance
103 ( GArbitrary self f some
255 ( GArbitrary self f some
104 , KnownNat (ArgumentsCount f)
256 , KnownNat (ArgumentsCount f)
105 , AllFieldsFinal self f ~ some
257 , AllFieldsFinal self f ~ some
106− ) => GArbitrary self (C1 c f) some where
258+ ) => GArbitrary self (M1 C c f) some where
107 gArbitrary _ = M1 <$> scale predNat (gArbitrary (Proxy :: Proxy self))
259 gArbitrary _ = M1 <$> scale predNat (gArbitrary (Proxy :: Proxy self))
108 where
260 where
109 argumentsCount = fromIntegral $ natVal (Proxy :: Proxy (ArgumentsCount f))
261 argumentsCount = fromIntegral $ natVal (Proxy :: Proxy (ArgumentsCount f))
@@ -116,14 +268,14 @@ instance GArbitrary self U1 'True where
116 gArbitrary _ = pure U1
268 gArbitrary _ = pure U1
117
269
118-- | Constructor field meta information
270-- | Constructor field meta information
119−instance GArbitrary self f some => GArbitrary self (S1 t f) some where
271+instance GArbitrary self f some => GArbitrary self (M1 S t f) some where
120 gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)
272 gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)
121
273
122-- | Data of the constructor field
274-- | Data of the constructor field
123instance
275instance
124 ( Arbitrary t
276 ( Arbitrary t
125− , Finite self (Rec0 t) ~ some
277+ , Finite self (K1 R t) ~ some
126− ) => GArbitrary self (Rec0 t) some where
278+ ) => GArbitrary self (K1 R t) some where
127 gArbitrary _ = K1 <$> arbitrary
279 gArbitrary _ = K1 <$> arbitrary
128
280
129-- | Product
281-- | Product
@@ -139,7 +291,7 @@ instance
139instance
291instance
140 ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
292 ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
141 , AllFieldsFinal self f ~ 'False
293 , AllFieldsFinal self f ~ 'False
142− ) => GArbitrary self (D1 t (C1 c f)) 'False where
294+ ) => GArbitrary self (M1 D t (M1 C c f)) 'False where
143 gArbitrary _ = error "Unreachable"
295 gArbitrary _ = error "Unreachable"
144#endif
296#endif
145
297
@@ -147,7 +299,7 @@ instance
147instance
299instance
148 ( FiniteSum self a b af bf
300 ( FiniteSum self a b af bf
149 , GArbitrary self (a :+: b) 'True
301 , GArbitrary self (a :+: b) 'True
150− ) => GArbitrary self (D1 t (a :+: b)) 'True where
302+ ) => GArbitrary self (M1 D t (a :+: b)) 'True where
151 gArbitrary _ = sized $ \s -> M1 <$>
303 gArbitrary _ = sized $ \s -> M1 <$>
152 if s > 1
304 if s > 1
153 then gArbitrary (Proxy :: Proxy self)
305 then gArbitrary (Proxy :: Proxy self)
@@ -203,8 +355,8 @@ instance
203 finiteElem _ = finiteSum (Proxy :: Proxy self)
355 finiteElem _ = finiteSum (Proxy :: Proxy self)
204
356
205instance
357instance
206− ( GArbitrary self (C1 c f) 'True
358+ ( GArbitrary self (M1 C c f) 'True
207− ) => FiniteSumElem self (C1 c f) where
359+ ) => FiniteSumElem self (M1 C c f) where
208 finiteElem _ = [gArbitrary (Proxy :: Proxy self)]
360 finiteElem _ = [gArbitrary (Proxy :: Proxy self)]
209
361
210
362
@@ -212,7 +364,7 @@ instance
212instance
364instance
213 ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
365 ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")
214 , (Finite self a || Finite self b) ~ 'False
366 , (Finite self a || Finite self b) ~ 'False
215− ) => GArbitrary self (D1 t (a :+: b)) 'False where
367+ ) => GArbitrary self (M1 D t (a :+: b)) 'False where
216 gArbitrary _ = error "Unreachable"
368 gArbitrary _ = error "Unreachable"
217#endif
369#endif
218
370
stack.yaml+1−5
@@ -1,5 +1 @@
1−resolver: lts-13.21
1+resolver: lts-19.2
2−
3−extra-deps:
4− - QuickCheck-2.14
5− - splitmix-0.0.5
stack.yaml.lock+5−19
@@ -3,24 +3,10 @@
3# For more information, please see the documentation at:
3# For more information, please see the documentation at:
4# https://docs.haskellstack.org/en/stable/lock_files
4# https://docs.haskellstack.org/en/stable/lock_files
5
5
6−packages:
6+packages: []
7−- completed:
8− hackage: QuickCheck-2.14@sha256:3f536a4b86bef7ec39025f04ef8d76c5ac5a78ba0b42e660b25d0a8f9c811045,7004
9− pantry-tree:
10− size: 2203
11− sha256: 7067593c50ff2e5e83c637ac73009f4bd8f43c29ff256e976bbb14674033abe9
12− original:
13− hackage: QuickCheck-2.14
14−- completed:
15− hackage: splitmix-0.0.5@sha256:4a49661be63f5aea0e132e9ab51be918789bb4dceb4ab9b15b85ba9cbbef5999,5412
16− pantry-tree:
17− size: 1148
18− sha256: b41d4f60cfabab8b02840906191013ee06fe2357371103a471c7cc55eda9e462
19− original:
20− hackage: splitmix-0.0.5
21snapshots:
7snapshots:
22- completed:
8- completed:
9+ sha256: e7e57649a12f6178d1158e4b6f1f1885ed56d210ae6174385271cecc9b1ea974
23− size: 498180
10+ size: 617368
24− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/13/21.yaml
11+ url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/2.yaml
25− sha256: eff2de19a6d4691ccbf6edc1fba858f1918683047dce0f09adede874bbd2a8f3
26− original: lts-13.21
12+ original: lts-19.2
test/Auxiliary.hsnew file+10
@@ -0,0 +1,10 @@
1+module Auxiliary 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/EnumTest.hsnew file+24
@@ -0,0 +1,24 @@
1+#if __GLASGOW_HASKELL__ >= 806 && __GLASGOW_HASKELL__ <= 900
2+{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-}
3+#elif __GLASGOW_HASKELL__ >= 902
4+{-# OPTIONS_GHC -fconstraint-solver-iterations=6 #-}
5+#endif
6+
7+
8+
9+module EnumTest where
10+
11+import Control.DeepSeq
12+import GHC.Generics
13+import Test.QuickCheck
14+import Test.QuickCheck.Arbitrary.Generic
15+
16+data Country = PL | GB | RU | RO | CZ | HR | SK | DE | NL | ES | BR
17+ deriving (Generic, NFData, Show)
18+
19+instance Arbitrary Country where
20+ arbitrary = genericArbitrary
21+ shrink = genericShrink
22+
23+prop_CountryTest :: Country -> Property
24+prop_CountryTest = total
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.hs+5−7
@@ -1,25 +1,23 @@
1{-# OPTIONS_GHC -fdefer-type-errors #-}
1{-# OPTIONS_GHC -fdefer-type-errors #-}
2+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}
2
3
3-- | Test that infinite types has no Arbitrary instance
4-- | Test that infinite types has no Arbitrary instance
4
5
5module NoTypecheckTest where
6module NoTypecheckTest where
6
7
7−import Control.Exception
8+import Auxiliary
8import GHC.Generics (Generic)
9import GHC.Generics (Generic)
9import Test.QuickCheck
10import Test.QuickCheck
10import Test.QuickCheck.Arbitrary.Generic
11import Test.QuickCheck.Arbitrary.Generic
11
12
12−
13+-- | Recursive infinite type which can not have valid Arbitrary instance
13data R = R R
14data R = R R
14 deriving (Eq, Show, Generic)
15 deriving (Eq, Show, Generic)
15
16
16−-- | Instance which must not be valid
17+-- | Instance which must not compile, but we are using deferred type errors
17instance Arbitrary R where
18instance Arbitrary R where
18 arbitrary = genericArbitrary
19 arbitrary = genericArbitrary
19 shrink = genericShrink
20 shrink = genericShrink
20
21
21unit_mustFail :: IO ()
22unit_mustFail :: IO ()
22−unit_mustFail = do
23+unit_mustFail = failGeneration @R
23− try (generate (arbitrary :: Gen R) >>= print) >>= \case
24− Left (_ :: SomeException) -> pure ()
25− Right _ -> error "Error expected"
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 Auxiliary
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.hs+53−23
@@ -1,45 +1,56 @@
1+{-# LANGUAGE DerivingStrategies #-}
2+{-# LANGUAGE DerivingVia #-}
3+{-# LANGUAGE DeriveAnyClass #-}
4+{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-} -- GHC-9.2.4
5+
1-- | Testing that our Arbitrary instances do not get stuck and respect the
6-- | Testing that our Arbitrary instances do not get stuck and respect the
2-- `size` parameter while generating.
7-- `size` parameter while generating.
3
8
4module RecursiveTest where
9module RecursiveTest where
5
10
6−import Control.DeepSeq
11+import Control.DeepSeq (NFData)
7import GHC.Generics (Generic)
12import GHC.Generics (Generic)
8import Test.QuickCheck
13import Test.QuickCheck
9import Test.QuickCheck.Arbitrary.Generic
14import Test.QuickCheck.Arbitrary.Generic
10
15
11data Unit = Unit
16data Unit = Unit
12 deriving (Eq, Show, Generic)
17 deriving (Eq, Show, Generic)
13−
18+ deriving anyclass NFData
14−instance NFData Unit
19+#if MIN_VERSION_QuickCheck(2, 14, 0)
15−
20+ deriving Arbitrary via (GenericArbitrary Unit)
21+#else
16instance Arbitrary Unit where
22instance Arbitrary Unit where
17 arbitrary = genericArbitrary
23 arbitrary = genericArbitrary
18 shrink = genericShrink
24 shrink = genericShrink
25+#endif
19
26
20prop_unitTotal :: Unit -> Property
27prop_unitTotal :: Unit -> Property
21prop_unitTotal = total
28prop_unitTotal = total
22
29
23data Single = Single Int
30data Single = Single Int
24 deriving (Eq, Show, Generic)
31 deriving (Eq, Show, Generic)
25−
32+ deriving anyclass NFData
26−instance NFData Single
33+#if MIN_VERSION_QuickCheck(2, 14, 0)
27−
34+ deriving Arbitrary via (GenericArbitrary Single)
35+#else
28instance Arbitrary Single where
36instance Arbitrary Single where
29 arbitrary = genericArbitrary
37 arbitrary = genericArbitrary
30 shrink = genericShrink
38 shrink = genericShrink
39+#endif
31
40
32prop_singleTotal :: Single -> Property
41prop_singleTotal :: Single -> Property
33prop_singleTotal = total
42prop_singleTotal = total
34
43
35data Multiple = M1 | M2 | M3 Int
44data Multiple = M1 | M2 | M3 Int
36 deriving (Eq, Show, Generic)
45 deriving (Eq, Show, Generic)
37−
46+ deriving anyclass NFData
38−instance NFData Multiple
47+#if MIN_VERSION_QuickCheck(2, 14, 0)
39−
48+ deriving Arbitrary via (GenericArbitrary Multiple)
49+#else
40instance Arbitrary Multiple where
50instance Arbitrary Multiple where
41 arbitrary = genericArbitrary
51 arbitrary = genericArbitrary
42 shrink = genericShrink
52 shrink = genericShrink
53+#endif
43
54
44prop_multipleTotal :: Multiple -> Property
55prop_multipleTotal :: Multiple -> Property
45prop_multipleTotal = total
56prop_multipleTotal = total
@@ -49,12 +60,14 @@ data Rec = Rec
49 , single :: Single
60 , single :: Single
50 , multiple :: Multiple
61 , multiple :: Multiple
51 } deriving (Eq, Show, Generic)
62 } deriving (Eq, Show, Generic)
52−
63+ deriving anyclass NFData
53−instance NFData Rec
64+#if MIN_VERSION_QuickCheck(2, 14, 0)
54−
65+ deriving Arbitrary via (GenericArbitrary Rec)
66+#else
55instance Arbitrary Rec where
67instance Arbitrary Rec where
56 arbitrary = genericArbitrary
68 arbitrary = genericArbitrary
57 shrink = genericShrink
69 shrink = genericShrink
70+#endif
58
71
59prop_recTotal :: Rec -> Property
72prop_recTotal :: Rec -> Property
60prop_recTotal = total
73prop_recTotal = total
@@ -64,13 +77,14 @@ data Expr
64 | Add Expr Expr
77 | Add Expr Expr
65 | Mul Expr Expr
78 | Mul Expr Expr
66 deriving (Eq, Show, Generic)
79 deriving (Eq, Show, Generic)
67−
80+ deriving anyclass NFData
68−-- | Instance with may fall into infinite loop
81+#if MIN_VERSION_QuickCheck(2, 14, 0)
82+ deriving Arbitrary via (GenericArbitrary Expr)
83+#else
69instance Arbitrary Expr where
84instance Arbitrary Expr where
70 arbitrary = genericArbitrary
85 arbitrary = genericArbitrary
71 shrink = genericShrink
86 shrink = genericShrink
72−
87+#endif
73−instance NFData Expr
74
88
75prop_exprTotal :: Expr -> Property
89prop_exprTotal :: Expr -> Property
76prop_exprTotal = total
90prop_exprTotal = total
@@ -83,12 +97,14 @@ data Recursive
83 | R4 Recursive
97 | R4 Recursive
84 | R5 Recursive String
98 | R5 Recursive String
85 deriving (Eq, Show, Generic)
99 deriving (Eq, Show, Generic)
86−
100+ deriving anyclass NFData
87−instance NFData Recursive
101+#if MIN_VERSION_QuickCheck(2, 14, 0)
88−
102+ deriving Arbitrary via (GenericArbitrary Recursive)
103+#else
89instance Arbitrary Recursive where
104instance Arbitrary Recursive where
90 arbitrary = genericArbitrary
105 arbitrary = genericArbitrary
91 shrink = genericShrink
106 shrink = genericShrink
107+#endif
92
108
93prop_recursiveTotal :: Recursive -> Property
109prop_recursiveTotal :: Recursive -> Property
94prop_recursiveTotal = total
110prop_recursiveTotal = total
@@ -97,12 +113,26 @@ data DeepRecursive
97 = Deep DeepRecursive DeepRecursive DeepRecursive DeepRecursive DeepRecursive
113 = Deep DeepRecursive DeepRecursive DeepRecursive DeepRecursive DeepRecursive
98 | Short
114 | Short
99 deriving (Eq, Show, Generic)
115 deriving (Eq, Show, Generic)
100−
116+ deriving anyclass NFData
101−instance NFData DeepRecursive
117+#if MIN_VERSION_QuickCheck(2, 14, 0)
102−
118+ deriving Arbitrary via (GenericArbitrary DeepRecursive)
119+#else
103instance Arbitrary DeepRecursive where
120instance Arbitrary DeepRecursive where
104 arbitrary = genericArbitrary
121 arbitrary = genericArbitrary
105 shrink = genericShrink
122 shrink = genericShrink
123+#endif
106
124
107prop_deepRecursiveTotal :: DeepRecursive -> Property
125prop_deepRecursiveTotal :: DeepRecursive -> Property
108prop_deepRecursiveTotal = total
126prop_deepRecursiveTotal = total
127+
128+data P p = NoP | P p
129+ deriving (Eq, Show, Generic)
130+ deriving anyclass NFData
131+
132+-- Note that deriving via doesn't work for case with arguments
133+instance (Arg (P p) p, Arbitrary p) => Arbitrary (P p) where
134+ arbitrary = genericArbitrary
135+ shrink = genericShrink
136+
137+prop_Ptotal :: P (P Int) -> Property
138+prop_Ptotal = total