genvalidity 0.2.0.4 → 1.1.1.0
raw patch · 11 files changed
Files
- CHANGELOG.md +204/−0
- LICENSE +1/−1
- Setup.hs +0/−2
- genvalidity.cabal +74/−48
- src/Data/GenRelativeValidity.hs +0/−20
- src/Data/GenValidity.hs +464/−172
- src/Data/GenValidity/Utils.hs +389/−0
- test/Data/GenValidity/GenericSpec.hs +105/−0
- test/Data/GenValidity/ShrinkGenericSpec.hs +63/−0
- test/Data/GenValiditySpec.hs +78/−39
- test/Data/InstanceSpec.hs +146/−0
+ 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 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,2 +0,0 @@-import Distribution.Simple-main = defaultMain
genvalidity.cabal view
@@ -1,56 +1,82 @@-name: genvalidity-version: 0.2.0.4-synopsis: Testing utilities for the validity library-description:- Note: There are companion instance packages for this library:- .- * <https://hackage.haskell.org/package/genvalidity-text genvalidity-text>- .- * <https://hackage.haskell.org/package/genvalidity-containers genvalidity-containers>+cabal-version: 1.12 -homepage: https://github.com/NorfairKing/validity#readme-license: MIT-license-file: LICENSE-author: Tom Sydney Kerckhove-maintainer: syd.kerckhove@gmail.com-copyright: Copyright: (c) 2016 Tom Sydney Kerckhove-category: Testing-build-type: Simple--- extra-source-files:-cabal-version: >=1.10+-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack +name: genvalidity+version: 1.1.1.0+synopsis: Testing utilities for the validity library+description: Note: There are companion instance packages for this library:+ .+ * <https://hackage.haskell.org/package/genvalidity-aeson genvalidity-aeson>+ .+ * <https://hackage.haskell.org/package/genvalidity-bytestring genvalidity-bytestring>+ .+ * <https://hackage.haskell.org/package/genvalidity-containers genvalidity-containers>+ .+ * <https://hackage.haskell.org/package/genvalidity-path genvalidity-path>+ .+ * <https://hackage.haskell.org/package/genvalidity-scientific genvalidity-scientific>+ .+ * <https://hackage.haskell.org/package/genvalidity-text genvalidity-text>+ .+ * <https://hackage.haskell.org/package/genvalidity-time genvalidity-time>+ .+ * <https://hackage.haskell.org/package/genvalidity-unordered-containers genvalidity-unordered-containers>+ .+ * <https://hackage.haskell.org/package/genvalidity-uuid genvalidity-uuid>+ .+ * <https://hackage.haskell.org/package/genvalidity-vector genvalidity-vector>+category: Testing+homepage: https://github.com/NorfairKing/validity#readme+bug-reports: https://github.com/NorfairKing/validity/issues+author: Tom Sydney Kerckhove+maintainer: syd@cs-syd.eu+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+ location: https://github.com/NorfairKing/validity+ library- hs-source-dirs: src- exposed-modules: Data.GenValidity- , Data.GenRelativeValidity- build-depends: base < 5- , validity >= 0.3 && < 0.4- , QuickCheck >= 2.8 && < 2.10- default-language: Haskell2010+ exposed-modules:+ Data.GenValidity+ Data.GenValidity.Utils+ other-modules:+ Paths_genvalidity+ hs-source-dirs:+ src+ ghc-options: -Wno-redundant-constraints+ build-depends:+ QuickCheck >=2.13+ , base >=4.13 && <5+ , random >=1.1+ , validity >=0.12.1+ default-language: Haskell2010 test-suite genvalidity-test- type:- exitcode-stdio-1.0- default-language:- Haskell2010- hs-source-dirs:- test- main-is:- Spec.hs+ type: exitcode-stdio-1.0+ main-is: Spec.hs other-modules:- Data.GenValiditySpec- ghc-options:- -threaded -rtsopts -with-rtsopts=-N- -Wall- -fno-warn-name-shadowing+ Data.GenValidity.GenericSpec+ Data.GenValidity.ShrinkGenericSpec+ Data.GenValiditySpec+ Data.InstanceSpec+ Paths_genvalidity+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall build-depends:- base-- , hspec- , QuickCheck >= 2.8 && < 2.9-+ QuickCheck+ , base >=4.13 && <5 , genvalidity--source-repository head- type: git- location: https://github.com/NorfairKing/validity+ , hspec+ , hspec-core+ default-language: Haskell2010
− src/Data/GenRelativeValidity.hs
@@ -1,20 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-module Data.GenRelativeValidity- ( module Data.RelativeValidity- , module Data.GenRelativeValidity- ) where--import Data.RelativeValidity-import Data.GenValidity--import Test.QuickCheck--class (GenValidity a, RelativeValidity a b) => GenRelativeValidity a b where- genUncheckedFor :: b -> Gen a- genUncheckedFor _ = genUnchecked-- genValidFor :: b -> Gen a- genValidFor b = genValid `suchThat` (`isValidFor` b)-- genInvalidFor :: b -> Gen a- genInvalidFor b = genUncheckedFor b `suchThat` (not . (`isValidFor` b))
src/Data/GenValidity.hs view
@@ -1,206 +1,498 @@-{-|+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} - @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.+--+-- 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.+-- 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 GenValid Prime where+-- > genValid = Prime <$>+-- > (oneof+-- > [ pure 2+-- > , ((\y -> 2 * abs y + 1) <$> arbitrary) `suchThat` isPrime)+-- > ])+--+--+-- Typical examples of tests involving validity could look as follows:+--+-- > it "succeeds when given valid input" $ do+-- > forAllValid $ \input ->+-- > myFunction input `shouldSatisfy` isRight+--+-- > it "produces valid output when it succeeds" $ do+-- > forAllValid $ \input ->+-- > case myFunction input of+-- > Nothing -> return () -- Can happen+-- > Just output -> output `shouldSatisfy` isValid+--+-- Definitely also look at the companion packages for more info on how to use this package.+module Data.GenValidity+ ( GenValid (..), - 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.+ -- * Helper functions+ genValidStructurally,+ genValidStructurallyWithoutExtraChecking,+ shrinkValidStructurally,+ shrinkValidStructurallyWithoutExtraFiltering,+ module Data.GenValidity.Utils, - The @GenValidity@ type class allows you to specify how to (efficiently)- generate data of the given type to allow for easier and quicker testing.- Just implementing @genUnchecked@ already gives you access to @genValid@ and- @genInvalid@ but writing custom implementations of these functions may speed- up the generation of data.+ -- ** Helper functions for specific types - 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:+ -- *** Char+ genUtf16SurrogateCodePoint,+ genLineSeparator,+ genNonLineSeparator, - > instance GenValidity Prime where- > genUnchecked = Prime <$> arbitrary- > genValid = Prime <$>- > (oneof- > [ pure 2- > , (\y -> 2 * y + 1) <$> (arbitrary `suchThat` (> 0) `suchThat` isPrime)- > ])+ -- *** String+ genSingleLineString, + -- * Re-exports+ module Data.Validity, - Typical examples of tests involving validity could look as follows:+ -- * The Generics magic+ GGenValid (..),+ GValidRecursivelyShrink (..),+ structurallyValidSubterms,+ GValidSubterms (..),+ GValidSubtermsIncl (..),+ )+where - > it "succeeds when given valid input" $ do- > forAll genValid $ \input ->- > myFunction input `shouldSatisfy` isRight+import Control.Monad (guard)+import Data.Char (chr)+import Data.Fixed (Fixed (..), HasResolution)+import Data.Functor.Const (Const (Const))+import Data.Functor.Identity (Identity (Identity))+import Data.GenValidity.Utils+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.Real (Ratio (..))+import Numeric.Natural+import Test.QuickCheck hiding (Fixed) - > it "produces valid output when it succeeds" $ do- > forAll genUnchecked $ \input ->- > case myFunction input of- > Nothing -> return () -- Can happen- > Just output -> output `shouldSatisfy` isValid- -}+{-# ANN module "HLint: ignore Reduce duplication" #-} -module Data.GenValidity- ( module Data.Validity- , module Data.GenValidity- ) where+-- | 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.+-- It is possible that, if few values are valid or if validity+-- checking is expensive, the resulting generator is too slow.+-- In that case, go to Step 2.+--+-- __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 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'+--+-- If you also write @Arbitrary@ instances for @GenValid@ types, it may be+-- best to simply use+--+-- > 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 = 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 :: (Generic a, GGenValid (Rep a)) => Gen a+ genValid = genValidStructurally -import Data.Validity+ -- | Shrink a valid value.+ --+ -- The default implementation is as follows:+ --+ -- > 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 :: (Generic a, GValidRecursivelyShrink (Rep a), GValidSubterms (Rep a) a) => a -> [a]+ shrinkValid = shrinkValidStructurally -import Test.QuickCheck+instance (GenValid a, GenValid b) => GenValid (a, b) where+ genValid =+ sized $ \n -> do+ (r, s) <- genSplit n+ a <- resize r genValid+ b <- resize s genValid+ return (a, b)+ shrinkValid = shrinkTuple shrinkValid shrinkValid -import Control.Monad (forM)+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 --- | A class of types for which @Validity@-related values can be generated.+instance (GenValid a, GenValid b, GenValid c) => GenValid (a, b, c) where+ genValid =+ sized $ \n -> do+ (r, s, t) <- genSplit3 n+ a <- resize r genValid+ b <- resize s genValid+ c <- resize t genValid+ return (a, b, c)+ shrinkValid = shrinkTriple shrinkValid shrinkValid shrinkValid++instance+ (GenValid a, GenValid b, GenValid c, GenValid d) =>+ GenValid (a, b, c, d)+ where+ genValid =+ sized $ \n -> do+ (r, s, t, u) <- genSplit4 n+ a <- resize r genValid+ b <- resize s genValid+ c <- resize t genValid+ d <- resize u genValid+ return (a, b, c, d)+ shrinkValid = shrinkQuadruple shrinkValid shrinkValid shrinkValid shrinkValid++instance+ (GenValid a, GenValid b, GenValid c, GenValid d, GenValid e) =>+ GenValid (a, b, c, d, e)+ where+ genValid =+ sized $ \n -> do+ (r, s, t, u, v) <- genSplit5 n+ a <- resize r genValid+ b <- resize s genValid+ c <- resize t genValid+ d <- resize u genValid+ e <- resize v genValid+ return (a, b, c, d, e)+ shrinkValid (a, b, c, d, e) =+ [ (a', b', c', d', e')+ | (a', (b', (c', (d', e')))) <- shrinkValid (a, (b, (c, (d, e))))+ ]++instance (GenValid a) => GenValid (Maybe a) where+ genValid = genMaybe genValid+ shrinkValid = shrinkMaybe shrinkValid++instance (GenValid a) => GenValid (NonEmpty a) where+ genValid = genNonEmptyOf genValid+ shrinkValid = shrinkNonEmpty shrinkValid++instance (GenValid a) => GenValid [a] where+ genValid = genListOf genValid+ shrinkValid = shrinkList shrinkValid++instance GenValid () where+ genValid = pure ()+ shrinkValid () = []++instance GenValid Bool where+ genValid = arbitrary+ shrinkValid = shrink++instance GenValid Ordering where+ genValid = arbitrary+ shrinkValid = 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)]++genLineSeparator :: Gen Char+genLineSeparator = elements ['\n', '\r']++genNonLineSeparator :: Gen Char+genNonLineSeparator = genValid `suchThat` (not . isLineSeparator)++genSingleLineString :: Gen String+genSingleLineString = genListOf genNonLineSeparator++instance GenValid Int where+ genValid = genIntX+ shrinkValid = shrink++instance GenValid Int8 where+ genValid = genIntX+ shrinkValid = shrink++instance GenValid Int16 where+ genValid = genIntX+ shrinkValid = shrink++instance GenValid Int32 where+ genValid = genIntX+ shrinkValid = shrink++instance GenValid Int64 where+ genValid = genIntX+ shrinkValid = shrink++instance GenValid Word where+ genValid = genWordX+ shrinkValid = shrink++instance GenValid Word8 where+ genValid = genWordX+ shrinkValid = shrink++instance GenValid Word16 where+ genValid = genWordX+ shrinkValid = shrink++instance GenValid Word32 where+ genValid = genWordX+ shrinkValid = shrink++instance GenValid Word64 where+ genValid = genWordX+ shrinkValid = shrink++instance GenValid Float where+ genValid = genFloat+ shrinkValid f+ | isInfinite f = []+ | isNaN f = []+ | otherwise = shrink f++instance GenValid Double where+ genValid = genDouble+ shrinkValid d+ | isInfinite d = []+ | isNaN d = []+ | otherwise = shrink d++instance GenValid Integer where+ genValid = genInteger+ shrinkValid = shrink++instance GenValid Natural where+ genValid = fromInteger . abs <$> genValid+ shrinkValid = fmap (fromInteger . abs) . shrinkValid . toInteger++instance (Integral a, Num a, Ord a, GenValid a) => GenValid (Ratio a) where+ genValid =+ ( do+ n <- genValid+ d <- (genValid `suchThat` (> 0))+ pure $ n :% d+ )+ `suchThat` isValid+ shrinkValid (n :% d) = do+ (n', d') <- shrinkTuple shrinkValid (filter (> 0) . shrinkValid) (n, d)+ let candidate = n' :% d'+ guard $ isValid candidate+ pure $ n' % d'++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 ----- If you also write @Arbitrary@ instances for @GenValidity@ types, it may be--- best to simply write @arbitrary = genValid@.-class Validity a => GenValidity a where- -- | Generate a truly arbitrary datum, this should cover all possible- -- values in the type- genUnchecked :: Gen a+-- > genValidStructurally = genValidStructurallyWithoutExtraChecking `suchThat` isValid+--+-- This is probably the function that you are looking for.+-- If you do use this function to override `genValid`, you probably also want to use+-- 'shrinkValidStructurally' to override 'shrinkValid'.+genValidStructurally :: (Validity a, Generic a, GGenValid (Rep a)) => Gen a+genValidStructurally = genValidStructurallyWithoutExtraChecking `suchThat` isValid - -- | Generate a valid datum, this should cover all possible valid values in- -- the type- --- -- The default implementation is as follows:- --- -- > genValid = genUnchecked `suchThat` isValid- --- -- 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- genValid = genUnchecked `suchThat` isValid+-- | Generate a valid value by generating all the sub parts using the 'Generic' instance,+--+-- This generator is _not_ guaranteed to generate a valid value.+--+-- This is probably _not_ the function that you are looking for when overriding+-- `genValid` _unless_ the type in question has no _extra_ validity constraints on top of+-- the validity of its sub parts.+genValidStructurallyWithoutExtraChecking :: (Generic a, GGenValid (Rep a)) => Gen a+genValidStructurallyWithoutExtraChecking = to <$> gGenValid - -- | Generate an invalid datum, this should cover all possible invalid- -- values- --- -- > genInvalid = genUnchecked `suchThat` (not . isValid)- --- -- 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.- genInvalid :: Gen a- genInvalid = genUnchecked `suchThat` (not . isValid)- {-# MINIMAL genUnchecked #-}+class GGenValid f where+ gGenValid :: Gen (f a) -instance (GenValidity a, GenValidity b) => GenValidity (a, b) where- genUnchecked = sized $ \n -> do- (r, s) <- genSplit n- a <- resize r genUnchecked- b <- resize s genUnchecked- return (a, b)+instance GGenValid U1 where+ gGenValid = pure U1 - genValid = sized $ \n -> do- (r, s) <- genSplit n- a <- resize r genValid- b <- resize s genValid- return (a, b)+instance (GGenValid a, GGenValid b) => GGenValid (a :*: b) where+ gGenValid = (:*:) <$> gGenValid <*> gGenValid - 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 (GGenValid a, GGenValid b) => GGenValid (a :+: b) where+ gGenValid = oneof [L1 <$> gGenValid, R1 <$> gGenValid] -instance (GenValidity a, GenValidity b, GenValidity c) => GenValidity (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)+instance (GGenValid a) => GGenValid (M1 i c a) where+ gGenValid = M1 <$> gGenValid - genValid = sized $ \n -> do- (r, s, t) <- genSplit3 n- a <- resize r genValid- b <- resize s genValid- c <- resize t genValid- return (a, b, c)+instance (GenValid a) => GGenValid (K1 i a) where+ gGenValid = K1 <$> genValid - 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)- ]+deriving newtype instance (GenValid a) => GenValid (Identity a) -instance GenValidity a => GenValidity (Maybe a) where- genUnchecked = oneof [pure Nothing, Just <$> genUnchecked]- genValid = oneof [pure Nothing, Just <$> genValid]- genInvalid = Just <$> genInvalid+deriving newtype instance (GenValid (f a)) => GenValid (Alt f a) +deriving newtype instance (GenValid a) => GenValid (Dual a) --- | If we can generate values of a certain type, we can also generate lists of--- them.--- This instance ensures that @genValid@ generates only lists of valid data and--- that @genInvalid@ generates lists of data such that there is at least one--- value in there that does not satisfy @isValid@, the rest is unchecked.-instance GenValidity a => GenValidity [a] where- genUnchecked = genListOf genUnchecked+deriving newtype instance (GenValid a) => GenValid (Semigroup.First a) - genValid = genListOf genValid+deriving newtype instance (GenValid a) => GenValid (Semigroup.Last a) - -- | At least one invalid value in the list, the rest could be either.- 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+deriving newtype instance (GenValid a) => GenValid (Monoid.First a) -upTo :: Int -> Gen Int-upTo n- | n <= 0 = pure 0- | otherwise = elements [0 .. n]+deriving newtype instance (GenValid a) => GenValid (Monoid.Last a) -genSplit :: Int -> Gen (Int, Int)-genSplit n- | n < 0 = pure (0, 0)- | otherwise = elements [ (i, n - i) | i <- [0..n] ]+deriving newtype instance (GenValid a) => GenValid (Const a b) -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)+-- | 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.+--+-- > shrinkValidStructurally = filter isValid . shrinkValidStructurallyWithoutExtraFiltering+--+-- This is probably the function that you are looking for.+shrinkValidStructurally :: (Validity a, Generic a, GValidRecursivelyShrink (Rep a), GValidSubterms (Rep a) a) => a -> [a]+shrinkValidStructurally = filter isValid . shrinkValidStructurallyWithoutExtraFiltering -arbPartition :: Int -> Gen [Int]-arbPartition k- | k <= 0 = pure []- | otherwise = do- first <- elements [1..k]- rest <- arbPartition $ k - first- return $ first : rest+-- | Shrink a term to any of its immediate valid subterms,+-- and also recursively shrink all subterms.+--+-- This shrinking function is _not_ guaranteed to shrink to valid values.+--+-- This is probably _not_ the function that you are looking for when overriding+-- `shrinkValid` _unless_ the type in question has no _extra_ validity constraints on top of+-- the validity of its sub parts.+shrinkValidStructurallyWithoutExtraFiltering :: (Generic a, GValidRecursivelyShrink (Rep a), GValidSubterms (Rep a) a) => a -> [a]+shrinkValidStructurallyWithoutExtraFiltering x = structurallyValidSubterms x ++ structurallyValidRecursivelyShrink x --- | A version of @listOf@ that takes size into account more accurately.-genListOf :: Gen a -> Gen [a]-genListOf func = sized $ \n -> do- size <- upTo n- pars <- arbPartition size- forM pars $ \i -> resize i func+-- | Recursively shrink all immediate structurally valid subterms.+structurallyValidRecursivelyShrink :: (Generic a, GValidRecursivelyShrink (Rep a)) => a -> [a]+structurallyValidRecursivelyShrink = map to . gValidRecursivelyShrink . from +class GValidRecursivelyShrink f where+ gValidRecursivelyShrink :: f a -> [f a]++instance (GValidRecursivelyShrink f, GValidRecursivelyShrink g) => GValidRecursivelyShrink (f :*: g) where+ gValidRecursivelyShrink (x :*: y) =+ ((:*:) <$> gValidRecursivelyShrink x <*> gValidRecursivelyShrink y)+ ++ [x' :*: y | x' <- gValidRecursivelyShrink x]+ ++ [x :*: y' | y' <- gValidRecursivelyShrink y]++instance (GValidRecursivelyShrink f, GValidRecursivelyShrink g) => GValidRecursivelyShrink (f :+: g) where+ gValidRecursivelyShrink (L1 x) = map L1 (gValidRecursivelyShrink x)+ gValidRecursivelyShrink (R1 x) = map R1 (gValidRecursivelyShrink x)++instance (GValidRecursivelyShrink f) => GValidRecursivelyShrink (M1 i c f) where+ gValidRecursivelyShrink (M1 x) = map M1 (gValidRecursivelyShrink x)++instance (GenValid a) => GValidRecursivelyShrink (K1 i a) where+ gValidRecursivelyShrink (K1 x) = map K1 (shrinkValid x)++instance GValidRecursivelyShrink U1 where+ gValidRecursivelyShrink U1 = []++instance GValidRecursivelyShrink V1 where+ -- The empty type can't be shrunk to anything.+ gValidRecursivelyShrink _ = []++-- | All immediate validSubterms of a term.+structurallyValidSubterms :: (Generic a, GValidSubterms (Rep a) a) => a -> [a]+structurallyValidSubterms = gValidSubterms . from++class GValidSubterms f a where+ gValidSubterms :: f a -> [a]++instance GValidSubterms V1 a where+ gValidSubterms _ = []++instance GValidSubterms U1 a where+ gValidSubterms U1 = []++instance (GValidSubtermsIncl f a, GValidSubtermsIncl g a) => GValidSubterms (f :*: g) a where+ gValidSubterms (l :*: r) = gValidSubtermsIncl l ++ gValidSubtermsIncl r++instance (GValidSubtermsIncl f a, GValidSubtermsIncl g a) => GValidSubterms (f :+: g) a where+ gValidSubterms (L1 x) = gValidSubtermsIncl x+ gValidSubterms (R1 x) = gValidSubtermsIncl x++instance (GValidSubterms f a) => GValidSubterms (M1 i c f) a where+ gValidSubterms (M1 x) = gValidSubterms x++instance GValidSubterms (K1 i a) b where+ gValidSubterms (K1 _) = []++class GValidSubtermsIncl f a where+ gValidSubtermsIncl :: f a -> [a]++instance GValidSubtermsIncl V1 a where+ gValidSubtermsIncl _ = []++instance GValidSubtermsIncl U1 a where+ gValidSubtermsIncl U1 = []++instance (GValidSubtermsIncl f a, GValidSubtermsIncl g a) => GValidSubtermsIncl (f :*: g) a where+ gValidSubtermsIncl (l :*: r) = gValidSubtermsIncl l ++ gValidSubtermsIncl r++instance (GValidSubtermsIncl f a, GValidSubtermsIncl g a) => GValidSubtermsIncl (f :+: g) a where+ gValidSubtermsIncl (L1 x) = gValidSubtermsIncl x+ gValidSubtermsIncl (R1 x) = gValidSubtermsIncl x++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+ gValidSubtermsIncl (K1 x) = [x]++instance {-# OVERLAPPING #-} GValidSubtermsIncl (K1 i a) b where+ gValidSubtermsIncl (K1 _) = []
+ src/Data/GenValidity/Utils.hs view
@@ -0,0 +1,389 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}++module Data.GenValidity.Utils+ ( -- ** Helper functions for implementing generators+ upTo,+ genSplit,+ genSplit3,+ genSplit4,+ genSplit5,+ genSplit6,+ genSplit7,+ genSplit8,+ arbPartition,+ shuffle,+ genListLength,+ genStringBy,+ genStringBy1,+ genListOf,+ genListOf1,+ genMaybe,+ genNonEmptyOf,+ genIntX,+ genWordX,+ genFloat,+ genDouble,+ genFloatX,+ genInteger,++ -- ** 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.Float (castWord32ToFloat, castWord64ToDouble)+import System.Random+import Test.QuickCheck hiding (Fixed)++-- | 'upTo' generates an integer between 0 (inclusive) and 'n'.+upTo :: Int -> Gen Int+upTo n+ | n <= 0 = pure 0+ | otherwise = choose (0, n)++-- | 'genSplit a' generates a tuple '(b, c)' such that 'b + c' equals 'a'.+genSplit :: Int -> Gen (Int, Int)+genSplit n+ | n < 0 = pure (0, 0)+ | otherwise = do+ 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)++-- | '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)++-- | '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)++-- | '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)++-- | '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)++-- | '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)++-- | 'arbPartition n' generates a list 'ls' such that 'sum ls' equals 'n', approximately.+arbPartition :: Int -> Gen [Int]+arbPartition 0 = pure []+arbPartition i = genListLengthWithSize i >>= go i+ where+ go :: Int -> Int -> Gen [Int]+ go size len = do+ us <- replicateM len $ choose (0, 1)+ let invs = map (invE 0.25) us+ -- Rescale the sizes to (approximately) sum to the given size.+ pure $ map (round . (* (fromIntegral size / sum invs))) invs++ -- Use an exponential distribution for generating the+ -- sizes in the partition.+ invE :: Double -> Double -> Double+ invE lambda u = (-log (1 - u)) / lambda++genMaybe :: Gen a -> Gen (Maybe a)+genMaybe gen = oneof [pure Nothing, Just <$> gen]++genNonEmptyOf :: Gen a -> Gen (NonEmpty a)+genNonEmptyOf gen = do+ l <- genListOf gen+ case NE.nonEmpty l of+ Nothing -> scale (+ 1) $ genNonEmptyOf gen+ Just ne -> pure ne++-- Uses 'genListLengthWithSize' with the size parameter+genListLength :: Gen Int+genListLength = sized genListLengthWithSize++-- Generate a list length with the given size+genListLengthWithSize :: Int -> Gen Int+genListLengthWithSize maxLen = round . invT (fromIntegral maxLen) <$> choose (0, 1)+ where+ -- Use a triangle distribution for generating the+ -- length of the list+ -- with minimum length '0', mode length '2'+ -- and given max length.+ invT :: Double -> Double -> Double+ invT m u =+ let a = 0+ b = m+ c = 2+ fc = (c - a) / (b - a)+ in if u < fc+ 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+-- in the list that it generates.+genListOf :: Gen a -> Gen [a]+genListOf func =+ sized $ \n -> do+ 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 = shrinkTuple s s++-- | Turn a shrinking function into a function that shrinks triples.+shrinkT3 :: (a -> [a]) -> (a, a, a) -> [(a, a, a)]+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 = 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+-- * Some around zero+-- * Mostly uniformly+genIntX :: forall a. (Integral a, Bounded a, Random a) => Gen a+genIntX =+ frequency+ [ (1, extreme),+ (1, small),+ (8, uniformInt)+ ]+ where+ extreme :: Gen a+ extreme = sized $ \s ->+ oneof+ [ choose (maxBound - fromIntegral s, maxBound),+ choose (minBound, minBound + fromIntegral s)+ ]+ small :: Gen a+ small = sized $ \s -> choose (-fromIntegral s, fromIntegral s)+ uniformInt :: Gen a+ uniformInt = choose (minBound, maxBound)++-- | Generate Word, Word8, Word16, Word32 and Word64 values smartly.+--+-- * Some at the border+-- * Some around zero+-- * Mostly uniformly+genWordX :: forall a. (Integral a, Bounded a, Random a) => Gen a+genWordX =+ frequency+ [ (1, extreme),+ (1, small),+ (8, uniformWord)+ ]+ where+ extreme :: Gen a+ extreme = sized $ \s ->+ choose (maxBound - fromIntegral s, maxBound)+ small :: Gen a+ small = sized $ \s -> choose (0, fromIntegral s)+ uniformWord :: Gen a+ uniformWord = choose (minBound, maxBound)++-- | See 'genFloatX'+genFloat :: Gen Float+genFloat = genFloatX castWord32ToFloat++-- | See 'genFloatX'+genDouble :: Gen Double+genDouble = genFloatX castWord64ToDouble++-- | Generate floating point numbers smartly:+--+-- * Some denormalised+-- * Some around zero+-- * Some around the bounds+-- * Some by encoding an Integer and an Int to a floating point number.+-- * Some accross the entire range+-- * Mostly uniformly via the bitrepresentation+--+-- The function parameter is to go from the bitrepresentation to the floating point value.+genFloatX ::+ forall a w.+ (Read a, RealFloat a, Bounded w, Random w) =>+ (w -> a) ->+ Gen a+genFloatX func =+ frequency+ [ (1, denormalised),+ (1, small),+ (1, aroundBounds),+ (1, uniformViaEncoding),+ (6, reallyUniform)+ ]+ where+ denormalised :: Gen a+ denormalised =+ elements+ [ read "NaN",+ read "Infinity",+ read "-Infinity",+ read "-0"+ ]+ -- This is what Quickcheck does,+ -- but inlined so QuickCheck cannot change+ -- it behind the scenes in the future.+ small :: Gen a+ small = sized $ \n -> do+ let n' = toInteger n+ let precision = 9999999999999 :: Integer+ b <- choose (1, precision)+ 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)+ (lowerExponent, upperExponent) = floatRange (0.0 :: a)+ aroundBounds :: Gen a+ aroundBounds = do+ s <- sized $ \n ->+ oneof+ [ choose (lowerSignificand, lowerSignificand + fromIntegral n),+ choose (upperSignificand - fromIntegral n, upperSignificand)+ ]+ e <- sized $ \n ->+ oneof+ [ choose (lowerExponent, lowerExponent + n),+ choose (upperExponent - n, upperExponent)+ ]+ pure $ encodeFloat s e+ uniformViaEncoding :: Gen a+ uniformViaEncoding = do+ s <- choose (lowerSignificand, upperSignificand)+ e <- choose $ floatRange (0.0 :: a)+ pure $ encodeFloat s e+ -- Not really uniform, but good enough+ reallyUniform :: Gen a+ reallyUniform = func <$> choose (minBound, maxBound)++genInteger :: Gen Integer+genInteger = sized $ \s ->+ oneof $+ (if s >= 10 then (genBiggerInteger :) else id)+ [ genIntSizedInteger,+ small+ ]+ where+ small = sized $ \s -> choose (-toInteger s, toInteger s)+ genIntSizedInteger = toInteger <$> (genIntX :: Gen Int)+ genBiggerInteger = sized $ \s -> do+ (a, b, c) <- genSplit3 s+ ai <- resize a genIntSizedInteger+ bi <- resize b genInteger+ ci <- resize c genIntSizedInteger+ pure $ ai * bi + ci
+ test/Data/GenValidity/GenericSpec.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.GenValidity.GenericSpec+ ( spec,+ )+where++import Control.Monad+import Data.GenValidity+import Data.Proxy+import Data.Typeable+import GHC.Generics (Generic, Rep)+import Test.Hspec+import Test.QuickCheck++spec :: Spec+spec = do+ describe "genValidStructurally" $ do+ genValidstructurallySpec (Proxy :: Proxy Bool)+ genValidstructurallySpec (Proxy :: Proxy Ordering)+ genValidstructurallySpec (Proxy :: Proxy (Maybe Double))+ genValidstructurallySpec (Proxy :: Proxy (Either Double Ordering))+ genValidstructurallySpec (Proxy :: Proxy MyType)+ describe "shrinkValidStructurally" $ do+ shrinkValidstructurallySpec (Proxy :: Proxy Bool)+ shrinkValidstructurallySpec (Proxy :: Proxy Ordering)+ shrinkValidstructurallySpec (Proxy :: Proxy (Maybe Double))+ shrinkValidstructurallySpec (Proxy :: Proxy (Either Double Ordering))+ shrinkValidstructurallySpec (Proxy :: Proxy MyType)++genValidstructurallySpec ::+ forall a.+ (Validity a, Show a, Typeable a, Generic a, GGenValid (Rep a)) =>+ Proxy a ->+ Spec+genValidstructurallySpec proxy =+ it (unwords ["only generates valid", "\"" ++ nameOf proxy ++ "\"s"]) $+ forAll (genValidStructurally :: Gen a) $ \a ->+ case prettyValidate a of+ Right _ -> return ()+ Left err ->+ expectationFailure $+ unlines+ [ "'validate' reported this value to be invalid: ",+ show a,+ "with explanation",+ err,+ ""+ ]++shrinkValidstructurallySpec ::+ forall a.+ ( Show a,+ Eq a,+ Typeable a,+ Generic a,+ GenValid a,+ GValidRecursivelyShrink (Rep a),+ GValidSubterms (Rep a) a+ ) =>+ Proxy a ->+ Spec+shrinkValidstructurallySpec proxy = do+ it (unwords ["only shrinks to valid", "\"" ++ nameOf proxy ++ "\"s"]) $+ forAll (genValid :: Gen a) $ \a ->+ forM_ (shrinkValidStructurally a) $ \subA ->+ case prettyValidate subA of+ Right _ -> return ()+ Left err ->+ expectationFailure $+ unlines+ [ "'validate' reported this value to be invalid: ",+ show subA,+ "with explanation",+ err,+ "but it should have been valid from shrinking"+ ]+ it+ ( unwords+ ["never shrinks to itself for valid", "\"" ++ nameOf proxy ++ "\"s"]+ )+ $ forAll (genValid :: Gen a)+ $ \a ->+ forM_ (shrinkValidStructurally a) $ \subA ->+ when (subA == a) $+ expectationFailure $+ unlines [show a, "was shrunk to itself."]++nameOf ::+ forall a.+ (Typeable a) =>+ Proxy a ->+ String+nameOf = show . typeRep++data MyType+ = MyType Double Ordering+ deriving (Show, Eq, Generic, Typeable)++instance Validity MyType++instance GenValid MyType
+ test/Data/GenValidity/ShrinkGenericSpec.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE DeriveGeneric #-}++module Data.GenValidity.ShrinkGenericSpec where++import Data.GenValidity+import GHC.Generics (Generic)+import Test.Hspec++spec :: Spec+spec = do+ describe "default shrinkValid" $ do+ it "figures out the right shrinking function for A" $+ shrinkValid A2 `shouldBe` [A1]+ it "figures out the right shrinking function for B" $+ shrinkValid B3 `shouldBe` [B1]+ it "shrinks tuples correctly" $+ shrinkValid ((A2, B3)) `shouldBe` [(A1, B1), (A1, B3), (A2, B1)]+ it "figures out the right shrinking function for Ex" $+ shrinkValid (Ex A2 B3) `shouldBe` [Ex A1 B1, Ex A1 B3, Ex A2 B1]+ describe "shrinkValidStructurally" $ do+ it "shrinks tuples correctly" $+ shrinkValidStructurally ((A2, B3))+ `shouldBe` [(A1, B1), (A1, B3), (A2, B1)]+ it "figures out the right shrinking function for Ex" $+ shrinkValidStructurally (Ex A2 B3)+ `shouldBe` [Ex A1 B1, Ex A1 B3, Ex A2 B1]++data Ex+ = Ex+ A+ B+ deriving (Show, Eq, Generic)++instance Validity Ex++instance GenValid Ex++data A+ = A1+ | A2+ deriving (Show, Eq, Generic)++instance Validity A++instance GenValid A where+ shrinkValid A1 = []+ shrinkValid A2 = [A1]++data B+ = B1+ | B2+ | B3+ deriving (Show, Eq, Generic)++instance Validity B where+ validate B1 = valid+ validate B2 = invalid "for test"+ validate B3 = valid++instance GenValid B where+ shrinkValid B1 = []+ shrinkValid B2 = [B1]+ shrinkValid B3 = [B1]
test/Data/GenValiditySpec.hs view
@@ -1,43 +1,82 @@-module Data.GenValiditySpec (spec) where--import Test.Hspec-import Test.QuickCheck+module Data.GenValiditySpec+ ( spec,+ )+where -import Data.GenValidity+import Data.GenValidity+import Test.Hspec+import Test.QuickCheck spec :: Spec spec = do- describe "upTo" $ do- it "returns only positive integers" $ do- forAll arbitrary $ \n ->- forAll (upTo n) (`shouldSatisfy` (>= 0))-- describe "genSplit" $ do- it "returns positive integers" $ do- forAll arbitrary $ \i ->- forAll (genSplit i) $ \(a, b) -> do- a `shouldSatisfy` (>= 0)- b `shouldSatisfy` (>= 0)-- it "returns two integers such that the sum is the original integer" $ do- forAll (arbitrary `suchThat` (>= 0)) $ \i ->- forAll (genSplit i) $ \(a, b) ->- a + b `shouldBe` i-- describe "arbPartition" $ do- it "returns an empty list upon strictly negative input" $ do- forAll (arbitrary `suchThat` (< 0)) $ \n ->- forAll (arbPartition n) (`shouldBe` [])-- it "returns a list of strictly positive integers" $ do- forAll arbitrary $ \n ->- forAll (arbPartition n) $ \p ->- p `shouldSatisfy` all (> 0)-- it "returns a list of integers that sum to the original positive integer" $ do- forAll (arbitrary `suchThat` (>= 0)) $ \n ->- forAll (arbPartition n) $ \p ->- sum p `shouldBe` n---+ describe "genUtf16SurrogateCodePoint" $+ it "generates Utf16 surrogate codepoints" $+ forAll genUtf16SurrogateCodePoint (`shouldSatisfy` isUtf16SurrogateCodePoint)+ describe "genLineSeparator" $+ it "generates only line separators" $+ forAll genLineSeparator (`shouldSatisfy` isLineSeparator)+ describe "genNonLineSeparator" $+ it "never generates line separators" $+ forAll genNonLineSeparator (`shouldSatisfy` (not . isLineSeparator))+ describe "genSingleLineString" $+ it "generates only single line strings" $+ forAll genSingleLineString (`shouldSatisfy` isSingleLine)+ describe "upTo" $ do+ it "returns only positive integers" $+ 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)))+ describe "genSplit" $ do+ it "returns positive integers" $+ forAll arbitrary $ \i ->+ forAll (genSplit i) $ \(a, b) -> do+ a `shouldSatisfy` (>= 0)+ b `shouldSatisfy` (>= 0)+ it "returns two integers such that the sum is the original integer" $+ forAll arbitrary $ \i ->+ forAll (genSplit i) $ \(a, b) -> a + b `shouldBe` max 0 i+ describe "genSplit3" $ do+ it "returns positive integers" $+ forAll arbitrary $ \i ->+ forAll (genSplit3 i) $ \(a, b, c) -> do+ a `shouldSatisfy` (>= 0)+ b `shouldSatisfy` (>= 0)+ c `shouldSatisfy` (>= 0)+ it "returns three integers such that the sum is the original integer" $+ forAll arbitrary $ \i ->+ forAll (genSplit3 i) $ \(a, b, c) ->+ a + b + c `shouldBe` max 0 i+ describe "genSplit4" $ do+ it "returns positive integers" $+ forAll arbitrary $ \i ->+ forAll (genSplit4 i) $ \(a, b, c, d) -> do+ a `shouldSatisfy` (>= 0)+ b `shouldSatisfy` (>= 0)+ c `shouldSatisfy` (>= 0)+ d `shouldSatisfy` (>= 0)+ it "returns four integers such that the sum is the original integer" $+ forAll arbitrary $ \i ->+ forAll (genSplit4 i) $ \(a, b, c, d) ->+ a + b + c + d `shouldBe` max 0 i+ describe "genSplit5" $ do+ it "returns positive integers" $+ forAll arbitrary $ \i ->+ forAll (genSplit5 i) $ \(a, b, c, d, e) -> do+ a `shouldSatisfy` (>= 0)+ b `shouldSatisfy` (>= 0)+ c `shouldSatisfy` (>= 0)+ d `shouldSatisfy` (>= 0)+ e `shouldSatisfy` (>= 0)+ it "returns four integers such that the sum is the original integer" $+ forAll arbitrary $ \i ->+ forAll (genSplit5 i) $ \(a, b, c, d, e) ->+ a + b + c + d + e `shouldBe` max 0 i+ describe "arbPartition" $ do+ it "returns an empty list upon strictly negative input" $+ forAll (arbitrary `suchThat` (< 0)) $ \n ->+ forAll (arbPartition n) (`shouldBe` [])+ it "returns a list of positive integers" $+ forAll arbitrary $ \n ->+ forAll (arbPartition n) $ \p -> p `shouldSatisfy` all (>= 0)
+ test/Data/InstanceSpec.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE NegativeLiterals #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.InstanceSpec+ ( spec,+ )+where++import Control.Monad+import Data.Data+import Data.Fixed+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+ 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 "shrinkValid Float" $ do+ let sf :: Float -> Spec+ 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 "shrinkValid Double" $ do+ let sd :: Double -> Spec+ sd d = it (unwords ["Does not shrink", show d, "to itself"]) $ d `shouldNotSatisfy` (`elem` shrinkValid d)+ sd (-1.032730679986007e18)+ genValidTest (Proxy :: Proxy Double)+ tupleTest (Proxy :: Proxy Double)+ genValidTest (Proxy :: Proxy (Ratio Int))+ modifyMaxSuccess (`quot` 2) $+ 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))+ genValidTest (Proxy :: Proxy (Ratio Int))+ -- threeTupleTests (Proxy :: Proxy (Ratio Int))+ genValidTest (Proxy :: Proxy (Ratio Int8))+ describe "shrinking (Ratio Int)" $+ it "can shrink this example" $+ let v = ((-9223372036854775808) % 9223372036854775761) :: Ratio Int+ in v `notElem` shrinkValid v+ describe "shrinking (Ratio Int8)" $+ it "can shrink this example" $+ let v = ((-128) % 113) :: Ratio Int8+ in v `notElem` shrinkValid v+ 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))++tupleTest ::+ forall a.+ (Show a, Eq a, Typeable a, GenValid a) =>+ Proxy a ->+ Spec+tupleTest proxy = do+ modifyMaxSuccess (`quot` 2) $ modifyMaxSize (`quot` 2) $ genValidTest $ (,) <$> proxy <*> proxy++genValidTest ::+ forall a.+ (Show a, Eq a, Typeable a, GenValid a) =>+ Proxy a ->+ Spec+genValidTest proxy = do+ it (unwords ["genValid of", nameOf proxy, "generates only valid values"]) $+ forAll genValid $ \a ->+ case prettyValidate (a :: a) of+ Right v -> seq v $ pure ()+ Left err ->+ expectationFailure $+ unlines ["'validate' reported this value to be invalid:", show a, err, ""]+ modifyMaxSuccess (`quot` 5) $+ it (unwords ["shrinkValid of", nameOf proxy, "shrinks to only valid values"]) $+ forAll genValid $ \a ->+ forM_ (shrinkValid a) $ \v ->+ case prettyValidate (v :: a) of+ Right v_ -> seq v_ $ pure ()+ Left err ->+ expectationFailure $+ unlines ["'validate' reported this value to be invalid:", show v, err, ""]+ 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 ()+ 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"]++nameOf ::+ forall a.+ (Typeable a) =>+ Proxy a ->+ String+nameOf = show . typeRep