diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/genvalidity.cabal b/genvalidity.cabal --- a/genvalidity.cabal +++ b/genvalidity.cabal @@ -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: - . - * - . - * +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: + . + * + . + * + . + * + . + * + . + * + . + * + . + * + . + * + . + * + . + * +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 diff --git a/src/Data/GenRelativeValidity.hs b/src/Data/GenRelativeValidity.hs deleted file mode 100644 --- a/src/Data/GenRelativeValidity.hs +++ /dev/null @@ -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)) diff --git a/src/Data/GenValidity.hs b/src/Data/GenValidity.hs --- a/src/Data/GenValidity.hs +++ b/src/Data/GenValidity.hs @@ -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 _) = [] diff --git a/src/Data/GenValidity/Utils.hs b/src/Data/GenValidity/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/GenValidity/Utils.hs @@ -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 diff --git a/test/Data/GenValidity/GenericSpec.hs b/test/Data/GenValidity/GenericSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/GenValidity/GenericSpec.hs @@ -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 diff --git a/test/Data/GenValidity/ShrinkGenericSpec.hs b/test/Data/GenValidity/ShrinkGenericSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/GenValidity/ShrinkGenericSpec.hs @@ -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] diff --git a/test/Data/GenValiditySpec.hs b/test/Data/GenValiditySpec.hs --- a/test/Data/GenValiditySpec.hs +++ b/test/Data/GenValiditySpec.hs @@ -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) diff --git a/test/Data/InstanceSpec.hs b/test/Data/InstanceSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/InstanceSpec.hs @@ -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