genvalidity 0.11.0.2 → 1.1.1.0
raw patch · 11 files changed
Files
- CHANGELOG.md +204/−0
- LICENSE +1/−1
- Setup.hs +0/−3
- genvalidity.cabal +11/−9
- src/Data/GenRelativeValidity.hs +0/−32
- src/Data/GenValidity.hs +115/−677
- src/Data/GenValidity/Utils.hs +110/−109
- test/Data/GenValidity/GenericSpec.hs +5/−5
- test/Data/GenValidity/ShrinkGenericSpec.hs +7/−20
- test/Data/GenValiditySpec.hs +2/−1
- test/Data/InstanceSpec.hs +66/−165
+ CHANGELOG.md view
@@ -0,0 +1,204 @@+# Changelog++## [1.1.1.0] - 2024-07-18++### Added++* `GenValid` instances for various newtypes in base++## [1.1.0.0] - 2022-08-30++### Added++* `genListOf1`+* `genMaybe`+* `shrinkMaybe`+* `shrinkNonEmpty`+* `shrinkTriple`+* `shrinkQuadruple`++### Changed++* Sped up shrinking of `NonEmpty` lists by an order of magnitude.+* Changed shrinking of `Ratio`s to be 10x faster.+* Reimplemented `shrinkT2`, `shrinkT3` and `shrinkT4` in terms of `shrinkTuple`, `shrinkTriple` and `shrinkQuadruple`.++## [1.0.0.1] - 2021-11-20++### Changed++* Added compatibility with `lts-18.16`++## [1.0.0.0] - 2021-11-20++### Changed++* The default implementation of `GenValid` now uses `genValidStructurally` and `shrinkValidStructurally`.++### Removed++* `GenUnchecked`: It is no longer necessary after changing the default implementation of `GenValid`.+* `GenInvalid`: It was a misfeature.+* `GenRelativeValidity`: It was a misfeature. ++## [0.11.0.1] - 2021-06-20++### Changed++Updated the base lower bound to be more accurate.++## [0.11.0.1] - 2020-04-28++### Changed++* Got rid of some unnecessary extra special values in the generator for double++## [0.11.0.0] - 2020-04-12++### Changed++* Changed the genUnchecked and shrinkUnchecked definitions for Word8, Word16, Word32 and Int8, Int16, Int32 according to their new validity instance in validity 0.10.0.0++## [0.10.0.2] - 2020-03-18++### Changed++* Better lower bound for genvalidity++## [0.10.0.1] - 2020-02-20++### Changed++* Fixed a bug where shrinking ratios of bounded types would crash if the minimum bound was in the numerator.++## [0.10.0.0] - 2020-02-10++### Added++* `Data.GenValidity.Utils.genIntX`+* `Data.GenValidity.Utils.genWordX`+* `Data.GenValidity.Utils.genFloat`+* `Data.GenValidity.Utils.genDouble`+* `Data.GenValidity.Utils.genFloatX`+* `Data.GenValidity.Utils.genInteger`+++### Changed++* Improved the cabal file+* Sped up the 'genValid' generators for the following types+ * ()+ * Bool+ * Ordering+ * Char+ * Int, Int8, Int16, Int32, Int64+ * Word, Word8, Word16, Word32, Word64+ * Float, Double+* Improved the generators of+ * Int, Int8, Int16, Int32, Int64+ Now also generates extreme values, but mostly uniform values.+ * Word, Word8, Word16, Word32, Word64+ Now also generates extreme values, but mostly uniform values.+ * Float, Double+ Now also generates values around the bounds, but mostly uniform values.+ * Natural, Integer+ Now also generates numbers larger than can be contained in a single Word/Int.+ * Ratio+ Fixed a bug: no longer generates invalid ratios for fixed-sized numerators+* Removed a lot of shrinking tests++## [0.9.1.0] - 2019-12-04++### Added++* `genSplit6`, `genSplit7`, `genSplit8`+* `genNonEmptyOf`++### Changed++* Changed `arbPartition` to generate nicer partitions.+ This influences `genListOf` and `genTreeOf` and the+ instances for all collections as well.++## [0.9.0.1] - 2019-09-27++### Changed++* Tests for `genUtf16SurrogateCodePoint`++## [0.9.0.0] - 2019-09-23++### Added++* `genUtf16SurrogateCodePoint`++### Changed++* Changed `GenValid Char` to generate UTF16 surrogate codepoints 10% of the time+* Changed `GenValid Char` to ignore sizes.++## [0.8.0.0] - 2019-03-06++### Added++* 'shrinkTuple'++### Changed++* Removed the 'GenUnchecked' constraint for 'GenValid' and 'GenInvalid'.++## [0.7.0.2] - 2019-02-28++### Added++* 'shrinkT4'++### Changed++* Clearer docs++## [0.7.0.1] - 2019-02-21++### Changed++* Sped up the shrinking test suite.++## [0.7.0.0] - 2018-11-07++### Changed++* `genUnchecked` of `Double` and `Float` now generates `NaN`, `+Infinity`, `-Infinity` and `-0` according to the new version of `validity`.++## [0.6.1.0] - 2018-10-06++### Changed++* Changed 'genValid`, `genUnchecked` and `genInvalid` for NonEmpty to better take the size into account.+* Sped up `shrinkUnchecked` for `Maybe`+* Sped up `shrinkValid` for `Maybe`+* Sped up `shrinkUnchecked` for `Either`+* Sped up `shrinkValid` for `Either`+* Sped up `shrinkUnchecked` for `(,)`+* Sped up `shrinkUnchecked` for `(,,)`+* Sped up `shrinkUnchecked` for `(,,,)`+* Sped up `shrinkValid` for lists+* Sped up `shrinkValid` for `NonEmpty` lists++## [0.6.0.0] - 2018-08-25++### Added++* `genValidStructurally` and `genValidStructurallyWithoutExtraChecking`+* `shrinkValidStructurally` and `shrinkValidStructurallyWithoutExtraFiltering` with `structurallyValidRecursivelyShrink` and `structurallyValidSubterms`++### Changed++* `-0` is now a valid value for `Double` and `Float`.+* `genUnchecked :: Gen Double` now also generates invalid values.+* `arbPartition` now shuffles the partitions, which means that `genListOf` produces lists of elements with shuffled sizes.+ This also fixes the same problem with `instance GenUnchecked a => GenUnchecked [a]`.++## Older versions++No history before version 0.6.0.0+
LICENSE view
@@ -1,6 +1,6 @@ The MIT License (MIT) -Copyright (c) 2016-2020 Tom Sydney Kerckhove+Copyright (c) 2016-2021 Tom Sydney Kerckhove Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
− Setup.hs
@@ -1,3 +0,0 @@-import Distribution.Simple--main = defaultMain
genvalidity.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4.+-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: genvalidity-version: 0.11.0.2+version: 1.1.1.0 synopsis: Testing utilities for the validity library description: Note: There are companion instance packages for this library: .@@ -33,10 +33,13 @@ bug-reports: https://github.com/NorfairKing/validity/issues author: Tom Sydney Kerckhove maintainer: syd@cs-syd.eu-copyright: Copyright: (c) 2016-2020 Tom Sydney Kerckhove+copyright: Copyright: (c) 2016-2021 Tom Sydney Kerckhove license: MIT license-file: LICENSE build-type: Simple+extra-source-files:+ LICENSE+ CHANGELOG.md source-repository head type: git@@ -44,7 +47,6 @@ library exposed-modules:- Data.GenRelativeValidity Data.GenValidity Data.GenValidity.Utils other-modules:@@ -53,10 +55,10 @@ src ghc-options: -Wno-redundant-constraints build-depends:- QuickCheck >=2.12- , base >=4.11 && <5- , random- , validity >=0.9+ QuickCheck >=2.13+ , base >=4.13 && <5+ , random >=1.1+ , validity >=0.12.1 default-language: Haskell2010 test-suite genvalidity-test@@ -73,7 +75,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: QuickCheck- , base >=4.11 && <5+ , base >=4.13 && <5 , genvalidity , hspec , hspec-core
− src/Data/GenRelativeValidity.hs
@@ -1,32 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}--module Data.GenRelativeValidity- ( module Data.RelativeValidity,- module Data.GenRelativeValidity,- )-where--import Data.GenValidity-import Data.RelativeValidity-import Test.QuickCheck--class- (GenUnchecked a, RelativeValidity a b) =>- GenRelativeUnchecked a b- where- genUncheckedFor :: b -> Gen a- genUncheckedFor _ = genUnchecked--class- (GenValid a, RelativeValidity a b) =>- GenRelativeValid a b- where- genValidFor :: b -> Gen a- genValidFor b = genValid `suchThat` (`isValidFor` b)--class- (GenUnchecked a, RelativeValidity a b, GenRelativeUnchecked a b) =>- GenRelativeInvalid a b- where- genInvalidFor :: b -> Gen a- genInvalidFor b = genUncheckedFor b `suchThat` (not . (`isValidFor` b))
src/Data/GenValidity.hs view
@@ -1,45 +1,36 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-}--#if __GLASGOW_HASKELL__ >= 710-#define OVERLAPPING_ {-# OVERLAPPING #-}-#else-{-# LANGUAGE OverlappingInstances #-}-#define OVERLAPPING_-#endif-#if MIN_VERSION_base(4,9,0) {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}-#endif -- | ----- @GenValidity@ exists to make tests involving @Validity@ types easier and speed--- up the generation of data for them.+-- @GenValid@ exists to make tests involving @Validity@ types easier and+-- speed up the generation of data for them. ----- Let's use the example from @Data.Validity@ again: A datatype that represents--- primes.--- To implement tests for this datatype, we would have to be able to generate--- both primes and non-primes. We could do this with--- @(Prime <$> arbitrary) `suchThat` isValid@--- but this is tedious and inefficient.+-- To implement tests for this datatype, we would have to be able to+-- generate both primes. We could do this with a generator like this one: --+-- > (Prime <$> 'arbitrary') `suchThat` isValid+--+-- However, this is tedious and inefficient, as well as quite+-- naive (because 'arbitrary' tends to use very naive generators).+-- -- The @GenValid@ type class allows you to specify how to (efficiently) -- generate valid data of the given type to allow for easier and quicker testing.--- Just instantiating @GenUnchecked@ already gives you access to a default instance--- of @GenValid@ and @GenInvalid@ but writing custom implementations of these functions--- may speed up the generation of data.+-- The default implementation of `GenValid` already gives you a generator and shrinking function+-- for free: --+-- > instance GenValid Prime+-- -- For example, to generate primes, we don't have to consider even numbers other -- than 2. A more efficient implementation could then look as follows: ----- > instance GenUnchecked Prime where--- > genUnchecked = Prime <$> arbitrary--- -- > instance GenValid Prime where -- > genValid = Prime <$> -- > (oneof@@ -55,17 +46,14 @@ -- > myFunction input `shouldSatisfy` isRight -- -- > it "produces valid output when it succeeds" $ do--- > forAllUnchecked $ \input ->+-- > forAllValid $ \input -> -- > case myFunction input of -- > Nothing -> return () -- Can happen -- > Just output -> output `shouldSatisfy` isValid ----- Definitely also look at the genvalidity-property and genvalidity-hspec packages--- for more info on how to use this package.+-- Definitely also look at the companion packages for more info on how to use this package. module Data.GenValidity- ( GenUnchecked (..),- GenValid (..),- GenInvalid (..),+ ( GenValid (..), -- * Helper functions genValidStructurally,@@ -88,14 +76,6 @@ module Data.Validity, -- * The Generics magic- genericGenUnchecked,- GGenUnchecked (..),- genericShrinkUnchecked,- uncheckedRecursivelyShrink,- GUncheckedRecursivelyShrink (..),- uncheckedSubterms,- GUncheckedSubterms (..),- GUncheckedSubtermsIncl (..), GGenValid (..), GValidRecursivelyShrink (..), structurallyValidSubterms,@@ -104,112 +84,43 @@ ) where -#if MIN_VERSION_base(4,9,0)-import Data.List.NonEmpty (NonEmpty((:|)))-#endif-#if MIN_VERSION_base(4,8,0)-import Data.Word (Word64)-import GHC.Word (Word8(..), Word16(..), Word32(..), Word(..))-#else-import Data.Word (Word, Word64)-import GHC.Word (Word8(..), Word16(..), Word32(..), Word(..))-#endif- import Control.Monad (guard) import Data.Char (chr) import Data.Fixed (Fixed (..), HasResolution)-#if MIN_VERSION_base(4,8,0)-import GHC.Natural-#else-import Control.Applicative ((<*>), (<$>), pure)-#endif-+import Data.Functor.Const (Const (Const))+import Data.Functor.Identity (Identity (Identity)) import Data.GenValidity.Utils-import Data.Int (Int64)+import Data.Int (Int16, Int32, Int64, Int8)+import Data.List.NonEmpty (NonEmpty)+import Data.Monoid (Alt, Dual)+import qualified Data.Monoid as Monoid import Data.Ratio ((%))+import qualified Data.Semigroup as Semigroup import Data.Validity+import Data.Word (Word16, Word32, Word64, Word8) import GHC.Generics-import GHC.Int (Int (..), Int16 (..), Int32 (..), Int8 (..)) import GHC.Real (Ratio (..))+import Numeric.Natural import Test.QuickCheck hiding (Fixed) {-# ANN module "HLint: ignore Reduce duplication" #-} --- | A class of types for which truly arbitrary values can be generated.------ === How to instantiate 'GenUnchecked'------ __Step 1__: Try to instantiate 'GenUnchecked' via 'Generic'.--- __this is probably what you want__------ An instance of this class can be made automatically if the type in question--- has a 'Generic' instance. This instance will try to use 'genUnchecked' to--- generate all structural sub-parts of the value that is being generated.------ Example:------ > {-# LANGUAGE DeriveGeneric #-}--- >--- > data MyType = MyType Rational String--- > deriving (Show, Eq, Generic)--- >--- > instance GenUnchecked MyType------ generates something like:------ > instance GenUnchecked MyType where--- > genUnchecked = MyType <$> genUnchecked <*> genUnchecked------ If this is not possible because there is no 'GenUnchecked' instance available for one of the--- sub-parts of your type, __then do not instantiate 'GenUnchecked' for your type__.--- Just continue with 'GenValid' instead.------ __Step 2__: If an instatiation via 'Generic' is not possible, then you should emulate what--- 'genericGenUnchecked' does.--- This means that all sub-parts should be generated using 'genUnchecked'.--- Make sure to generate any possible value, valid or not, that can exist at runtime--- even when taking the existence of 'Unsafe.Coerce.unsafeCoerce' into account.------ === Warning: Invalid values can be funky------ Some types have serious validity constraints. See 'Rational' for example.--- These can behave very strangely when they are not valid.--- In that case, __do not override 'GenUnchecked' such that 'genUnchecked' only generates valid values__.--- In that case, do not override 'genUnchecked' at all.--- Instead, use 'genValid' from 'GenValid' (see below) instead and consider not instantiating 'GenUnchecked' at all.-class GenUnchecked a where- genUnchecked :: Gen a- default genUnchecked ::- (Generic a, GGenUnchecked (Rep a)) =>- Gen a- genUnchecked = genericGenUnchecked-- shrinkUnchecked :: a -> [a]- default shrinkUnchecked ::- (Generic a, GUncheckedRecursivelyShrink (Rep a), GUncheckedSubterms (Rep a) a) =>- a ->- [a]- shrinkUnchecked = genericShrinkUnchecked---- | A class of types for which valid values can be generated.+-- | A class of types for which valid values can be generated to be valid. -- -- === How to instantiate 'GenValid' -- -- __Step 1__: Try to instantiate 'GenValid' without overriding any functions.--- This is only possible if your type has a 'GenUnchecked' instance.--- If it doesn't, go to step 2. -- It is possible that, if few values are valid or if validity--- checking is expensive, that the resulting generator is too slow.+-- checking is expensive, the resulting generator is too slow. -- In that case, go to Step 2. ----- __Step 2__: Try to instantiate 'GenValid' using the helper functions via 'Generic'--- This involves using 'genValidStructurally' to override 'genValid' and--- using 'shrinkValidStructurally' to override 'shrinkValid'.--- __Every time you override 'genValid', you should also override 'shrinkValid'__+-- __Step 2__: Consider using 'genValidStructurallyWithoutExtraChecking' and+-- 'shrinkValidStructurallyWithoutExtraFiltering' to speed up generation.+-- This only works if your type has a derived or trivial 'Validity'+-- instance. ----- __Step 3__: If the above is not possible due to lack of a 'Generic' instance,--- then you should emulate what 'genValidStructurally' does.--- This means that all sub-parts should be generated using 'genValid'.+-- __Step 3__: If that still is not fast enough, consider writing your own+-- generator and shrinking function. -- Make sure to generate any possible valid value, but only valid values. -- -- === A note about 'Arbitrary'@@ -217,79 +128,37 @@ -- If you also write @Arbitrary@ instances for @GenValid@ types, it may be -- best to simply use ----- > arbitrary = genValid--- > shrink = shrinkValid-class Validity a => GenValid a where+-- > instance Arbitrary A where+-- > arbitrary = genValid+-- > shrink = shrinkValid+class (Validity a) => GenValid a where -- | Generate a valid datum, this should cover all possible valid values in -- the type -- -- The default implementation is as follows: --- -- > genValid = genUnchecked `suchThat` isValid+ -- > genValid = genValidStructurally -- -- To speed up testing, it may be a good idea to implement this yourself. -- If you do, make sure that it is possible to generate all possible valid -- data, otherwise your testing may not cover all cases. genValid :: Gen a- default genValid :: GenUnchecked a => Gen a- genValid = genUnchecked `suchThat` isValid+ default genValid :: (Generic a, GGenValid (Rep a)) => Gen a+ genValid = genValidStructurally -- | Shrink a valid value. -- -- The default implementation is as follows: --- -- > shrinkValid = filter isValid . shrinkUnchecked+ -- > shrinkValid = shrinkValidStructurally -- -- It is important that this shrinking function only shrinks values to valid values. -- If `shrinkValid` ever shrinks a value to an invalid value, the test that is being shrunk for -- might fail for a different reason than for the reason that it originally failed. -- This would lead to very confusing error messages. shrinkValid :: a -> [a]- default shrinkValid :: GenUnchecked a => a -> [a]- shrinkValid = filter isValid . shrinkUnchecked---- | A class of types for which invalid values can be generated.------ === How to instantiate 'GenInvalid'------ __Step 1__: Realise that you probably do not want to.--- It makes no sense, and serves no purpose, to instantiate 'GenInvalid' for types--- which contain no invalid values. (In fact, the default implementation will go into--- an infinite loop for such types.)--- You should only instantiate 'GenInvalid' if you explicitly want to use it--- to write tests that deal with invalid values, or if you are writing a container--- for parametric values.------ __Step 2__: Instantiate 'GenInvalid' without overriding any functions.-class Validity a => GenInvalid a where- genInvalid :: Gen a-- -- | Generate an invalid datum, this should cover all possible invalid- -- values- --- -- > genInvalid = genUnchecked `suchThat` isInvalid- --- -- To speed up testing, it may be a good idea to implement this yourself.- -- If you do, make sure that it is possible to generate all possible- -- invalid data, otherwise your testing may not cover all cases.- default genInvalid :: GenUnchecked a => Gen a- genInvalid = genUnchecked `suchThat` isInvalid-- shrinkInvalid :: a -> [a]- default shrinkInvalid :: GenUnchecked a => a -> [a]- shrinkInvalid = filter isInvalid . shrinkUnchecked--instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (a, b) where- genUnchecked =- sized $ \n -> do- (r, s) <- genSplit n- a <- resize r genUnchecked- b <- resize s genUnchecked- return (a, b)- shrinkUnchecked (a, b) =- ((,) <$> shrinkUnchecked a <*> shrinkUnchecked b)- ++ [(a', b) | a' <- shrinkUnchecked a]- ++ [(a, b') | b' <- shrinkUnchecked b]+ default shrinkValid :: (Generic a, GValidRecursivelyShrink (Rep a), GValidSubterms (Rep a) a) => a -> [a]+ shrinkValid = shrinkValidStructurally instance (GenValid a, GenValid b) => GenValid (a, b) where genValid =@@ -300,53 +169,11 @@ return (a, b) shrinkValid = shrinkTuple shrinkValid shrinkValid -instance (GenUnchecked a, GenInvalid a, GenUnchecked b, GenInvalid b) => GenInvalid (a, b) where- genInvalid =- sized $ \n -> do- (r, s) <- genSplit n- oneof- [ do- a <- resize r genUnchecked- b <- resize s genInvalid- return (a, b),- do- a <- resize r genInvalid- b <- resize s genUnchecked- return (a, b)- ]--instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (Either a b) where- genUnchecked = oneof [Left <$> genUnchecked, Right <$> genUnchecked]- shrinkUnchecked (Left a) = Left <$> shrinkUnchecked a- shrinkUnchecked (Right b) = Right <$> shrinkUnchecked b- instance (GenValid a, GenValid b) => GenValid (Either a b) where genValid = oneof [Left <$> genValid, Right <$> genValid] shrinkValid (Left a) = Left <$> shrinkValid a shrinkValid (Right b) = Right <$> shrinkValid b --- | This instance ensures that the generated tupse contains at least one invalid element. The other element is unchecked.-instance (GenInvalid a, GenInvalid b) => GenInvalid (Either a b) where- genInvalid = oneof [Left <$> genInvalid, Right <$> genInvalid]- shrinkInvalid (Left v) = Left <$> shrinkInvalid v- shrinkInvalid (Right v) = Right <$> shrinkInvalid v--instance- (GenUnchecked a, GenUnchecked b, GenUnchecked c) =>- GenUnchecked (a, b, c)- where- genUnchecked =- sized $ \n -> do- (r, s, t) <- genSplit3 n- a <- resize r genUnchecked- b <- resize s genUnchecked- c <- resize t genUnchecked- return (a, b, c)- shrinkUnchecked (a, b, c) =- [ (a', b', c')- | (a', (b', c')) <- shrinkUnchecked (a, (b, c))- ]- instance (GenValid a, GenValid b, GenValid c) => GenValid (a, b, c) where genValid = sized $ \n -> do@@ -355,59 +182,7 @@ b <- resize s genValid c <- resize t genValid return (a, b, c)- shrinkValid (a, b, c) =- [ (a', b', c')- | (a', (b', c')) <- shrinkValid (a, (b, c))- ]---- | This instance ensures that the generated triple contains at least one invalid element. The other two are unchecked.-instance- ( GenUnchecked a,- GenUnchecked b,- GenUnchecked c,- GenInvalid a,- GenInvalid b,- GenInvalid c- ) =>- GenInvalid (a, b, c)- where- genInvalid =- sized $ \n -> do- (r, s, t) <- genSplit3 n- oneof- [ do- a <- resize r genInvalid- b <- resize s genUnchecked- c <- resize t genUnchecked- return (a, b, c),- do- a <- resize r genUnchecked- b <- resize s genInvalid- c <- resize t genUnchecked- return (a, b, c),- do- a <- resize r genUnchecked- b <- resize s genUnchecked- c <- resize t genInvalid- return (a, b, c)- ]--instance- (GenUnchecked a, GenUnchecked b, GenUnchecked c, GenUnchecked d) =>- GenUnchecked (a, b, c, d)- where- genUnchecked =- sized $ \n -> do- (r, s, t, u) <- genSplit4 n- a <- resize r genUnchecked- b <- resize s genUnchecked- c <- resize t genUnchecked- d <- resize u genUnchecked- return (a, b, c, d)- shrinkUnchecked (a, b, c, d) =- [ (a', b', c', d')- | (a', (b', (c', d'))) <- shrinkUnchecked (a, (b, (c, d)))- ]+ shrinkValid = shrinkTriple shrinkValid shrinkValid shrinkValid instance (GenValid a, GenValid b, GenValid c, GenValid d) =>@@ -421,71 +196,7 @@ c <- resize t genValid d <- resize u genValid return (a, b, c, d)- shrinkValid (a, b, c, d) =- [ (a', b', c', d')- | (a', (b', (c', d'))) <- shrinkValid (a, (b, (c, d)))- ]---- | This instance ensures that the generated triple contains at least one invalid element. The other two are unchecked.-instance- ( GenUnchecked a,- GenUnchecked b,- GenUnchecked c,- GenUnchecked d,- GenInvalid a,- GenInvalid b,- GenInvalid c,- GenInvalid d- ) =>- GenInvalid (a, b, c, d)- where- genInvalid =- sized $ \n -> do- (r, s, t, u) <- genSplit4 n- oneof- [ do- a <- resize r genInvalid- b <- resize s genUnchecked- c <- resize t genUnchecked- d <- resize u genUnchecked- return (a, b, c, d),- do- a <- resize r genUnchecked- b <- resize s genInvalid- c <- resize t genUnchecked- d <- resize u genUnchecked- return (a, b, c, d),- do- a <- resize r genUnchecked- b <- resize s genUnchecked- c <- resize t genInvalid- d <- resize u genUnchecked- return (a, b, c, d),- do- a <- resize r genUnchecked- b <- resize s genUnchecked- c <- resize t genUnchecked- d <- resize u genInvalid- return (a, b, c, d)- ]--instance- (GenUnchecked a, GenUnchecked b, GenUnchecked c, GenUnchecked d, GenUnchecked e) =>- GenUnchecked (a, b, c, d, e)- where- genUnchecked =- sized $ \n -> do- (r, s, t, u, v) <- genSplit5 n- a <- resize r genUnchecked- b <- resize s genUnchecked- c <- resize t genUnchecked- d <- resize u genUnchecked- e <- resize v genUnchecked- return (a, b, c, d, e)- shrinkUnchecked (a, b, c, d, e) =- [ (a', b', c', d', e')- | (a', (b', (c', (d', e')))) <- shrinkUnchecked (a, (b, (c, (d, e))))- ]+ shrinkValid = shrinkQuadruple shrinkValid shrinkValid shrinkValid shrinkValid instance (GenValid a, GenValid b, GenValid c, GenValid d, GenValid e) =>@@ -505,146 +216,41 @@ | (a', (b', (c', (d', e')))) <- shrinkValid (a, (b, (c, (d, e)))) ] --- | This instance ensures that the generated triple contains at least one invalid element. The other two are unchecked.-instance- ( GenUnchecked a,- GenUnchecked b,- GenUnchecked c,- GenUnchecked d,- GenUnchecked e,- GenInvalid a,- GenInvalid b,- GenInvalid c,- GenInvalid d,- GenInvalid e- ) =>- GenInvalid (a, b, c, d, e)- where- genInvalid =- sized $ \n -> do- (r, s, t, u, v) <- genSplit5 n- oneof- [ do- a <- resize r genInvalid- b <- resize s genUnchecked- c <- resize t genUnchecked- d <- resize u genUnchecked- e <- resize v genUnchecked- return (a, b, c, d, e),- do- a <- resize r genUnchecked- b <- resize s genInvalid- c <- resize t genUnchecked- d <- resize u genUnchecked- e <- resize v genUnchecked- return (a, b, c, d, e),- do- a <- resize r genUnchecked- b <- resize s genUnchecked- c <- resize t genInvalid- d <- resize u genUnchecked- e <- resize v genUnchecked- return (a, b, c, d, e),- do- a <- resize r genUnchecked- b <- resize s genUnchecked- c <- resize t genUnchecked- d <- resize u genInvalid- e <- resize v genUnchecked- return (a, b, c, d, e),- do- a <- resize r genUnchecked- b <- resize s genUnchecked- c <- resize t genUnchecked- d <- resize u genUnchecked- e <- resize v genInvalid- return (a, b, c, d, e)- ]--instance GenUnchecked a => GenUnchecked (Maybe a) where- genUnchecked = oneof [pure Nothing, Just <$> genUnchecked]- shrinkUnchecked Nothing = []- shrinkUnchecked (Just a) = Nothing : (Just <$> shrinkUnchecked a)--instance GenValid a => GenValid (Maybe a) where- genValid = oneof [pure Nothing, Just <$> genValid]- shrinkValid Nothing = []- shrinkValid (Just a) = Nothing : (Just <$> shrinkValid a)--instance GenInvalid a => GenInvalid (Maybe a) where- genInvalid = Just <$> genInvalid- shrinkInvalid Nothing = [] -- Should not happen- shrinkInvalid (Just a) = Just <$> shrinkInvalid a--#if MIN_VERSION_base(4,9,0)-instance GenUnchecked a => GenUnchecked (NonEmpty a) where- genUnchecked = genNonEmptyOf genUnchecked- shrinkUnchecked (v :| vs) = [ e :| es | (e, es) <- shrinkUnchecked (v, vs)]--instance GenValid a => GenValid (NonEmpty a) where- genValid = genNonEmptyOf genValid- shrinkValid (v :| vs) = [ e :| es | (e, es) <- shrinkValid (v, vs)]--instance (GenUnchecked a, GenInvalid a) => GenInvalid (NonEmpty a) where- genInvalid = genNonEmptyOf genInvalid-#endif+instance (GenValid a) => GenValid (Maybe a) where+ genValid = genMaybe genValid+ shrinkValid = shrinkMaybe shrinkValid -instance GenUnchecked a => GenUnchecked [a] where- genUnchecked = genListOf genUnchecked- shrinkUnchecked = shrinkList shrinkUnchecked+instance (GenValid a) => GenValid (NonEmpty a) where+ genValid = genNonEmptyOf genValid+ shrinkValid = shrinkNonEmpty shrinkValid --- | If we can generate values of a certain type, we can also generate lists of--- them.-instance GenValid a => GenValid [a] where+instance (GenValid a) => GenValid [a] where genValid = genListOf genValid shrinkValid = shrinkList shrinkValid --- | This instance ensures that the generated list contains at least one element--- that satisfies 'isInvalid'. The rest is unchecked.-instance (GenUnchecked a, GenInvalid a) => GenInvalid [a] where- genInvalid =- sized $ \n -> do- (x, y, z) <- genSplit3 n- before <- resize x $ genListOf genUnchecked- middle <- resize y genInvalid- after <- resize z $ genListOf genUnchecked- return $ before ++ [middle] ++ after--instance GenUnchecked () where- genUnchecked = arbitrary- shrinkUnchecked = shrink- instance GenValid () where- genValid = genUnchecked- shrinkValid = shrinkUnchecked--instance GenUnchecked Bool where- genUnchecked = arbitrary- shrinkUnchecked = shrink+ genValid = pure ()+ shrinkValid () = [] instance GenValid Bool where- genValid = genUnchecked- shrinkValid = shrinkUnchecked--instance GenUnchecked Ordering where- genUnchecked = arbitrary- shrinkUnchecked = shrink+ genValid = arbitrary+ shrinkValid = shrink instance GenValid Ordering where- genValid = genUnchecked- shrinkValid = shrinkUnchecked+ genValid = arbitrary+ shrinkValid = shrink -instance GenUnchecked Char where- genUnchecked = frequency [(9, choose (minBound, maxBound)), (1, genUtf16SurrogateCodePoint)]- shrinkUnchecked = shrink+instance GenValid Char where+ genValid =+ frequency+ [ (9, choose (minBound, maxBound)),+ (1, genUtf16SurrogateCodePoint)+ ]+ shrinkValid = shrink genUtf16SurrogateCodePoint :: Gen Char genUtf16SurrogateCodePoint = chr <$> oneof [choose (0xD800, 0xDBFF), choose (0xDC00, 0xDFFF)] -instance GenValid Char where- genValid = genUnchecked- shrinkValid = shrinkUnchecked- genLineSeparator :: Gen Char genLineSeparator = elements ['\n', '\r'] @@ -654,138 +260,67 @@ genSingleLineString :: Gen String genSingleLineString = genListOf genNonLineSeparator -instance GenUnchecked Int where- genUnchecked = genIntX- shrinkUnchecked = shrink- instance GenValid Int where- genValid = genUnchecked- shrinkValid = shrinkUnchecked--instance GenUnchecked Int8 where- genUnchecked = genUncheckedInt (I8#)- shrinkUnchecked = shrinkUncheckedInt (\(I# i#) -> I8# i#) (\(I8# i#) -> I# i#)+ genValid = genIntX+ shrinkValid = shrink instance GenValid Int8 where genValid = genIntX shrinkValid = shrink -instance GenUnchecked Int16 where- genUnchecked = genUncheckedInt (I16#)- shrinkUnchecked = shrinkUncheckedInt (\(I# i#) -> I16# i#) (\(I16# i#) -> I# i#)- instance GenValid Int16 where genValid = genIntX shrinkValid = shrink -instance GenUnchecked Int32 where- genUnchecked = genUncheckedInt (I32#)- shrinkUnchecked = shrinkUncheckedInt (\(I# i#) -> I32# i#) (\(I32# i#) -> I# i#)- instance GenValid Int32 where genValid = genIntX shrinkValid = shrink -instance GenUnchecked Int64 where- genUnchecked = genIntX- shrinkUnchecked = shrink- instance GenValid Int64 where- genValid = genUnchecked- shrinkValid = shrinkUnchecked--instance GenUnchecked Word where- genUnchecked = genWordX- shrinkUnchecked = shrink+ genValid = genIntX+ shrinkValid = shrink instance GenValid Word where- genValid = genUnchecked- shrinkValid = shrinkUnchecked--instance GenUnchecked Word8 where- genUnchecked = genUncheckedWord (W8#)- shrinkUnchecked = shrinkUncheckedWord (\(W# w#) -> W8# w#) (\(W8# w#) -> W# w#)+ genValid = genWordX+ shrinkValid = shrink instance GenValid Word8 where genValid = genWordX shrinkValid = shrink -instance GenUnchecked Word16 where- genUnchecked = genUncheckedWord (W16#)- shrinkUnchecked = shrinkUncheckedWord (\(W# w#) -> W16# w#) (\(W16# w#) -> W# w#)- instance GenValid Word16 where genValid = genWordX shrinkValid = shrink -instance GenUnchecked Word32 where- genUnchecked = genUncheckedWord (W32#)- shrinkUnchecked = shrinkUncheckedWord (\(W# w#) -> W32# w#) (\(W32# w#) -> W# w#)- instance GenValid Word32 where genValid = genWordX shrinkValid = shrink -instance GenUnchecked Word64 where- genUnchecked = genWordX- shrinkUnchecked = shrink- instance GenValid Word64 where- genValid = genUnchecked- shrinkValid = shrinkUnchecked+ genValid = genWordX+ shrinkValid = shrink -#if MIN_VERSION_QuickCheck(2,9,2)-instance GenUnchecked Float where- genUnchecked = genFloat- shrinkUnchecked f+instance GenValid Float where+ genValid = genFloat+ shrinkValid f | isInfinite f = [] | isNaN f = [] | otherwise = shrink f-#else-instance GenUnchecked Float where- genUnchecked = genFloat- shrinkUnchecked _ = []-#endif -instance GenValid Float where- genValid = genUnchecked- shrinkValid = shrinkUnchecked--#if MIN_VERSION_QuickCheck(2,9,2)-instance GenUnchecked Double where- genUnchecked = genDouble- shrinkUnchecked d- | isInfinite d = []- | isNaN d = []- | otherwise = shrink d-#else-instance GenUnchecked Double where- genUnchecked = genDouble- shrinkUnchecked _ = []-#endif- instance GenValid Double where- genValid = genUnchecked- shrinkValid = shrinkUnchecked--instance GenUnchecked Integer where- genUnchecked = genInteger- shrinkUnchecked = shrink--instance GenValid Integer+ genValid = genDouble+ shrinkValid d+ | isInfinite d = []+ | isNaN d = []+ | otherwise = shrink d -#if MIN_VERSION_base(4,8,0)-instance GenUnchecked Natural where- genUnchecked = fromInteger . abs <$> genUnchecked- shrinkUnchecked = fmap (fromInteger . abs) . shrinkUnchecked . toInteger+instance GenValid Integer where+ genValid = genInteger+ shrinkValid = shrink instance GenValid Natural where- genValid = fromInteger . abs <$> genValid-#endif--instance (Integral a, GenUnchecked a) => GenUnchecked (Ratio a) where- genUnchecked = (:%) <$> genUnchecked <*> genUnchecked- shrinkUnchecked (n :% d) = [n' :% d' | (n', d') <- shrinkUnchecked (n, d)]+ genValid = fromInteger . abs <$> genValid+ shrinkValid = fmap (fromInteger . abs) . shrinkValid . toInteger instance (Integral a, Num a, Ord a, GenValid a) => GenValid (Ratio a) where genValid =@@ -796,127 +331,14 @@ ) `suchThat` isValid shrinkValid (n :% d) = do- (n', d') <- shrinkValid (n, d)- guard $ d' > 0+ (n', d') <- shrinkTuple shrinkValid (filter (> 0) . shrinkValid) (n, d) let candidate = n' :% d' guard $ isValid candidate pure $ n' % d' -instance (Integral a, Num a, Ord a, Validity a, GenUnchecked a) => GenInvalid (Ratio a)--instance HasResolution a => GenUnchecked (Fixed a) where- genUnchecked = MkFixed <$> genUnchecked- shrinkUnchecked (MkFixed i) = MkFixed <$> shrinkUnchecked i--instance HasResolution a => GenValid (Fixed a)--genericGenUnchecked :: (Generic a, GGenUnchecked (Rep a)) => Gen a-genericGenUnchecked = to <$> gGenUnchecked--class GGenUnchecked f where- gGenUnchecked :: Gen (f a)--instance GGenUnchecked U1 where- gGenUnchecked = pure U1--instance (GGenUnchecked a, GGenUnchecked b) => GGenUnchecked (a :*: b) where- gGenUnchecked = (:*:) <$> gGenUnchecked <*> gGenUnchecked--instance (GGenUnchecked a, GGenUnchecked b) => GGenUnchecked (a :+: b) where- gGenUnchecked = oneof [L1 <$> gGenUnchecked, R1 <$> gGenUnchecked]--instance (GGenUnchecked a) => GGenUnchecked (M1 i c a) where- gGenUnchecked = M1 <$> gGenUnchecked--instance (GenUnchecked a) => GGenUnchecked (K1 i a) where- gGenUnchecked = K1 <$> genUnchecked---- | Shrink a term to any of its immediate subterms,--- and also recursively shrink all subterms.-genericShrinkUnchecked :: (Generic a, GUncheckedRecursivelyShrink (Rep a), GUncheckedSubterms (Rep a) a) => a -> [a]-genericShrinkUnchecked x = uncheckedSubterms x ++ uncheckedRecursivelyShrink x---- | Recursively shrink all immediate uncheckedSubterms.-uncheckedRecursivelyShrink :: (Generic a, GUncheckedRecursivelyShrink (Rep a)) => a -> [a]-uncheckedRecursivelyShrink = map to . gUncheckedRecursivelyShrink . from--class GUncheckedRecursivelyShrink f where- gUncheckedRecursivelyShrink :: f a -> [f a]--instance (GUncheckedRecursivelyShrink f, GUncheckedRecursivelyShrink g) => GUncheckedRecursivelyShrink (f :*: g) where- gUncheckedRecursivelyShrink (x :*: y) =- ((:*:) <$> gUncheckedRecursivelyShrink x <*> gUncheckedRecursivelyShrink y)- ++ [x' :*: y | x' <- gUncheckedRecursivelyShrink x]- ++ [x :*: y' | y' <- gUncheckedRecursivelyShrink y]--instance (GUncheckedRecursivelyShrink f, GUncheckedRecursivelyShrink g) => GUncheckedRecursivelyShrink (f :+: g) where- gUncheckedRecursivelyShrink (L1 x) = map L1 (gUncheckedRecursivelyShrink x)- gUncheckedRecursivelyShrink (R1 x) = map R1 (gUncheckedRecursivelyShrink x)--instance GUncheckedRecursivelyShrink f => GUncheckedRecursivelyShrink (M1 i c f) where- gUncheckedRecursivelyShrink (M1 x) = map M1 (gUncheckedRecursivelyShrink x)--instance GenUnchecked a => GUncheckedRecursivelyShrink (K1 i a) where- gUncheckedRecursivelyShrink (K1 x) = map K1 (shrinkUnchecked x)--instance GUncheckedRecursivelyShrink U1 where- gUncheckedRecursivelyShrink U1 = []--instance GUncheckedRecursivelyShrink V1 where- -- The empty type can't be shrunk to anything.- gUncheckedRecursivelyShrink _ = []---- | All immediate uncheckedSubterms of a term.-uncheckedSubterms :: (Generic a, GUncheckedSubterms (Rep a) a) => a -> [a]-uncheckedSubterms = gUncheckedSubterms . from--class GUncheckedSubterms f a where- gUncheckedSubterms :: f a -> [a]--instance GUncheckedSubterms V1 a where- gUncheckedSubterms _ = []--instance GUncheckedSubterms U1 a where- gUncheckedSubterms U1 = []--instance (GUncheckedSubtermsIncl f a, GUncheckedSubtermsIncl g a) => GUncheckedSubterms (f :*: g) a where- gUncheckedSubterms (l :*: r) = gUncheckedSubtermsIncl l ++ gUncheckedSubtermsIncl r--instance (GUncheckedSubtermsIncl f a, GUncheckedSubtermsIncl g a) => GUncheckedSubterms (f :+: g) a where- gUncheckedSubterms (L1 x) = gUncheckedSubtermsIncl x- gUncheckedSubterms (R1 x) = gUncheckedSubtermsIncl x--instance GUncheckedSubterms f a => GUncheckedSubterms (M1 i c f) a where- gUncheckedSubterms (M1 x) = gUncheckedSubterms x--instance GUncheckedSubterms (K1 i a) b where- gUncheckedSubterms (K1 _) = []--class GUncheckedSubtermsIncl f a where- gUncheckedSubtermsIncl :: f a -> [a]--instance GUncheckedSubtermsIncl V1 a where- gUncheckedSubtermsIncl _ = []--instance GUncheckedSubtermsIncl U1 a where- gUncheckedSubtermsIncl U1 = []--instance (GUncheckedSubtermsIncl f a, GUncheckedSubtermsIncl g a) => GUncheckedSubtermsIncl (f :*: g) a where- gUncheckedSubtermsIncl (l :*: r) = gUncheckedSubtermsIncl l ++ gUncheckedSubtermsIncl r--instance (GUncheckedSubtermsIncl f a, GUncheckedSubtermsIncl g a) => GUncheckedSubtermsIncl (f :+: g) a where- gUncheckedSubtermsIncl (L1 x) = gUncheckedSubtermsIncl x- gUncheckedSubtermsIncl (R1 x) = gUncheckedSubtermsIncl x--instance GUncheckedSubtermsIncl f a => GUncheckedSubtermsIncl (M1 i c f) a where- gUncheckedSubtermsIncl (M1 x) = gUncheckedSubtermsIncl x---- This is the important case: We've found a term of the same type.-instance OVERLAPPING_ GUncheckedSubtermsIncl (K1 i a) a where- gUncheckedSubtermsIncl (K1 x) = [x]--instance OVERLAPPING_ GUncheckedSubtermsIncl (K1 i a) b where- gUncheckedSubtermsIncl (K1 _) = []+instance (HasResolution a) => GenValid (Fixed a) where+ genValid = MkFixed <$> genValid+ shrinkValid (MkFixed i) = MkFixed <$> shrinkValid i -- | Generate a valid value by generating all the sub parts using the 'Generic' instance, -- and trying that until a valid value has been generated@@ -957,6 +379,22 @@ instance (GenValid a) => GGenValid (K1 i a) where gGenValid = K1 <$> genValid +deriving newtype instance (GenValid a) => GenValid (Identity a)++deriving newtype instance (GenValid (f a)) => GenValid (Alt f a)++deriving newtype instance (GenValid a) => GenValid (Dual a)++deriving newtype instance (GenValid a) => GenValid (Semigroup.First a)++deriving newtype instance (GenValid a) => GenValid (Semigroup.Last a)++deriving newtype instance (GenValid a) => GenValid (Monoid.First a)++deriving newtype instance (GenValid a) => GenValid (Monoid.Last a)++deriving newtype instance (GenValid a) => GenValid (Const a b)+ -- | Shrink a term to any of its immediate valid subterms, -- and also recursively shrink all subterms, and then filtering out the results that are not valid. --@@ -994,10 +432,10 @@ gValidRecursivelyShrink (L1 x) = map L1 (gValidRecursivelyShrink x) gValidRecursivelyShrink (R1 x) = map R1 (gValidRecursivelyShrink x) -instance GValidRecursivelyShrink f => GValidRecursivelyShrink (M1 i c f) where+instance (GValidRecursivelyShrink f) => GValidRecursivelyShrink (M1 i c f) where gValidRecursivelyShrink (M1 x) = map M1 (gValidRecursivelyShrink x) -instance GenValid a => GValidRecursivelyShrink (K1 i a) where+instance (GenValid a) => GValidRecursivelyShrink (K1 i a) where gValidRecursivelyShrink (K1 x) = map K1 (shrinkValid x) instance GValidRecursivelyShrink U1 where@@ -1027,7 +465,7 @@ gValidSubterms (L1 x) = gValidSubtermsIncl x gValidSubterms (R1 x) = gValidSubtermsIncl x -instance GValidSubterms f a => GValidSubterms (M1 i c f) a where+instance (GValidSubterms f a) => GValidSubterms (M1 i c f) a where gValidSubterms (M1 x) = gValidSubterms x instance GValidSubterms (K1 i a) b where@@ -1049,12 +487,12 @@ gValidSubtermsIncl (L1 x) = gValidSubtermsIncl x gValidSubtermsIncl (R1 x) = gValidSubtermsIncl x -instance GValidSubtermsIncl f a => GValidSubtermsIncl (M1 i c f) a where+instance (GValidSubtermsIncl f a) => GValidSubtermsIncl (M1 i c f) a where gValidSubtermsIncl (M1 x) = gValidSubtermsIncl x -- This is the important case: We've found a term of the same type.-instance OVERLAPPING_ GValidSubtermsIncl (K1 i a) a where+instance {-# OVERLAPPING #-} GValidSubtermsIncl (K1 i a) a where gValidSubtermsIncl (K1 x) = [x] -instance OVERLAPPING_ GValidSubtermsIncl (K1 i a) b where+instance {-# OVERLAPPING #-} GValidSubtermsIncl (K1 i a) b where gValidSubtermsIncl (K1 _) = []
src/Data/GenValidity/Utils.hs view
@@ -1,19 +1,9 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-}--#if __GLASGOW_HASKELL__ >= 710-#define OVERLAPPING_ {-# OVERLAPPING #-}-#else-{-# LANGUAGE OverlappingInstances #-}-#define OVERLAPPING_-#endif-#if MIN_VERSION_base(4,9,0) {-# OPTIONS_GHC -fno-warn-redundant-constraints #-}-#endif+ module Data.GenValidity.Utils ( -- ** Helper functions for implementing generators upTo,@@ -27,53 +17,41 @@ arbPartition, shuffle, genListLength,+ genStringBy,+ genStringBy1, genListOf,-#if MIN_VERSION_base(4,9,0)+ genListOf1,+ genMaybe, genNonEmptyOf,-#endif-- -- ** Helper functions for implementing shrinking functions- shrinkTuple,- shrinkT2,- shrinkT3,- shrinkT4, genIntX, genWordX, genFloat, genDouble, genFloatX, genInteger,- genUncheckedInt,- shrinkUncheckedInt,- genUncheckedWord,- shrinkUncheckedWord,++ -- ** Helper functions for implementing shrinking functions+ shrinkMaybe,+ shrinkTuple,+ shrinkTriple,+ shrinkQuadruple,+ shrinkT2,+ shrinkT3,+ shrinkT4,+ shrinkList,+ shrinkNonEmpty, ) where +import Control.Monad (forM, replicateM)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Maybe import Data.Ratio-import GHC.Exts (Int#, Word#) import GHC.Float (castWord32ToFloat, castWord64ToDouble)-import GHC.Int (Int (..))-import GHC.Word (Word (..)) import System.Random import Test.QuickCheck hiding (Fixed) -#if !MIN_VERSION_QuickCheck(2,8,0)-import Data.List (sortBy)-import Data.Ord (comparing)-#endif-#if MIN_VERSION_base(4,9,0)-import Data.List.NonEmpty(NonEmpty(..))-import qualified Data.List.NonEmpty as NE-#endif--#if MIN_VERSION_base(4,8,0)-import Control.Monad (forM, replicateM)-#else-import Control.Applicative ((<$>), (<*>), pure)-import Control.Monad (forM, replicateM)-#endif- -- | 'upTo' generates an integer between 0 (inclusive) and 'n'. upTo :: Int -> Gen Int upTo n@@ -85,68 +63,68 @@ genSplit n | n < 0 = pure (0, 0) | otherwise = do- i <- choose (0, n)- let j = n - i- pure (i, j)+ i <- choose (0, n)+ let j = n - i+ pure (i, j) -- | 'genSplit3 a' generates a triple '(b, c, d)' such that 'b + c + d' equals 'a'. genSplit3 :: Int -> Gen (Int, Int, Int) genSplit3 n | n < 0 = pure (0, 0, 0) | otherwise = do- (a, z) <- genSplit n- (b, c) <- genSplit z- return (a, b, c)+ (a, z) <- genSplit n+ (b, c) <- genSplit z+ return (a, b, c) -- | 'genSplit4 a' generates a quadruple '(b, c, d, e)' such that 'b + c + d + e' equals 'a'. genSplit4 :: Int -> Gen (Int, Int, Int, Int) genSplit4 n | n < 0 = pure (0, 0, 0, 0) | otherwise = do- (y, z) <- genSplit n- (a, b) <- genSplit y- (c, d) <- genSplit z- return (a, b, c, d)+ (y, z) <- genSplit n+ (a, b) <- genSplit y+ (c, d) <- genSplit z+ return (a, b, c, d) -- | 'genSplit5 a' generates a quintuple '(b, c, d, e, f)' such that 'b + c + d + e + f' equals 'a'. genSplit5 :: Int -> Gen (Int, Int, Int, Int, Int) genSplit5 n | n < 0 = pure (0, 0, 0, 0, 0) | otherwise = do- (y, z) <- genSplit n- (a, b, c) <- genSplit3 y- (d, e) <- genSplit z- return (a, b, c, d, e)+ (y, z) <- genSplit n+ (a, b, c) <- genSplit3 y+ (d, e) <- genSplit z+ return (a, b, c, d, e) -- | 'genSplit6 a' generates a sextuple '(b, c, d, e, f, g)' such that 'b + c + d + e + f + g' equals 'a'. genSplit6 :: Int -> Gen (Int, Int, Int, Int, Int, Int) genSplit6 n | n < 0 = pure (0, 0, 0, 0, 0, 0) | otherwise = do- (y, z) <- genSplit n- (a, b, c) <- genSplit3 y- (d, e, f) <- genSplit3 z- return (a, b, c, d, e, f)+ (y, z) <- genSplit n+ (a, b, c) <- genSplit3 y+ (d, e, f) <- genSplit3 z+ return (a, b, c, d, e, f) -- | 'genSplit7 a' generates a septtuple '(b, c, d, e, f, g)' such that 'b + c + d + e + f + g' equals 'a'. genSplit7 :: Int -> Gen (Int, Int, Int, Int, Int, Int, Int) genSplit7 n | n < 0 = pure (0, 0, 0, 0, 0, 0, 0) | otherwise = do- (y, z) <- genSplit n- (a, b, c) <- genSplit3 y- (d, e, f, g) <- genSplit4 z- return (a, b, c, d, e, f, g)+ (y, z) <- genSplit n+ (a, b, c) <- genSplit3 y+ (d, e, f, g) <- genSplit4 z+ return (a, b, c, d, e, f, g) -- | 'genSplit8 a' generates a octtuple '(b, c, d, e, f, g, h)' such that 'b + c + d + e + f + g + h' equals 'a'. genSplit8 :: Int -> Gen (Int, Int, Int, Int, Int, Int, Int, Int) genSplit8 n | n < 0 = pure (0, 0, 0, 0, 0, 0, 0, 0) | otherwise = do- (y, z) <- genSplit n- (a, b, c, d) <- genSplit4 y- (e, f, g, h) <- genSplit4 z- return (a, b, c, d, e, f, g, h)+ (y, z) <- genSplit n+ (a, b, c, d) <- genSplit4 y+ (e, f, g, h) <- genSplit4 z+ return (a, b, c, d, e, f, g, h) -- | 'arbPartition n' generates a list 'ls' such that 'sum ls' equals 'n', approximately. arbPartition :: Int -> Gen [Int]@@ -163,24 +141,17 @@ -- Use an exponential distribution for generating the -- sizes in the partition. invE :: Double -> Double -> Double- invE lambda u = (- log (1 - u)) / lambda+ invE lambda u = (-log (1 - u)) / lambda -#if !MIN_VERSION_QuickCheck(2,8,0)--- | Generates a random permutation of the given list.-shuffle :: [a] -> Gen [a]-shuffle xs = do- ns <- vectorOf (length xs) (choose (minBound :: Int, maxBound))- return (map snd (sortBy (comparing fst) (zip ns xs)))-#endif+genMaybe :: Gen a -> Gen (Maybe a)+genMaybe gen = oneof [pure Nothing, Just <$> gen] -#if MIN_VERSION_base(4,9,0) genNonEmptyOf :: Gen a -> Gen (NonEmpty a) genNonEmptyOf gen = do l <- genListOf gen case NE.nonEmpty l of- Nothing -> scale (+1) $ genNonEmptyOf gen+ Nothing -> scale (+ 1) $ genNonEmptyOf gen Just ne -> pure ne-#endif -- Uses 'genListLengthWithSize' with the size parameter genListLength :: Gen Int@@ -204,6 +175,14 @@ then a + sqrt (u * (b - a) * (c - a)) else b - sqrt ((1 - u) * (b - a) * (b - c)) +-- Generate a String using a generator of 'Char's+genStringBy :: Gen Char -> Gen String+genStringBy = genListOf++-- Generate a String using a generator of 'Char's+genStringBy1 :: Gen Char -> Gen String+genStringBy1 = genListOf1+ -- | A version of @listOf@ that takes size into account more accurately. -- -- This generator distributes the size that is is given among the values@@ -214,24 +193,62 @@ pars <- arbPartition n forM pars $ \i -> resize i func +-- | A version of 'genNonEmptyOf' that returns a list instead of a 'NonEmpty'.+genListOf1 :: Gen a -> Gen [a]+genListOf1 gen = NE.toList <$> genNonEmptyOf gen++-- | Lift a shrinker function into a maybe+shrinkMaybe :: (a -> [a]) -> Maybe a -> [Maybe a]+shrinkMaybe shrinker = \case+ Nothing -> []+ Just a -> Nothing : (Just <$> shrinker a)++-- | Combine two shrinking functions to shrink a tuple. shrinkTuple :: (a -> [a]) -> (b -> [b]) -> (a, b) -> [(a, b)] shrinkTuple sa sb (a, b) = ((,) <$> sa a <*> sb b) ++ [(a', b) | a' <- sa a] ++ [(a, b') | b' <- sb b] +-- | Like 'shrinkTuple', but for triples+shrinkTriple ::+ (a -> [a]) ->+ (b -> [b]) ->+ (c -> [c]) ->+ (a, b, c) ->+ [(a, b, c)]+shrinkTriple sa sb sc (a, b, c) = do+ (a', (b', c')) <- shrinkTuple sa (shrinkTuple sb sc) (a, (b, c))+ pure (a', b', c')++-- | Like 'shrinkTuple', but for quadruples+shrinkQuadruple ::+ (a -> [a]) ->+ (b -> [b]) ->+ (c -> [c]) ->+ (d -> [d]) ->+ (a, b, c, d) ->+ [(a, b, c, d)]+shrinkQuadruple sa sb sc sd (a, b, c, d) = do+ ((a', b'), (c', d')) <- shrinkTuple (shrinkTuple sa sb) (shrinkTuple sc sd) ((a, b), (c, d))+ pure (a', b', c', d')+ -- | Turn a shrinking function into a function that shrinks tuples. shrinkT2 :: (a -> [a]) -> (a, a) -> [(a, a)]-shrinkT2 s (a, b) = (,) <$> s a <*> s b+shrinkT2 s = shrinkTuple s s -- | Turn a shrinking function into a function that shrinks triples. shrinkT3 :: (a -> [a]) -> (a, a, a) -> [(a, a, a)]-shrinkT3 s (a, b, c) = (,,) <$> s a <*> s b <*> s c+shrinkT3 s = shrinkTriple s s s -- | Turn a shrinking function into a function that shrinks quadruples. shrinkT4 :: (a -> [a]) -> (a, a, a, a) -> [(a, a, a, a)]-shrinkT4 s (a, b, c, d) = (,,,) <$> s a <*> s b <*> s c <*> s d+shrinkT4 s = shrinkQuadruple s s s s +-- Shrink a nonempty list given a shrinker for values.+shrinkNonEmpty :: (a -> [a]) -> NonEmpty a -> [NonEmpty a]+shrinkNonEmpty shrinker = mapMaybe NE.nonEmpty . shrinkList shrinker . NE.toList+ -- | Generate Int, Int8, Int16, Int32 and Int64 values smartly. -- -- * Some at the border@@ -242,7 +259,7 @@ frequency [ (1, extreme), (1, small),- (8, uniform)+ (8, uniformInt) ] where extreme :: Gen a@@ -252,9 +269,9 @@ choose (minBound, minBound + fromIntegral s) ] small :: Gen a- small = sized $ \s -> choose (- fromIntegral s, fromIntegral s)- uniform :: Gen a- uniform = choose (minBound, maxBound)+ small = sized $ \s -> choose (-fromIntegral s, fromIntegral s)+ uniformInt :: Gen a+ uniformInt = choose (minBound, maxBound) -- | Generate Word, Word8, Word16, Word32 and Word64 values smartly. --@@ -266,7 +283,7 @@ frequency [ (1, extreme), (1, small),- (8, uniform)+ (8, uniformWord) ] where extreme :: Gen a@@ -274,8 +291,8 @@ choose (maxBound - fromIntegral s, maxBound) small :: Gen a small = sized $ \s -> choose (0, fromIntegral s)- uniform :: Gen a- uniform = choose (minBound, maxBound)+ uniformWord :: Gen a+ uniformWord = choose (minBound, maxBound) -- | See 'genFloatX' genFloat :: Gen Float@@ -325,12 +342,12 @@ let n' = toInteger n let precision = 9999999999999 :: Integer b <- choose (1, precision)- a <- choose ((- n') * b, n' * b)+ a <- choose ((-n') * b, n' * b) pure (fromRational (a % b)) upperSignificand :: Integer upperSignificand = floatRadix (0.0 :: a) ^ floatDigits (0.0 :: a) lowerSignificand :: Integer- lowerSignificand = (- upperSignificand)+ lowerSignificand = (-upperSignificand) (lowerExponent, upperExponent) = floatRange (0.0 :: a) aroundBounds :: Gen a aroundBounds = do@@ -362,7 +379,7 @@ small ] where- small = sized $ \s -> choose (- toInteger s, toInteger s)+ small = sized $ \s -> choose (-toInteger s, toInteger s) genIntSizedInteger = toInteger <$> (genIntX :: Gen Int) genBiggerInteger = sized $ \s -> do (a, b, c) <- genSplit3 s@@ -370,19 +387,3 @@ bi <- resize b genInteger ci <- resize c genIntSizedInteger pure $ ai * bi + ci--genUncheckedInt :: (Int# -> a) -> Gen a-genUncheckedInt func = do- (I# i#) <- genIntX- pure $ func i#--shrinkUncheckedInt :: (Int -> a) -> (a -> Int) -> a -> [a]-shrinkUncheckedInt fromInt toInt = fmap fromInt . shrink . toInt--genUncheckedWord :: (Word# -> a) -> Gen a-genUncheckedWord func = do- (W# w#) <- genWordX- pure $ func w#--shrinkUncheckedWord :: (Word -> a) -> (a -> Word) -> a -> [a]-shrinkUncheckedWord fromWord toWord = fmap fromWord . shrink . toWord
test/Data/GenValidity/GenericSpec.hs view
@@ -82,14 +82,16 @@ ( unwords ["never shrinks to itself for valid", "\"" ++ nameOf proxy ++ "\"s"] )- $ forAll (genValid :: Gen a) $ \a ->+ $ forAll (genValid :: Gen a)+ $ \a -> forM_ (shrinkValidStructurally a) $ \subA -> when (subA == a) $- expectationFailure $ unlines [show a, "was shrunk to itself."]+ expectationFailure $+ unlines [show a, "was shrunk to itself."] nameOf :: forall a.- Typeable a =>+ (Typeable a) => Proxy a -> String nameOf = show . typeRep@@ -99,7 +101,5 @@ deriving (Show, Eq, Generic, Typeable) instance Validity MyType--instance GenUnchecked MyType instance GenValid MyType
test/Data/GenValidity/ShrinkGenericSpec.hs view
@@ -8,13 +8,6 @@ spec :: Spec spec = do- describe "genericShrinkUnchecked" $ do- it "shrinks tuples correctly" $- genericShrinkUnchecked ((A2, B3))- `shouldBe` [(A1, B1), (A1, B2), (A1, B3), (A2, B1), (A2, B2)]- it "figures out the right shrinking function for Ex" $- genericShrinkUnchecked (Ex A2 B3)- `shouldBe` [Ex A1 B1, Ex A1 B2, Ex A1 B3, Ex A2 B1, Ex A2 B2] describe "default shrinkValid" $ do it "figures out the right shrinking function for A" $ shrinkValid A2 `shouldBe` [A1]@@ -40,8 +33,6 @@ instance Validity Ex -instance GenUnchecked Ex- instance GenValid Ex data A@@ -51,11 +42,9 @@ instance Validity A -instance GenUnchecked A where- shrinkUnchecked A1 = []- shrinkUnchecked A2 = [A1]--instance GenValid A+instance GenValid A where+ shrinkValid A1 = []+ shrinkValid A2 = [A1] data B = B1@@ -68,9 +57,7 @@ validate B2 = invalid "for test" validate B3 = valid -instance GenUnchecked B where- shrinkUnchecked B1 = []- shrinkUnchecked B2 = [B1]- shrinkUnchecked B3 = [B1, B2]--instance GenValid B+instance GenValid B where+ shrinkValid B1 = []+ shrinkValid B2 = [B1]+ shrinkValid B3 = [B1]
test/Data/GenValiditySpec.hs view
@@ -23,7 +23,8 @@ forAll genSingleLineString (`shouldSatisfy` isSingleLine) describe "upTo" $ do it "returns only positive integers" $- forAll arbitrary $ \n -> forAll (upTo n) (`shouldSatisfy` (>= 0))+ forAll arbitrary $+ \n -> forAll (upTo n) (`shouldSatisfy` (>= 0)) it "returns only integers smaller than or equal to the given number" $ forAll arbitrary $ \n -> forAll (upTo n) (`shouldSatisfy` (<= (max n 0)))
test/Data/InstanceSpec.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE NegativeLiterals #-} {-# LANGUAGE ScopedTypeVariables #-} module Data.InstanceSpec@@ -6,72 +6,63 @@ ) where -#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<*>), pure)-import Data.Functor ((<$>))-#endif--#if MIN_VERSION_base(4,9,0)-import Data.List.NonEmpty (NonEmpty)-#endif- import Control.Monad import Data.Data import Data.Fixed-#if MIN_VERSION_base(4,8,0)-import GHC.Natural-#endif import Data.GenValidity import Data.Int+import Data.List.NonEmpty (NonEmpty) import Data.Ratio import Data.Word+import Numeric.Natural import Test.Hspec import Test.Hspec.Core.QuickCheck (modifyMaxSize, modifyMaxSuccess) import Test.QuickCheck spec :: Spec spec = do- twoTests (Proxy :: Proxy ())- twoTests (Proxy :: Proxy Bool)- twoTests (Proxy :: Proxy Ordering)- twoTests (Proxy :: Proxy Char)- twoTests (Proxy :: Proxy Word)- twoTests (Proxy :: Proxy Word8)- twoTests (Proxy :: Proxy Word16)- twoTests (Proxy :: Proxy Word32)- twoTests (Proxy :: Proxy Word64)- twoTests (Proxy :: Proxy Int)- twoTests (Proxy :: Proxy Int8)- twoTests (Proxy :: Proxy Int16)- twoTests (Proxy :: Proxy Int32)- twoTests (Proxy :: Proxy Int64)- twoTests (Proxy :: Proxy Integer)- twoTests (Proxy :: Proxy Float)- twoTupleTests (Proxy :: Proxy Float)+ genValidTest (Proxy :: Proxy ())+ genValidTest (Proxy :: Proxy Bool)+ genValidTest (Proxy :: Proxy Ordering)+ genValidTest (Proxy :: Proxy Char)+ genValidTest (Proxy :: Proxy Word)+ genValidTest (Proxy :: Proxy Word8)+ genValidTest (Proxy :: Proxy Word16)+ genValidTest (Proxy :: Proxy Word32)+ genValidTest (Proxy :: Proxy Word64)+ genValidTest (Proxy :: Proxy Int)+ genValidTest (Proxy :: Proxy Int8)+ genValidTest (Proxy :: Proxy Int16)+ genValidTest (Proxy :: Proxy Int32)+ genValidTest (Proxy :: Proxy Int64)+ genValidTest (Proxy :: Proxy Integer)+ genValidTest (Proxy :: Proxy Float)+ tupleTest (Proxy :: Proxy Float) -- Regression tests- describe "shrinkUnchecked Float" $ do+ describe "shrinkValid Float" $ do let sf :: Float -> Spec- sf f = it (unwords ["Does not shrink", show f, "to itself"]) $ f `shouldNotSatisfy` (`elem` shrinkUnchecked f)+ sf f = it (unwords ["Does not shrink", show f, "to itself"]) $ f `shouldNotSatisfy` (`elem` shrinkValid f) sf (-2.1393704e20) sf 1.2223988e-12 sf 2.7896812e10- describe "shrinkUnchecked Double" $ do+ describe "shrinkValid Double" $ do let sd :: Double -> Spec- sd d = it (unwords ["Does not shrink", show d, "to itself"]) $ d `shouldNotSatisfy` (`elem` shrinkUnchecked d)+ sd d = it (unwords ["Does not shrink", show d, "to itself"]) $ d `shouldNotSatisfy` (`elem` shrinkValid d) sd (-1.032730679986007e18)- twoTests (Proxy :: Proxy Double)- twoTupleTests (Proxy :: Proxy Double)- threeTests (Proxy :: Proxy (Ratio Int))+ genValidTest (Proxy :: Proxy Double)+ tupleTest (Proxy :: Proxy Double)+ genValidTest (Proxy :: Proxy (Ratio Int)) modifyMaxSuccess (`quot` 2) $- modifyMaxSize (`quot` 2) $ twoTests (Proxy :: Proxy (Either Bool Ordering))- twoTests (Proxy :: Proxy (Maybe Ordering))- twoTests (Proxy :: Proxy (Maybe (Maybe (Ordering))))- threeTests (Proxy :: Proxy (Ratio Integer))+ modifyMaxSize (`quot` 2) $+ genValidTest (Proxy :: Proxy (Either Bool Ordering))+ genValidTest (Proxy :: Proxy (Maybe Ordering))+ genValidTest (Proxy :: Proxy (Maybe (Maybe (Ordering))))+ genValidTest (Proxy :: Proxy (Ratio Integer)) -- threeTupleTests (Proxy :: Proxy (Ratio Integer))- threeTests (Proxy :: Proxy (Ratio Int))+ genValidTest (Proxy :: Proxy (Ratio Int)) -- threeTupleTests (Proxy :: Proxy (Ratio Int))- threeTests (Proxy :: Proxy (Ratio Int8))+ genValidTest (Proxy :: Proxy (Ratio Int8)) describe "shrinking (Ratio Int)" $ it "can shrink this example" $ let v = ((-9223372036854775808) % 9223372036854775761) :: Ratio Int@@ -80,88 +71,31 @@ it "can shrink this example" $ let v = ((-128) % 113) :: Ratio Int8 in v `notElem` shrinkValid v- twoTests (Proxy :: Proxy Uni)- twoTupleTests (Proxy :: Proxy Uni)- twoTests (Proxy :: Proxy Deci)- twoTupleTests (Proxy :: Proxy Deci)- twoTests (Proxy :: Proxy Centi)- twoTupleTests (Proxy :: Proxy Centi)- twoTests (Proxy :: Proxy Milli)- twoTupleTests (Proxy :: Proxy Milli)- twoTests (Proxy :: Proxy Micro)- twoTupleTests (Proxy :: Proxy Micro)- twoTests (Proxy :: Proxy Nano)- twoTupleTests (Proxy :: Proxy Nano)- twoTests (Proxy :: Proxy Pico)- twoTupleTests (Proxy :: Proxy Pico)--#if MIN_VERSION_base(4,8,0)- twoTests (Proxy :: Proxy Natural)-- twoTupleTests (Proxy :: Proxy Natural)-#endif-#if MIN_VERSION_base(4,9,0)- twoTests (Proxy :: Proxy (NonEmpty Ordering))-#endif-twoTupleTests ::- forall a.- (Show a, Eq a, Typeable a, GenUnchecked a, GenValid a) =>- Proxy a ->- Spec-twoTupleTests proxy = do- modifyMaxSuccess (`quot` 2) $ modifyMaxSize (`quot` 2) $ twoTests $ (,) <$> proxy <*> proxy--twoTests ::- forall a.- (Show a, Eq a, Typeable a, GenUnchecked a, GenValid a) =>- Proxy a ->- Spec-twoTests proxy =- describe (nameOf proxy) $ do- genUncheckedTest proxy- genValidTest proxy--threeTests ::- forall a.- (Show a, Eq a, Typeable a, GenUnchecked a, GenValid a, GenInvalid a) =>- Proxy a ->- Spec-threeTests proxy =- describe (nameOf proxy) $ do- genUncheckedTest proxy- genValidTest proxy- genInvalidTest proxy+ genValidTest (Proxy :: Proxy Uni)+ tupleTest (Proxy :: Proxy Uni)+ genValidTest (Proxy :: Proxy Deci)+ tupleTest (Proxy :: Proxy Deci)+ genValidTest (Proxy :: Proxy Centi)+ tupleTest (Proxy :: Proxy Centi)+ genValidTest (Proxy :: Proxy Milli)+ tupleTest (Proxy :: Proxy Milli)+ genValidTest (Proxy :: Proxy Micro)+ tupleTest (Proxy :: Proxy Micro)+ genValidTest (Proxy :: Proxy Nano)+ tupleTest (Proxy :: Proxy Nano)+ genValidTest (Proxy :: Proxy Pico)+ tupleTest (Proxy :: Proxy Pico)+ genValidTest (Proxy :: Proxy Natural)+ tupleTest (Proxy :: Proxy Natural)+ genValidTest (Proxy :: Proxy (NonEmpty Ordering)) -genUncheckedTest ::+tupleTest :: forall a.- (Show a, Eq a, Typeable a, GenUnchecked a, GenValid a) =>+ (Show a, Eq a, Typeable a, GenValid a) => Proxy a -> Spec-genUncheckedTest proxy = do- it (unwords ["genUnchecked of", nameOf proxy, "does not crash while validating"]) $- forAll genUnchecked $ \a ->- case prettyValidate (a :: a) of- Right v -> seq v True- Left err -> seq err True- modifyMaxSuccess (`quot` 5) $- it- ( unwords- [ "shrinkUnchecked of",- nameOf proxy,- "only produces values that do not crash while validating"- ]- )- $ forAll genUnchecked $ \a ->- forM_ (shrinkUnchecked a) $ \v ->- case prettyValidate (v :: a) of- Right v_ -> seq v_ $ pure () :: IO ()- Left err -> seq err $ pure ()- modifyMaxSuccess (`quot` 5) $- it (unwords ["shrinkUnchecked of", nameOf proxy, "does not shrink to itself"]) $- forAll genValid $ \a ->- forM_ (shrinkUnchecked a) $ \a' ->- unless (a /= a') $- expectationFailure $ unlines ["The value", show (a :: a), "was shrunk to itself"]+tupleTest proxy = do+ modifyMaxSuccess (`quot` 2) $ modifyMaxSize (`quot` 2) $ genValidTest $ (,) <$> proxy <*> proxy genValidTest :: forall a.@@ -185,61 +119,28 @@ Left err -> expectationFailure $ unlines ["'validate' reported this value to be invalid:", show v, err, ""]- modifyMaxSuccess (`quot` 5) $- it+ modifyMaxSuccess (`quot` 5)+ $ it ( unwords ["shrinkValid of", nameOf proxy, "only produces values that do not crash while validating"] )- $ forAll genValid $ \a ->- forM_ (shrinkValid a) $ \v ->- case prettyValidate (v :: a) of- Right v_ -> seq v_ $ pure () :: IO ()- Left err -> seq err $ pure ()+ $ forAll genValid+ $ \a ->+ forM_ (shrinkValid a) $ \v ->+ case prettyValidate (v :: a) of+ Right v_ -> seq v_ $ pure () :: IO ()+ Left err -> seq err $ pure () modifyMaxSuccess (`quot` 5) $ it (unwords ["shrinkValid of", nameOf proxy, "does not shrink to itself"]) $ forAll genValid $ \a -> forM_ (shrinkValid a) $ \a' -> unless (a /= a') $- expectationFailure $ unlines ["The value", show (a :: a), "was shrunk to itself"]--genInvalidTest ::- forall a.- (Show a, Typeable a, GenInvalid a) =>- Proxy a ->- Spec-genInvalidTest proxy = do- it (unwords ["genInvalid of", nameOf proxy, "generates only invalid values"]) $- forAll genInvalid $ \a ->- case prettyValidate (a :: a) of- Right _ ->- expectationFailure $ unlines ["'validate' reported this value to be valid: ", show a]- Left e -> seq e $ pure ()- modifyMaxSuccess (`quot` 5) $- it (unwords ["shrinkInvalid of", nameOf proxy, "shrinks to only invalid values"]) $- forAll genInvalid $ \a ->- forM_ (shrinkInvalid a) $ \v ->- case prettyValidate (v :: a) of- Right _ ->- expectationFailure $ unlines ["'validate' reported this value to be valid: ", show v]- Left e -> seq e $ pure ()- modifyMaxSuccess (`quot` 5) $- it- ( unwords- [ "shrinkInvalid of",- nameOf proxy,- "only produces values that do not crash while validating"- ]- )- $ forAll genInvalid $ \a ->- forM_ (shrinkInvalid a) $ \v ->- case prettyValidate (v :: a) of- Right _ ->- expectationFailure $ unlines ["'validate' reported this value to be valid: ", show v]- Left e -> seq e $ pure ()+ expectationFailure $+ unlines ["The value", show (a :: a), "was shrunk to itself"] nameOf :: forall a.- Typeable a =>+ (Typeable a) => Proxy a -> String nameOf = show . typeRep