git.iko.soy/typeable/generic-arbitrary
on master help sign in
more test and docs
961d7efAleksey Uymanov
generic-arbitrary.cabal+4−1
compare with master
unifiedsplit
@@ -62,8 +62,10 @@ test-suite test
62 , tasty-discover
62 , tasty-discover
63 , tasty-hunit
63 , tasty-hunit
64 , tasty-quickcheck
64 , tasty-quickcheck
65+ other-modules: Aux
65− other-modules: LimitationDemo
66+ , LimitationDemo
66 , NoTypecheckTest
67 , NoTypecheckTest
68+ , ParametersTest
67 , RecursiveTest
69 , RecursiveTest
68 default-extensions: AllowAmbiguousTypes
70 default-extensions: AllowAmbiguousTypes
69 , CPP
71 , CPP
@@ -80,6 +82,7 @@ test-suite test
80 , PolyKinds
82 , PolyKinds
81 , RankNTypes
83 , RankNTypes
82 , ScopedTypeVariables
84 , ScopedTypeVariables
85+ , TypeApplications
83 , TypeFamilies
86 , TypeFamilies
84 , TypeOperators
87 , TypeOperators
85 , TypeSynonymInstances
88 , TypeSynonymInstances
src/Test/QuickCheck/Arbitrary/Generic.hs+60−5
@@ -1,6 +1,7 @@
1−{- |
1+{-|
2
2
3−Generic implementation of the 'arbitrary' method. Example usage:
3+This module is a generic implementation of the 'arbitrary' method. Example
4+usage:
4
5
5@
6@
6data Foo = Foo
7data Foo = Foo
@@ -74,8 +75,52 @@ data R2 = R2 R1
74@
75@
75
76
76This code will compile and the @arbitrary@ generated will always hand. Yes,
77This code will compile and the @arbitrary@ generated will always hand. Yes,
77−there is a problem with mutually recursive types
78+there is a problem with mutually recursive types.
78
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 on compilation 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.
79
124
80-}
125-}
81
126
@@ -85,10 +130,18 @@ module Test.QuickCheck.Arbitrary.Generic
85 , GenericArbitrary(..)
130 , GenericArbitrary(..)
86#endif
131#endif
87 , Arg
132 , Arg
133+ , TypesDiffer
134+ , AllFieldsFinal
135+ , Finite
136+ , ArgumentsCount
137+ , SumLen
88 , genericArbitrary
138 , genericArbitrary
89 , genericShrink
139 , genericShrink
90 ) where
140 ) where
91
141
142+
143+
144+
92import Control.Applicative
145import Control.Applicative
93import Data.Coerce (coerce)
146import Data.Coerce (coerce)
94import Data.Proxy
147import Data.Proxy
@@ -99,6 +152,8 @@ import Test.QuickCheck as QC
99#if MIN_VERSION_QuickCheck(2, 14, 0)
152#if MIN_VERSION_QuickCheck(2, 14, 0)
100import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
153import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink)
101
154
155+
156+
102-- | Newtype for @DerivingVia@
157-- | Newtype for @DerivingVia@
103newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
158newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }
104 deriving (Show, Eq)
159 deriving (Show, Eq)
@@ -113,12 +168,12 @@ instance
113 shrink = coerce (genericShrink :: a -> [a])
168 shrink = coerce (genericShrink :: a -> [a])
114#endif
169#endif
115
170
171+type Arg self field = (TypesDiffer self field ~ 'True)
172+
116type family TypesDiffer a b where
173type family TypesDiffer a b where
117 TypesDiffer a a = 'False
174 TypesDiffer a a = 'False
118 TypesDiffer a b = 'True
175 TypesDiffer a b = 'True
119
176
120−type Arg self field = (TypesDiffer self field ~ 'True)
121−
122type family AllFieldsFinal self (a :: * -> *) :: Bool where
177type family AllFieldsFinal self (a :: * -> *) :: Bool where
123 AllFieldsFinal self U1 = 'True
178 AllFieldsFinal self U1 = 'True
124 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b
179 AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b
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/NoTypecheckTest.hs+2−5
@@ -5,7 +5,7 @@
5
5
6module NoTypecheckTest where
6module NoTypecheckTest where
7
7
8−import Control.Exception
8+import Aux
9import GHC.Generics (Generic)
9import GHC.Generics (Generic)
10import Test.QuickCheck
10import Test.QuickCheck
11import Test.QuickCheck.Arbitrary.Generic
11import Test.QuickCheck.Arbitrary.Generic
@@ -20,7 +20,4 @@ instance Arbitrary R where
20 shrink = genericShrink
20 shrink = genericShrink
21
21
22unit_mustFail :: IO ()
22unit_mustFail :: IO ()
23−unit_mustFail = do
23+unit_mustFail = failGeneration @R
24− try (generate (arbitrary :: Gen R) >>= print) >>= \case
25− Left (_ :: SomeException) -> pure ()
26− 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 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