generic-arbitrary 0.1.0 → 1.0.1.2
raw patch · 11 files changed
Files
- CHANGELOG.md +39/−0
- README.md +140/−0
- generic-arbitrary.cabal +82/−4
- src/Test/QuickCheck/Arbitrary/Generic.hs +336/−28
- test/Auxiliary.hs +10/−0
- test/EnumTest.hs +24/−0
- test/LimitationDemo.hs +37/−0
- test/NoTypecheckTest.hs +23/−0
- test/ParametersTest.hs +34/−0
- test/RecursiveTest.hs +138/−0
- test/Test.hs +1/−0
CHANGELOG.md view
@@ -1,3 +1,42 @@+1.0.1.2+-------++* Fix dependency bounds (including retroactively), and compilation with warnings.++1.0.1.1+-------++* Fix compilation with GHC 9.8.3++1.0.1+-----++* Compillability by GHC-9.2.4+* Fix cabal `tested-with` field++1.0.0+-----++* Fixed issue with too big terms in case of recursive types+* Recpect the `size` argument+* Types with parameters require `Arg` now++0.2.2+-----++* Resolved an issue where the size of the generators could become negative++0.2.1+-----++* Added compatibility with GHC 9.2.1++0.2.0+-----++* Added `GenericArbitrary` for use with the [DerivingVia](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/deriving_via.html) compiler extension.+* Minimum bound on QuickCheck changed to 2.14.+ 0.1.0 -----
+ README.md view
@@ -0,0 +1,140 @@+# generic-arbitrary++[](https://github.com/typeable/generic-arbitrary/actions/workflows/haskell-ci.yml)++# What?++Package for deriving `Arbitrary` via `Generic`.++``` haskell+import GHC.Generics (Generic)+import Test.QuickCheck+import Test.QuickCheck.Arbitrary.Generic++data Expr+ = Lit Int+ | Add Expr Expr+ | Mul Expr Expr+ deriving (Eq, Show, Generic)+ deriving Arbitrary via (GenericArbitrary Expr)+```++Older versions of this package had a problem with hanging `arbitrary`+method. Since `1.0.0` this problem almost solved.++For `QuickCheck` older than `2.14.0` the `GenericArbitrary` is not available, so+you will need to write instances more verbosely++``` haskell+data Expr+ = Lit Int+ | Add Expr Expr+ | Mul Expr Expr+ deriving (Eq, Show, Generic)++instance Arbitrary Expr where+ arbitrary = genericArbitrary+ shrink = genericShrink+```++Which is generally the same.++# Infinite terms problem++The `generic-arbitrary` can partially handle the problem with recursive+types. Assume the type `R`++``` haskell+data R = R R+ deriving Generic+```++there is no instance++``` haskell+instance Arbitrary R where+ arbitrary = genericArbitrary+ shrink = genericShrink+```++If you try to compile this you will get a type level error++> • R refers to itself in all constructors++Which means that there is no finite term for `R` because it is recursive in all+it's constructors. But, if you correct the definition of `R` like this.++``` haskell+data R = R R | F+ deriving Generic+```++Then it will compile. And the `arbitrary` generated will not hang forever,+because it respects the `size` parameter.++## Limitation++There is a limitation of recursion detection:++``` haskell+data R1 = R1 R2+ deriving (Eq, Ord, Show, Generic)+ deriving anyclass NFData+ deriving Arbitrary via (GenericArbitrary R1)++data R2 = R2 R1+ deriving (Eq, Ord, Show, Generic)+ deriving anyclass NFData+ deriving Arbitrary via (GenericArbitrary R2)+```++This code will compile and the `arbitrary` generated will always hang. Yes,+there is a problem with mutually recursive types.++# Type parameters++Now let's see an example of datatype with parameters++``` haskell+data A a = A a+ deriving (Eq, Ord, Show)+ deriving anyclass NFData+ deriving (Generic)++instance (Arbitrary a) => Arbitrary (A a) where+ arbitrary = genericArbitrary+ shrink = genericShrink+```++It should work from first glance, but when compile it will throw an error:++```+• Could not deduce (Test.QuickCheck.Arbitrary.Generic.GArbitrary+ (A a)+ (GHC.Generics.D1+ ('GHC.Generics.MetaData "A" "ParametersTest" "main" 'False)+ (GHC.Generics.C1+ ('GHC.Generics.MetaCons "A" 'GHC.Generics.PrefixI 'False)+ (GHC.Generics.S1+ ('GHC.Generics.MetaSel+ 'Nothing+ 'GHC.Generics.NoSourceUnpackedness+ 'GHC.Generics.NoSourceStrictness+ 'GHC.Generics.DecidedLazy)+ (GHC.Generics.Rec0 a))))+ (TypesDiffer (A a) a))+ arising from a use of ‘genericArbitrary’+```++Here the `TypesDiffer` is a type familty dealing with recursive types and+helping us to eliminate inproper instances. To convince the compiller, that the+`a` parameter is not an `A a` we must fix the instance with additional+constraint `Arg (A a) a`++``` haskell+instance (Arg (A a) a, Arbitrary a) => Arbitrary (A a) where+ arbitrary = genericArbitrary+ shrink = genericShrink+```++Now everything compiles and works as expected.
generic-arbitrary.cabal view
@@ -1,23 +1,101 @@ name: generic-arbitrary-version: 0.1.0+version: 1.0.1.2 synopsis: Generic implementation for QuickCheck's Arbitrary description: Generic implementations of methods of the 'Arbitrary' class from the QuickCheck library. The approach taken here can lead to diverging instances- for recursive types but is safe for non-recursive ones and guarantees+ for mutually recursive types but is safe for simply recursive ones and guarantees flat distribution for constructors of sum-types. license: MIT license-file: LICENSE author: Typeable.io contributors maintainer: makeit@typeable.io+homepage: http://github.com/typeable/generic-arbitrary#readme category: Generic build-type: Simple extra-source-files: CHANGELOG.md-cabal-version: >=1.22+ , README.md+cabal-version: 2.0+tested-with: GHC == 8.6.5+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.4+ , GHC == 9.4.3+ , GHC == 9.8.1 +source-repository head+ type: git+ location: https://github.com/typeable/generic-arbitrary.git+ library exposed-modules: Test.QuickCheck.Arbitrary.Generic- build-depends: QuickCheck >= 2.8, base >=4.8 && <5+ build-depends: base >=4.8 && <5+ , QuickCheck >=2.8 hs-source-dirs: src default-language: Haskell2010+ default-extensions: AllowAmbiguousTypes+ , CPP+ , ConstraintKinds+ , DataKinds+ , DeriveGeneric+ , FlexibleContexts+ , FlexibleInstances+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , PolyKinds+ , RankNTypes+ , ScopedTypeVariables+ , TypeFamilies+ , TypeOperators+ , TypeSynonymInstances+ , UndecidableInstances+ , ViewPatterns+++test-suite test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Test.hs+ default-language: Haskell2010+ build-depends: base >=4.12 && <5+ , QuickCheck >=2.10+ , deepseq+ , generic-arbitrary+ , tasty >=1.4.2 || <1.4.0.1+ , tasty-discover >= 2.0.0+ , tasty-hunit >= 0.9.2+ , tasty-quickcheck+ other-modules: Auxiliary+ , EnumTest+ , LimitationDemo+ , NoTypecheckTest+ , ParametersTest+ , RecursiveTest+ default-extensions: AllowAmbiguousTypes+ , CPP+ , DataKinds+ , DeriveAnyClass+ , DeriveGeneric+ , DerivingStrategies+ , DerivingVia+ , FlexibleContexts+ , FlexibleInstances+ , GeneralizedNewtypeDeriving+ , LambdaCase+ , MultiParamTypeClasses+ , PolyKinds+ , RankNTypes+ , ScopedTypeVariables+ , TypeApplications+ , TypeFamilies+ , TypeOperators+ , TypeSynonymInstances+ , UndecidableInstances+ , ViewPatterns+ build-tool-depends: tasty-discover:tasty-discover+ ghc-options: -Wall+ -threaded+ -rtsopts+ "-with-rtsopts=-N -A64m -qb0 -n4m -T -I1"
src/Test/QuickCheck/Arbitrary/Generic.hs view
@@ -1,8 +1,14 @@-{-# LANGUAGE UndecidableInstances, TypeOperators, DataKinds, TypeFamilies, ScopedTypeVariables#-}+#if __GLASGOW_HASKELL__ >= 806+{-# OPTIONS_GHC -Wno-star-is-type #-}+#endif+#if __GLASGOW_HASKELL__ >= 800+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}+#endif -{- |+{-| -Generic implementation of the 'arbitrary' method. Example usage:+This module is a generic implementation of the 'arbitrary' method. Example+usage: @ data Foo = Foo@@ -15,53 +21,355 @@ shrink = genericShrink @ +This instance can also be derived using DerivingVia language extension++@+data Foo = Foo+ { _fooX :: X+ , _fooY :: Y+ } deriving (Generic)+ deriving (Arbitrary) via GenericArbitrary Foo+@+ The generated 'arbitrary' method is equivalent to -@Foo <$> arbitrary <*> arbitrary@.+@+Foo '<$>' arbitrary '<*>' arbitrary+@. +It can also handle a recursive types problem. Assuming a type++@+data R = R R+ deriving Generic+@++there is no instance++@+instance Arbitrary R where+ arbitrary = genericArbitrary+ shrink = genericShrink+@++If you try to compile this you will get a type level error++> • R refers to itself in all constructors++Which means that there is no finite term for @R@ because it is recursive. But,+if you correct the definition of @R@ like this.++@+data R = R R | F+ deriving Generic+@++Then it will compile. And the @arbitrary@ generated will not hang forever, because+it respects the @size@ parameter.++There is a limitation of recursion detection:++@+data R1 = R1 R2+ deriving (Eq, Ord, Show, Generic)+ deriving anyclass NFData+ deriving Arbitrary via (GenericArbitrary R1)++data R2 = R2 R1+ deriving (Eq, Ord, Show, Generic)+ deriving anyclass NFData+ deriving Arbitrary via (GenericArbitrary R2)+@++This code will compile and the @arbitrary@ generated will always hang. Yes,+there is a problem with mutually recursive types.++Now lets see an example of datatype with parameters++@+data A a = A a+ deriving (Eq, Ord, Show)+ deriving anyclass NFData+ deriving (Generic)++instance (Arbitrary a) => Arbitrary (A a) where+ arbitrary = genericArbitrary+ shrink = genericShrink+@++It should work from first glance, but when compile it will throw an error:++@+ • Could not deduce (Test.QuickCheck.Arbitrary.Generic.GArbitrary+ (A a)+ (GHC.Generics.D1+ ('GHC.Generics.MetaData "A" "ParametersTest" "main" 'False)+ (GHC.Generics.C1+ ('GHC.Generics.MetaCons "A" 'GHC.Generics.PrefixI 'False)+ (GHC.Generics.S1+ ('GHC.Generics.MetaSel+ 'Nothing+ 'GHC.Generics.NoSourceUnpackedness+ 'GHC.Generics.NoSourceStrictness+ 'GHC.Generics.DecidedLazy)+ (GHC.Generics.Rec0 a))))+ (TypesDiffer (A a) a))+ arising from a use of ‘genericArbitrary’+@++Here the @TypesDiffer@ is a type familty dealing with recursive types and+helping us to eliminate inproper instances. To convince the compiller, that the+@a@ parameter is not an @A a@ we must fix the instance with additional constraint++@+instance (Arg (A a) a, Arbitrary a) => Arbitrary (A a) where+ arbitrary = genericArbitrary+ shrink = genericShrink+@++Now everything compiles and works as expected.+ -} module Test.QuickCheck.Arbitrary.Generic- ( Arbitrary(..)- , genericArbitrary+ ( -- * Main+ genericArbitrary+#if MIN_VERSION_QuickCheck(2, 14, 0)+ , GenericArbitrary(..)+#endif+ , Arg+ -- * Internal+ , GArbitrary+ , FiniteSum+ , FiniteSumElem+ , Finite+ , AllFieldsFinal+ , TypesDiffer+ , ArgumentsCount+ , SumLen+ -- * Reexports+ , Arbitrary(..) , genericShrink ) where -import Control.Applicative-import Data.Proxy-import GHC.Generics as G-import GHC.TypeLits-import Test.QuickCheck as QC+import Control.Applicative+import Data.Proxy+import Data.Type.Bool+import GHC.Generics as G+import GHC.TypeLits+import Prelude+import Test.QuickCheck as QC+#if MIN_VERSION_QuickCheck(2, 14, 0)+import Data.Coerce (coerce)+import Test.QuickCheck.Arbitrary (GSubterms, RecursivelyShrink) -class GArbitrary a where- gArbitrary :: QC.Gen (a x) -instance GArbitrary G.U1 where- gArbitrary = pure G.U1 -instance Arbitrary c => GArbitrary (G.K1 i c) where- gArbitrary = G.K1 <$> arbitrary+-- | Newtype for @DerivingVia@+--+-- Usage:+--+-- @+-- data Foo = Foo+-- { _fooX :: X+-- , _fooY :: Y+-- } deriving (Generic)+-- deriving (Arbitrary) via GenericArbitrary Foo+-- @+--+-- @since 1.0.0+newtype GenericArbitrary a = GenericArbitrary { unGenericArbitrary :: a }+ deriving (Show, Eq) -instance GArbitrary f => GArbitrary (G.M1 i c f) where- gArbitrary = G.M1 <$> gArbitrary+instance+ ( Generic a,+ GArbitrary a (Rep a) some,+ RecursivelyShrink (Rep a),+ GSubterms (Rep a) a+ ) => Arbitrary (GenericArbitrary a) where+ arbitrary = coerce (genericArbitrary :: Gen a)+ shrink = coerce (genericShrink :: a -> [a])+#endif -instance (GArbitrary a, GArbitrary b) => GArbitrary (a G.:*: b) where- gArbitrary = liftA2 (G.:*:) gArbitrary gArbitrary+-- | Constraint helper for types with parameters+--+-- Usage:+--+-- @+-- data A a = A a+-- deriving (Generic)+-- instance (Arg (A a) a, Arbitrary a) => Arbitrary (A a) where+-- arbitrary = genericArbitrary+-- shrink = genericShrink+-- @+--+-- @since 1.0.0 +type Arg self field = (TypesDiffer self field ~ 'True)++type family TypesDiffer a b where+ TypesDiffer a a = 'False+ TypesDiffer a b = 'True++type family AllFieldsFinal self (a :: * -> *) :: Bool where+ AllFieldsFinal self U1 = 'True+ AllFieldsFinal self (a :*: b) = AllFieldsFinal self a && AllFieldsFinal self b+ AllFieldsFinal self (M1 S t (K1 R field)) = TypesDiffer self field++type family Finite self (a :: * -> *) :: Bool where+ Finite self U1 = 'True+ Finite self (K1 R field) = TypesDiffer self field+ Finite self (a :*: b) = Finite self a && Finite self b+ Finite self (M1 D t f) = Finite self f+ Finite self (a :+: b) = Finite self a || Finite self b+ Finite self (M1 C c f) = AllFieldsFinal self f+ Finite self (M1 S s f) = Finite self f++type family ArgumentsCount (a :: * -> *) :: Nat where+ ArgumentsCount U1 = 1+ ArgumentsCount (M1 S s f) = 1+ ArgumentsCount (a :*: b) = (ArgumentsCount a) + (ArgumentsCount b)+ -- | Calculates count of constructors encoded by particular ':+:'. -- Internal use only. type family SumLen a :: Nat where SumLen (a G.:+: b) = (SumLen a) + (SumLen b) SumLen a = 1 -instance (GArbitrary a, GArbitrary b, KnownNat (SumLen a), KnownNat (SumLen b)- ) => GArbitrary (a G.:+: b) where- gArbitrary = frequency- [ (lfreq, G.L1 <$> gArbitrary)- , (rfreq, G.R1 <$> gArbitrary) ]+-- | Generic arbitrary.+--+-- Parameters are:+-- * self: the ADT we generating instance for+-- * a: some part of the `Rep self`+-- * finite: Is `a` finite? Infinite type has no finite values (like Stream)+class (Finite self a ~ finite) => GArbitrary self a (finite :: Bool) where+ gArbitrary :: Proxy self -> QC.Gen (a x)++instance+ ( GArbitrary self (M1 C c f) 'True+ ) => GArbitrary self (M1 D t (M1 C c f)) 'True where+ gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)++-- | The constructor meta information+instance+ ( GArbitrary self f some+ , KnownNat (ArgumentsCount f)+ , AllFieldsFinal self f ~ some+ ) => GArbitrary self (M1 C c f) some where+ gArbitrary _ = M1 <$> scale predNat (gArbitrary (Proxy :: Proxy self)) where+ argumentsCount = fromIntegral $ natVal (Proxy :: Proxy (ArgumentsCount f))+ predNat n = max 0 $ if argumentsCount > 1+ then n `div` argumentsCount+ else pred n++-- | Unit type instance+instance GArbitrary self U1 'True where+ gArbitrary _ = pure U1++-- | Constructor field meta information+instance GArbitrary self f some => GArbitrary self (M1 S t f) some where+ gArbitrary _ = M1 <$> gArbitrary (Proxy :: Proxy self)++-- | Data of the constructor field+instance+ ( Arbitrary t+ , Finite self (K1 R t) ~ some+ ) => GArbitrary self (K1 R t) some where+ gArbitrary _ = K1 <$> arbitrary++-- | Product+instance+ ( GArbitrary self a af+ , GArbitrary self b bf+ , (af && bf) ~ some+ ) => GArbitrary self (a :*: b) some where+ gArbitrary _ = liftA2 (:*:)+ (gArbitrary (Proxy :: Proxy self)) (gArbitrary (Proxy :: Proxy self))++#if __GLASGOW_HASKELL__ >= 800+instance+ ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")+ , AllFieldsFinal self f ~ 'False+ ) => GArbitrary self (M1 D t (M1 C c f)) 'False where+ gArbitrary _ = error "Unreachable"+#endif++-- | ADT declaration with multiple constructors+instance+ ( FiniteSum self a b af bf+ , GArbitrary self (a :+: b) 'True+ ) => GArbitrary self (M1 D t (a :+: b)) 'True where+ gArbitrary _ = sized $ \s -> M1 <$>+ if s > 1+ then gArbitrary (Proxy :: Proxy self)+ else oneof (finiteSum (Proxy :: Proxy self))++-- | Any sum inside of declaration+instance+ ( GArbitrary self a af, GArbitrary self b bf+ , KnownNat (SumLen a), KnownNat (SumLen b)+ , (af || bf) ~ some+ ) => GArbitrary self (a :+: b) some where+ gArbitrary _ = frequency+ [ (lfreq, G.L1 <$> gArbitrary (Proxy :: Proxy self))+ , (rfreq, G.R1 <$> gArbitrary (Proxy :: Proxy self)) ]+ where lfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen a)) rfreq = fromIntegral $ natVal (Proxy :: Proxy (SumLen b)) -genericArbitrary :: (Generic a, GArbitrary ga, ga ~ G.Rep a) => Gen a-genericArbitrary = G.to <$> gArbitrary+class+ ( Finite self a ~ af, Finite self b ~ bf+ ) => FiniteSum self (a :: * -> *) (b :: * -> *) af bf where+ finiteSum :: Proxy self -> [Gen ((a :+: b) p)]++instance+ ( FiniteSumElem self a, FiniteSumElem self b+ , Finite self a ~ 'True+ , Finite self b ~ 'True+ ) => FiniteSum self a b 'True 'True where+ finiteSum _ = concat+ [ fmap L1 <$> finiteElem (Proxy :: Proxy self)+ , fmap R1 <$> finiteElem (Proxy :: Proxy self)]++instance+ ( FiniteSumElem self a+ , Finite self a ~ 'True+ , Finite self b ~ 'False+ ) => FiniteSum self a b 'True 'False where+ finiteSum _ = fmap L1 <$> finiteElem (Proxy :: Proxy self)++instance+ ( FiniteSumElem self b+ , Finite self a ~ 'False+ , Finite self b ~ 'True+ ) => FiniteSum self a b 'False 'True where+ finiteSum _ = fmap R1 <$> finiteElem (Proxy :: Proxy self)++class FiniteSumElem self a where+ finiteElem :: Proxy self -> [Gen (a p)]++instance+ ( FiniteSum self a b af bf+ ) => FiniteSumElem self (a :+: b) where+ finiteElem _ = finiteSum (Proxy :: Proxy self)++instance+ ( GArbitrary self (M1 C c f) 'True+ ) => FiniteSumElem self (M1 C c f) where+ finiteElem _ = [gArbitrary (Proxy :: Proxy self)]+++#if __GLASGOW_HASKELL__ >= 800+instance+ ( TypeError (ShowType self :<>: Text " refers to itself in all constructors")+ , (Finite self a || Finite self b) ~ 'False+ ) => GArbitrary self (M1 D t (a :+: b)) 'False where+ gArbitrary _ = error "Unreachable"+#endif++genericArbitrary+ :: forall a ga some+ . (Generic a, GArbitrary a ga some, ga ~ Rep a)+ => Gen a+genericArbitrary = G.to <$> gArbitrary (Proxy :: Proxy a)
+ test/Auxiliary.hs view
@@ -0,0 +1,10 @@+module Auxiliary where++import Control.Exception+import Test.QuickCheck++failGeneration :: forall a. (Arbitrary a, Show a) => IO ()+failGeneration = do+ try (generate (arbitrary :: Gen a) >>= print) >>= \case+ Left (_ :: SomeException) -> pure ()+ Right _ -> error "Error expected"
+ test/EnumTest.hs view
@@ -0,0 +1,24 @@+#if __GLASGOW_HASKELL__ >= 806 && __GLASGOW_HASKELL__ <= 900+{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-}+#elif __GLASGOW_HASKELL__ >= 902+{-# OPTIONS_GHC -fconstraint-solver-iterations=6 #-}+#endif++++module EnumTest where++import Control.DeepSeq+import GHC.Generics+import Test.QuickCheck+import Test.QuickCheck.Arbitrary.Generic++data Country = PL | GB | RU | RO | CZ | HR | SK | DE | NL | ES | BR+ deriving (Generic, NFData, Show)++instance Arbitrary Country where+ arbitrary = genericArbitrary+ shrink = genericShrink++prop_CountryTest :: Country -> Property+prop_CountryTest = total
+ test/LimitationDemo.hs view
@@ -0,0 +1,37 @@+module LimitationDemo where++import Control.DeepSeq+import GHC.Generics (Generic)+import Test.QuickCheck+import Test.QuickCheck.Arbitrary.Generic++-- As you can see, we have this instance generated, but it will definitely lead+-- to generating an infinite term (and the only term). The recursion detection+-- doesn't work here+data R1 = R1 R2+ deriving (Eq, Ord, Show, Generic)+ deriving anyclass NFData+#if MIN_VERSION_QuickCheck(2, 14, 0)+ deriving Arbitrary via (GenericArbitrary R1)+#else+instance Arbitrary R1 where+ arbitrary = genericArbitrary+ shrink = genericShrink+#endif++data R2 = R2 R1+ deriving (Eq, Ord, Show, Generic)+ deriving anyclass NFData+#if MIN_VERSION_QuickCheck(2, 14, 0)+ deriving Arbitrary via (GenericArbitrary R2)+#else+instance Arbitrary R2 where+ arbitrary = genericArbitrary+ shrink = genericShrink+#endif++-- To force the instance realy be generated+usage :: IO ()+usage = do+ r1 :: R1 <- generate arbitrary+ print r1 -- haha
+ test/NoTypecheckTest.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS_GHC -fdefer-type-errors #-}+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}++-- | Test that infinite types has no Arbitrary instance++module NoTypecheckTest where++import Auxiliary+import GHC.Generics (Generic)+import Test.QuickCheck+import Test.QuickCheck.Arbitrary.Generic++-- | Recursive infinite type which can not have valid Arbitrary instance+data R = R R+ deriving (Eq, Show, Generic)++-- | Instance which must not compile, but we are using deferred type errors+instance Arbitrary R where+ arbitrary = genericArbitrary+ shrink = genericShrink++unit_mustFail :: IO ()+unit_mustFail = failGeneration @R
+ test/ParametersTest.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -fdefer-type-errors #-}+{-# OPTIONS_GHC -Wno-deferred-type-errors #-}++module ParametersTest where++import Auxiliary+import Control.DeepSeq+import GHC.Generics (Generic)+import Test.QuickCheck+import Test.QuickCheck.Arbitrary.Generic++data A a = A a+ deriving (Eq, Ord, Show)+ deriving anyclass NFData+ deriving (Generic)++instance (Arbitrary a) => Arbitrary (A a) where+ arbitrary = genericArbitrary+ shrink = genericShrink++data B a = B a+ deriving (Eq, Ord, Show)+ deriving anyclass NFData+ deriving (Generic)++instance (Arg (B a) a, Arbitrary a) => Arbitrary (B a) where+ arbitrary = genericArbitrary+ shrink = genericShrink++unit_argumentConstraintFail :: IO ()+unit_argumentConstraintFail = failGeneration @(A Int)++prop_properArgumentConstraint :: B Int -> Property+prop_properArgumentConstraint = total
+ test/RecursiveTest.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# OPTIONS_GHC -fconstraint-solver-iterations=5 #-} -- GHC-9.2.4++-- | Testing that our Arbitrary instances do not get stuck and respect the+-- `size` parameter while generating.++module RecursiveTest where++import Control.DeepSeq (NFData)+import GHC.Generics (Generic)+import Test.QuickCheck+import Test.QuickCheck.Arbitrary.Generic++data Unit = Unit+ deriving (Eq, Show, Generic)+ deriving anyclass NFData+#if MIN_VERSION_QuickCheck(2, 14, 0)+ deriving Arbitrary via (GenericArbitrary Unit)+#else+instance Arbitrary Unit where+ arbitrary = genericArbitrary+ shrink = genericShrink+#endif++prop_unitTotal :: Unit -> Property+prop_unitTotal = total++data Single = Single Int+ deriving (Eq, Show, Generic)+ deriving anyclass NFData+#if MIN_VERSION_QuickCheck(2, 14, 0)+ deriving Arbitrary via (GenericArbitrary Single)+#else+instance Arbitrary Single where+ arbitrary = genericArbitrary+ shrink = genericShrink+#endif++prop_singleTotal :: Single -> Property+prop_singleTotal = total++data Multiple = M1 | M2 | M3 Int+ deriving (Eq, Show, Generic)+ deriving anyclass NFData+#if MIN_VERSION_QuickCheck(2, 14, 0)+ deriving Arbitrary via (GenericArbitrary Multiple)+#else+instance Arbitrary Multiple where+ arbitrary = genericArbitrary+ shrink = genericShrink+#endif++prop_multipleTotal :: Multiple -> Property+prop_multipleTotal = total++data Rec = Rec+ { unit :: Unit+ , single :: Single+ , multiple :: Multiple+ } deriving (Eq, Show, Generic)+ deriving anyclass NFData+#if MIN_VERSION_QuickCheck(2, 14, 0)+ deriving Arbitrary via (GenericArbitrary Rec)+#else+instance Arbitrary Rec where+ arbitrary = genericArbitrary+ shrink = genericShrink+#endif++prop_recTotal :: Rec -> Property+prop_recTotal = total++data Expr+ = Lit Int+ | Add Expr Expr+ | Mul Expr Expr+ deriving (Eq, Show, Generic)+ deriving anyclass NFData+#if MIN_VERSION_QuickCheck(2, 14, 0)+ deriving Arbitrary via (GenericArbitrary Expr)+#else+instance Arbitrary Expr where+ arbitrary = genericArbitrary+ shrink = genericShrink+#endif++prop_exprTotal :: Expr -> Property+prop_exprTotal = total++data Recursive+ = R1 Recursive+ | R2 Recursive Int+ | N Int+ | R3 Recursive+ | R4 Recursive+ | R5 Recursive String+ deriving (Eq, Show, Generic)+ deriving anyclass NFData+#if MIN_VERSION_QuickCheck(2, 14, 0)+ deriving Arbitrary via (GenericArbitrary Recursive)+#else+instance Arbitrary Recursive where+ arbitrary = genericArbitrary+ shrink = genericShrink+#endif++prop_recursiveTotal :: Recursive -> Property+prop_recursiveTotal = total++data DeepRecursive+ = Deep DeepRecursive DeepRecursive DeepRecursive DeepRecursive DeepRecursive+ | Short+ deriving (Eq, Show, Generic)+ deriving anyclass NFData+#if MIN_VERSION_QuickCheck(2, 14, 0)+ deriving Arbitrary via (GenericArbitrary DeepRecursive)+#else+instance Arbitrary DeepRecursive where+ arbitrary = genericArbitrary+ shrink = genericShrink+#endif++prop_deepRecursiveTotal :: DeepRecursive -> Property+prop_deepRecursiveTotal = total++data P p = NoP | P p+ deriving (Eq, Show, Generic)+ deriving anyclass NFData++-- Note that deriving via doesn't work for case with arguments+instance (Arg (P p) p, Arbitrary p) => Arbitrary (P p) where+ arbitrary = genericArbitrary+ shrink = genericShrink++prop_Ptotal :: P (P Int) -> Property+prop_Ptotal = total
+ test/Test.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}