genvalidity 0.11.0.0 → 0.11.0.2
raw patch · 8 files changed
+982/−882 lines, 8 filesdep ~QuickCheckdep ~base
Dependency ranges changed: QuickCheck, base
Files
- genvalidity.cabal +6/−9
- src/Data/GenRelativeValidity.hs +22/−16
- src/Data/GenValidity.hs +532/−466
- src/Data/GenValidity/Utils.hs +137/−136
- test/Data/GenValidity/GenericSpec.hs +53/−55
- test/Data/GenValidity/ShrinkGenericSpec.hs +44/−45
- test/Data/GenValiditySpec.hs +74/−66
- test/Data/InstanceSpec.hs +114/−89
genvalidity.cabal view
@@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack------ hash: a5dc5e1588ff412e964237d33283651af0936a55506c5f8e6919d2ab901c77ec name: genvalidity-version: 0.11.0.0+version: 0.11.0.2 synopsis: Testing utilities for the validity library description: Note: There are companion instance packages for this library: .@@ -53,13 +51,12 @@ Paths_genvalidity hs-source-dirs: src+ ghc-options: -Wno-redundant-constraints build-depends:- QuickCheck >=2.7- , base >=4.10 && <5+ QuickCheck >=2.12+ , base >=4.11 && <5 , random , validity >=0.9- if impl(ghc >=8.0.0)- ghc-options: -Wno-redundant-constraints default-language: Haskell2010 test-suite genvalidity-test@@ -76,7 +73,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall build-depends: QuickCheck- , base >=4.10 && <5+ , base >=4.11 && <5 , genvalidity , hspec , hspec-core
src/Data/GenRelativeValidity.hs view
@@ -1,26 +1,32 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Data.GenRelativeValidity- ( module Data.RelativeValidity- , module Data.GenRelativeValidity- ) where+ ( module Data.RelativeValidity,+ module Data.GenRelativeValidity,+ )+where import Data.GenValidity import Data.RelativeValidity- import Test.QuickCheck -class (GenUnchecked a, RelativeValidity a b) =>- GenRelativeUnchecked a b where- genUncheckedFor :: b -> Gen a- genUncheckedFor _ = genUnchecked+class+ (GenUnchecked a, RelativeValidity a b) =>+ GenRelativeUnchecked a b+ where+ genUncheckedFor :: b -> Gen a+ genUncheckedFor _ = genUnchecked -class (GenValid a, RelativeValidity a b) =>- GenRelativeValid a b where- genValidFor :: b -> Gen a- genValidFor b = genValid `suchThat` (`isValidFor` b)+class+ (GenValid a, RelativeValidity a b) =>+ GenRelativeValid a b+ where+ genValidFor :: b -> Gen a+ genValidFor b = genValid `suchThat` (`isValidFor` b) -class (GenUnchecked a, RelativeValidity a b, GenRelativeUnchecked a b) =>- GenRelativeInvalid a b where- genInvalidFor :: b -> Gen a- genInvalidFor b = genUncheckedFor b `suchThat` (not . (`isValidFor` b))+class+ (GenUnchecked a, RelativeValidity a b, GenRelativeUnchecked a b) =>+ GenRelativeInvalid a b+ where+ genInvalidFor :: b -> Gen a+ genInvalidFor b = genUncheckedFor b `suchThat` (not . (`isValidFor` b))
src/Data/GenValidity.hs view
@@ -1,58 +1,11 @@-{-|-- @GenValidity@ exists to make tests involving @Validity@ types easier and speed- up the generation of data for them.-- Let's use the example from @Data.Validity@ again: A datatype that represents- primes.- To implement tests for this datatype, we would have to be able to generate- both primes and non-primes. We could do this with- @(Prime <$> arbitrary) `suchThat` isValid@- but this is tedious and inefficient.-- The @GenValid@ type class allows you to specify how to (efficiently)- generate valid data of the given type to allow for easier and quicker testing.- Just instantiating @GenUnchecked@ already gives you access to a default instance- of @GenValid@ and @GenInvalid@ but writing custom implementations of these functions- may speed up the generation of data.-- For example, to generate primes, we don't have to consider even numbers other- than 2. A more efficient implementation could then look as follows:-- > instance GenUnchecked Prime where- > genUnchecked = Prime <$> arbitrary-- > instance GenValid Prime where- > genValid = Prime <$>- > (oneof- > [ 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- > forAllUnchecked $ \input ->- > case myFunction input of- > Nothing -> return () -- Can happen- > Just output -> output `shouldSatisfy` isValid-- Definitely also look at the genvalidity-property and genvalidity-hspec packages- for more info on how to use this package.- -}+{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE CPP #-}+ #if __GLASGOW_HASKELL__ >= 710 #define OVERLAPPING_ {-# OVERLAPPING #-} #else@@ -63,43 +16,94 @@ {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} #endif +-- |+--+-- @GenValidity@ exists to make tests involving @Validity@ types easier and speed+-- up the generation of data for them.+--+-- 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.+--+-- The @GenValid@ type class allows you to specify how to (efficiently)+-- generate valid data of the given type to allow for easier and quicker testing.+-- Just instantiating @GenUnchecked@ already gives you access to a default instance+-- of @GenValid@ and @GenInvalid@ but writing custom implementations of these functions+-- may speed up the generation of data.+--+-- For example, to generate primes, we don't have to consider even numbers other+-- than 2. A more efficient implementation could then look as follows:+--+-- > instance GenUnchecked Prime where+-- > genUnchecked = Prime <$> arbitrary+--+-- > instance GenValid Prime where+-- > genValid = Prime <$>+-- > (oneof+-- > [ 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+-- > forAllUnchecked $ \input ->+-- > case myFunction input of+-- > Nothing -> return () -- Can happen+-- > Just output -> output `shouldSatisfy` isValid+--+-- Definitely also look at the genvalidity-property and genvalidity-hspec packages+-- for more info on how to use this package. module Data.GenValidity- ( GenUnchecked(..)- , GenValid(..)- , GenInvalid(..)+ ( GenUnchecked (..),+ GenValid (..),+ GenInvalid (..), -- * Helper functions- , genValidStructurally- , genValidStructurallyWithoutExtraChecking- , shrinkValidStructurally- , shrinkValidStructurallyWithoutExtraFiltering- , module Data.GenValidity.Utils+ genValidStructurally,+ genValidStructurallyWithoutExtraChecking,+ shrinkValidStructurally,+ shrinkValidStructurallyWithoutExtraFiltering,+ module Data.GenValidity.Utils, - -- * Strange, possibly useful functions- , genUtf16SurrogateCodePoint+ -- ** Helper functions for specific types + -- *** Char+ genUtf16SurrogateCodePoint,+ genLineSeparator,+ genNonLineSeparator,++ -- *** String+ genSingleLineString,+ -- * Re-exports- , module Data.Validity+ module Data.Validity, -- * The Generics magic- , genericGenUnchecked- , GGenUnchecked(..)- , genericShrinkUnchecked- , uncheckedRecursivelyShrink- , GUncheckedRecursivelyShrink(..)- , uncheckedSubterms- , GUncheckedSubterms(..)- , GUncheckedSubtermsIncl(..)- , GGenValid(..)- , GValidRecursivelyShrink(..)- , structurallyValidSubterms- , GValidSubterms(..)- , GValidSubtermsIncl(..)- ) where--import Data.Validity+ genericGenUnchecked,+ GGenUnchecked (..),+ genericShrinkUnchecked,+ uncheckedRecursivelyShrink,+ GUncheckedRecursivelyShrink (..),+ uncheckedSubterms,+ GUncheckedSubterms (..),+ GUncheckedSubtermsIncl (..),+ GGenValid (..),+ GValidRecursivelyShrink (..),+ structurallyValidSubterms,+ GValidSubterms (..),+ GValidSubtermsIncl (..),+ )+where -import Data.Fixed (Fixed(..), HasResolution) #if MIN_VERSION_base(4,9,0) import Data.List.NonEmpty (NonEmpty((:|))) #endif@@ -110,16 +114,10 @@ import Data.Word (Word, Word64) import GHC.Word (Word8(..), Word16(..), Word32(..), Word(..)) #endif-import Data.Int (Int64)-import GHC.Int (Int8(..), Int16(..), Int32(..), Int(..))-import Data.Char (chr)-import Data.Ratio ((%))-import GHC.Generics-import GHC.Real (Ratio(..))-import Control.Monad (guard) -import Test.QuickCheck hiding (Fixed)-+import Control.Monad (guard)+import Data.Char (chr)+import Data.Fixed (Fixed (..), HasResolution) #if MIN_VERSION_base(4,8,0) import GHC.Natural #else@@ -127,6 +125,13 @@ #endif import Data.GenValidity.Utils+import Data.Int (Int64)+import Data.Ratio ((%))+import Data.Validity+import GHC.Generics+import GHC.Int (Int (..), Int16 (..), Int32 (..), Int8 (..))+import GHC.Real (Ratio (..))+import Test.QuickCheck hiding (Fixed) {-# ANN module "HLint: ignore Reduce duplication" #-} @@ -173,16 +178,18 @@ -- In that case, do not override 'genUnchecked' at all. -- Instead, use 'genValid' from 'GenValid' (see below) instead and consider not instantiating 'GenUnchecked' at all. class GenUnchecked a where- genUnchecked :: Gen a- default genUnchecked :: (Generic a, GGenUnchecked (Rep a)) =>- Gen a- genUnchecked = genericGenUnchecked+ genUnchecked :: Gen a+ default genUnchecked ::+ (Generic a, GGenUnchecked (Rep a)) =>+ Gen a+ genUnchecked = genericGenUnchecked - shrinkUnchecked :: a -> [a]- default shrinkUnchecked ::- (Generic a, GUncheckedRecursivelyShrink (Rep a), GUncheckedSubterms (Rep a) a) =>- a -> [a]- shrinkUnchecked = genericShrinkUnchecked+ shrinkUnchecked :: a -> [a]+ default shrinkUnchecked ::+ (Generic a, GUncheckedRecursivelyShrink (Rep a), GUncheckedSubterms (Rep a) a) =>+ a ->+ [a]+ shrinkUnchecked = genericShrinkUnchecked -- | A class of types for which valid values can be generated. --@@ -213,33 +220,33 @@ -- > arbitrary = genValid -- > shrink = shrinkValid class Validity a => GenValid a where- -- | Generate a valid datum, this should cover all possible valid values in- -- the type- --- -- The default implementation is as follows:- --- -- > genValid = genUnchecked `suchThat` isValid- --- -- To speed up testing, it may be a good idea to implement this yourself.- -- If you do, make sure that it is possible to generate all possible valid- -- data, otherwise your testing may not cover all cases.- genValid :: Gen a- default genValid :: GenUnchecked a => Gen a- genValid = genUnchecked `suchThat` isValid+ -- | 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+ default genValid :: GenUnchecked a => Gen a+ genValid = genUnchecked `suchThat` isValid - -- | Shrink a valid value.- --- -- The default implementation is as follows:- --- -- > shrinkValid = filter isValid . shrinkUnchecked- --- -- It is important that this shrinking function only shrinks values to valid values.- -- If `shrinkValid` ever shrinks a value to an invalid value, the test that is being shrunk for- -- might fail for a different reason than for the reason that it originally failed.- -- This would lead to very confusing error messages.- shrinkValid :: a -> [a]- default shrinkValid :: GenUnchecked a => a -> [a]- shrinkValid = filter isValid . shrinkUnchecked+ -- | Shrink a valid value.+ --+ -- The default implementation is as follows:+ --+ -- > shrinkValid = filter isValid . shrinkUnchecked+ --+ -- It is important that this shrinking function only shrinks values to valid values.+ -- If `shrinkValid` ever shrinks a value to an invalid value, the test that is being shrunk for+ -- might fail for a different reason than for the reason that it originally failed.+ -- This would lead to very confusing error messages.+ shrinkValid :: a -> [a]+ default shrinkValid :: GenUnchecked a => a -> [a]+ shrinkValid = filter isValid . shrinkUnchecked -- | A class of types for which invalid values can be generated. --@@ -255,267 +262,319 @@ -- -- __Step 2__: Instantiate 'GenInvalid' without overriding any functions. class Validity a => GenInvalid a where- genInvalid :: Gen a- -- | Generate an invalid datum, this should cover all possible invalid- -- values- --- -- > genInvalid = genUnchecked `suchThat` isInvalid- --- -- To speed up testing, it may be a good idea to implement this yourself.- -- If you do, make sure that it is possible to generate all possible- -- invalid data, otherwise your testing may not cover all cases.- default genInvalid :: GenUnchecked a => Gen a- genInvalid = genUnchecked `suchThat` isInvalid+ genInvalid :: Gen a - shrinkInvalid :: a -> [a]- default shrinkInvalid :: GenUnchecked a => a -> [a]- shrinkInvalid = filter isInvalid . shrinkUnchecked+ -- | Generate an invalid datum, this should cover all possible invalid+ -- values+ --+ -- > genInvalid = genUnchecked `suchThat` isInvalid+ --+ -- To speed up testing, it may be a good idea to implement this yourself.+ -- If you do, make sure that it is possible to generate all possible+ -- invalid data, otherwise your testing may not cover all cases.+ default genInvalid :: GenUnchecked a => Gen a+ genInvalid = genUnchecked `suchThat` isInvalid + shrinkInvalid :: a -> [a]+ default shrinkInvalid :: GenUnchecked a => a -> [a]+ shrinkInvalid = filter isInvalid . shrinkUnchecked+ instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (a, b) where- genUnchecked =- sized $ \n -> do- (r, s) <- genSplit n- a <- resize r genUnchecked- b <- resize s genUnchecked- return (a, b)- shrinkUnchecked (a, b) = ((,) <$> shrinkUnchecked a <*> shrinkUnchecked b)- ++ [ (a', b) | a' <- shrinkUnchecked a ]- ++ [ (a, b') | b' <- shrinkUnchecked b ]+ genUnchecked =+ sized $ \n -> do+ (r, s) <- genSplit n+ a <- resize r genUnchecked+ b <- resize s genUnchecked+ return (a, b)+ shrinkUnchecked (a, b) =+ ((,) <$> shrinkUnchecked a <*> shrinkUnchecked b)+ ++ [(a', b) | a' <- shrinkUnchecked a]+ ++ [(a, b') | b' <- shrinkUnchecked b] 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+ genValid =+ sized $ \n -> do+ (r, s) <- genSplit n+ a <- resize r genValid+ b <- resize s genValid+ return (a, b)+ shrinkValid = shrinkTuple shrinkValid shrinkValid instance (GenUnchecked a, GenInvalid a, GenUnchecked b, GenInvalid b) => GenInvalid (a, b) where- genInvalid =- sized $ \n -> do- (r, s) <- genSplit n- oneof- [ do a <- resize r genUnchecked- b <- resize s genInvalid- return (a, b)- , do a <- resize r genInvalid- b <- resize s genUnchecked- return (a, b)- ]+ genInvalid =+ sized $ \n -> do+ (r, s) <- genSplit n+ oneof+ [ do+ a <- resize r genUnchecked+ b <- resize s genInvalid+ return (a, b),+ do+ a <- resize r genInvalid+ b <- resize s genUnchecked+ return (a, b)+ ] instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (Either a b) where- genUnchecked = oneof [Left <$> genUnchecked, Right <$> genUnchecked]- shrinkUnchecked (Left a) = Left <$> shrinkUnchecked a- shrinkUnchecked (Right b) = Right <$> shrinkUnchecked b+ genUnchecked = oneof [Left <$> genUnchecked, Right <$> genUnchecked]+ shrinkUnchecked (Left a) = Left <$> shrinkUnchecked a+ shrinkUnchecked (Right b) = Right <$> shrinkUnchecked b instance (GenValid a, GenValid b) => GenValid (Either a b) where- genValid = oneof [Left <$> genValid, Right <$> genValid]- shrinkValid (Left a) = Left <$> shrinkValid a- shrinkValid (Right b) = Right <$> shrinkValid b+ genValid = oneof [Left <$> genValid, Right <$> genValid]+ shrinkValid (Left a) = Left <$> shrinkValid a+ shrinkValid (Right b) = Right <$> shrinkValid b -- | This instance ensures that the generated tupse contains at least one invalid element. The other element is unchecked. instance (GenInvalid a, GenInvalid b) => GenInvalid (Either a b) where- genInvalid = oneof [Left <$> genInvalid, Right <$> genInvalid]- shrinkInvalid (Left v) = Left <$> shrinkInvalid v- shrinkInvalid (Right v) = Right <$> shrinkInvalid v+ genInvalid = oneof [Left <$> genInvalid, Right <$> genInvalid]+ shrinkInvalid (Left v) = Left <$> shrinkInvalid v+ shrinkInvalid (Right v) = Right <$> shrinkInvalid v -instance (GenUnchecked a, GenUnchecked b, GenUnchecked c) =>- GenUnchecked (a, b, c) where- genUnchecked =- sized $ \n -> do- (r, s, t) <- genSplit3 n- a <- resize r genUnchecked+instance+ (GenUnchecked a, GenUnchecked b, GenUnchecked c) =>+ GenUnchecked (a, b, c)+ where+ genUnchecked =+ sized $ \n -> do+ (r, s, t) <- genSplit3 n+ a <- resize r genUnchecked+ b <- resize s genUnchecked+ c <- resize t genUnchecked+ return (a, b, c)+ shrinkUnchecked (a, b, c) =+ [ (a', b', c')+ | (a', (b', c')) <- shrinkUnchecked (a, (b, c))+ ]++instance (GenValid a, GenValid b, GenValid c) => GenValid (a, b, c) where+ genValid =+ sized $ \n -> do+ (r, s, t) <- genSplit3 n+ a <- resize r genValid+ b <- resize s genValid+ c <- resize t genValid+ return (a, b, c)+ shrinkValid (a, b, c) =+ [ (a', b', c')+ | (a', (b', c')) <- shrinkValid (a, (b, c))+ ]++-- | This instance ensures that the generated triple contains at least one invalid element. The other two are unchecked.+instance+ ( GenUnchecked a,+ GenUnchecked b,+ GenUnchecked c,+ GenInvalid a,+ GenInvalid b,+ GenInvalid c+ ) =>+ GenInvalid (a, b, c)+ where+ genInvalid =+ sized $ \n -> do+ (r, s, t) <- genSplit3 n+ oneof+ [ do+ a <- resize r genInvalid b <- resize s genUnchecked c <- resize t genUnchecked+ return (a, b, c),+ do+ a <- resize r genUnchecked+ b <- resize s genInvalid+ c <- resize t genUnchecked+ return (a, b, c),+ do+ a <- resize r genUnchecked+ b <- resize s genUnchecked+ c <- resize t genInvalid return (a, b, c)- shrinkUnchecked (a, b, c) =- [ (a', b', c')- | (a', (b', c')) <- shrinkUnchecked (a, (b, c)) ] -instance (GenValid a, GenValid b, GenValid c) => GenValid (a, b, c) where- genValid =- sized $ \n -> do- (r, s, t) <- genSplit3 n- a <- resize r genValid- b <- resize s genValid- c <- resize t genValid- return (a, b, c)- shrinkValid (a, b, c) =- [ (a', b', c')- | (a', (b', c')) <- shrinkValid (a, (b, c))- ]+instance+ (GenUnchecked a, GenUnchecked b, GenUnchecked c, GenUnchecked d) =>+ GenUnchecked (a, b, c, d)+ where+ genUnchecked =+ sized $ \n -> do+ (r, s, t, u) <- genSplit4 n+ a <- resize r genUnchecked+ b <- resize s genUnchecked+ c <- resize t genUnchecked+ d <- resize u genUnchecked+ return (a, b, c, d)+ shrinkUnchecked (a, b, c, d) =+ [ (a', b', c', d')+ | (a', (b', (c', d'))) <- shrinkUnchecked (a, (b, (c, d)))+ ] --- | This instance ensures that the generated triple contains at least one invalid element. The other two are unchecked.-instance ( GenUnchecked a, GenUnchecked b, GenUnchecked c- , GenInvalid a, GenInvalid b, GenInvalid c) =>- GenInvalid (a, b, c) where- genInvalid =- sized $ \n -> do- (r, s, t) <- genSplit3 n- oneof- [ do a <- resize r genInvalid- b <- resize s genUnchecked- c <- resize t genUnchecked- return (a, b, c)- , do a <- resize r genUnchecked- b <- resize s genInvalid- c <- resize t genUnchecked- return (a, b, c)- , do a <- resize r genUnchecked- b <- resize s genUnchecked- c <- resize t genInvalid- return (a, b, c)- ]+instance+ (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 (a, b, c, d) =+ [ (a', b', c', d')+ | (a', (b', (c', d'))) <- shrinkValid (a, (b, (c, d)))+ ] -instance (GenUnchecked a, GenUnchecked b, GenUnchecked c, GenUnchecked d) =>- GenUnchecked (a, b, c, d) where- genUnchecked =- sized $ \n -> do- (r, s, t, u) <- genSplit4 n- a <- resize r genUnchecked+-- | This instance ensures that the generated triple contains at least one invalid element. The other two are unchecked.+instance+ ( GenUnchecked a,+ GenUnchecked b,+ GenUnchecked c,+ GenUnchecked d,+ GenInvalid a,+ GenInvalid b,+ GenInvalid c,+ GenInvalid d+ ) =>+ GenInvalid (a, b, c, d)+ where+ genInvalid =+ sized $ \n -> do+ (r, s, t, u) <- genSplit4 n+ oneof+ [ do+ a <- resize r genInvalid b <- resize s genUnchecked c <- resize t genUnchecked d <- resize u genUnchecked+ return (a, b, c, d),+ do+ a <- resize r genUnchecked+ b <- resize s genInvalid+ c <- resize t genUnchecked+ d <- resize u genUnchecked+ return (a, b, c, d),+ do+ a <- resize r genUnchecked+ b <- resize s genUnchecked+ c <- resize t genInvalid+ d <- resize u genUnchecked+ return (a, b, c, d),+ do+ a <- resize r genUnchecked+ b <- resize s genUnchecked+ c <- resize t genUnchecked+ d <- resize u genInvalid return (a, b, c, d)- shrinkUnchecked (a, b, c, d) =- [ (a', b', c', d')- | (a', (b', (c', d'))) <- shrinkUnchecked (a, (b, (c, d))) ] -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 (a, b, c, d) =- [ (a', b', c', d')- | (a', (b', (c', d'))) <- shrinkValid (a, (b, (c, d)))- ]+instance+ (GenUnchecked a, GenUnchecked b, GenUnchecked c, GenUnchecked d, GenUnchecked e) =>+ GenUnchecked (a, b, c, d, e)+ where+ genUnchecked =+ sized $ \n -> do+ (r, s, t, u, v) <- genSplit5 n+ a <- resize r genUnchecked+ b <- resize s genUnchecked+ c <- resize t genUnchecked+ d <- resize u genUnchecked+ e <- resize v genUnchecked+ return (a, b, c, d, e)+ shrinkUnchecked (a, b, c, d, e) =+ [ (a', b', c', d', e')+ | (a', (b', (c', (d', e')))) <- shrinkUnchecked (a, (b, (c, (d, e))))+ ] --- | This instance ensures that the generated triple contains at least one invalid element. The other two are unchecked.-instance ( GenUnchecked a, GenUnchecked b, GenUnchecked c, GenUnchecked d- , GenInvalid a, GenInvalid b, GenInvalid c, GenInvalid d) =>- GenInvalid (a, b, c, d) where- genInvalid =- sized $ \n -> do- (r, s, t, u) <- genSplit4 n- oneof- [ do a <- resize r genInvalid- b <- resize s genUnchecked- c <- resize t genUnchecked- d <- resize u genUnchecked- return (a, b, c, d)- , do a <- resize r genUnchecked- b <- resize s genInvalid- c <- resize t genUnchecked- d <- resize u genUnchecked- return (a, b, c, d)- , do a <- resize r genUnchecked- b <- resize s genUnchecked- c <- resize t genInvalid- d <- resize u genUnchecked- return (a, b, c, d)- , do a <- resize r genUnchecked- b <- resize s genUnchecked- c <- resize t genUnchecked- d <- resize u genInvalid- return (a, b, c, d)- ]+instance+ (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 (GenUnchecked a, GenUnchecked b, GenUnchecked c, GenUnchecked d, GenUnchecked e) =>- GenUnchecked (a, b, c, d, e) where- genUnchecked =- sized $ \n -> do- (r, s, t, u, v) <- genSplit5 n- a <- resize r genUnchecked+-- | This instance ensures that the generated triple contains at least one invalid element. The other two are unchecked.+instance+ ( GenUnchecked a,+ GenUnchecked b,+ GenUnchecked c,+ GenUnchecked d,+ GenUnchecked e,+ GenInvalid a,+ GenInvalid b,+ GenInvalid c,+ GenInvalid d,+ GenInvalid e+ ) =>+ GenInvalid (a, b, c, d, e)+ where+ genInvalid =+ sized $ \n -> do+ (r, s, t, u, v) <- genSplit5 n+ oneof+ [ do+ a <- resize r genInvalid b <- resize s genUnchecked c <- resize t genUnchecked d <- resize u genUnchecked e <- resize v genUnchecked+ return (a, b, c, d, e),+ do+ a <- resize r genUnchecked+ b <- resize s genInvalid+ c <- resize t genUnchecked+ d <- resize u genUnchecked+ e <- resize v genUnchecked+ return (a, b, c, d, e),+ do+ a <- resize r genUnchecked+ b <- resize s genUnchecked+ c <- resize t genInvalid+ d <- resize u genUnchecked+ e <- resize v genUnchecked+ return (a, b, c, d, e),+ do+ a <- resize r genUnchecked+ b <- resize s genUnchecked+ c <- resize t genUnchecked+ d <- resize u genInvalid+ e <- resize v genUnchecked+ return (a, b, c, d, e),+ do+ a <- resize r genUnchecked+ b <- resize s genUnchecked+ c <- resize t genUnchecked+ d <- resize u genUnchecked+ e <- resize v genInvalid return (a, b, c, d, e)- shrinkUnchecked (a, b, c, d, e) =- [ (a', b', c', d', e')- | (a', (b', (c', (d', e')))) <- shrinkUnchecked (a, (b, (c, (d, e)))) ] -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))))- ]---- | This instance ensures that the generated triple contains at least one invalid element. The other two are unchecked.-instance ( GenUnchecked a, GenUnchecked b, GenUnchecked c, GenUnchecked d, GenUnchecked e- , GenInvalid a, GenInvalid b, GenInvalid c, GenInvalid d, GenInvalid e) =>- GenInvalid (a, b, c, d, e) where- genInvalid =- sized $ \n -> do- (r, s, t, u, v) <- genSplit5 n- oneof- [ do a <- resize r genInvalid- b <- resize s genUnchecked- c <- resize t genUnchecked- d <- resize u genUnchecked- e <- resize v genUnchecked- return (a, b, c, d, e)- , do a <- resize r genUnchecked- b <- resize s genInvalid- c <- resize t genUnchecked- d <- resize u genUnchecked- e <- resize v genUnchecked- return (a, b, c, d, e)- , do a <- resize r genUnchecked- b <- resize s genUnchecked- c <- resize t genInvalid- d <- resize u genUnchecked- e <- resize v genUnchecked- return (a, b, c, d, e)- , do a <- resize r genUnchecked- b <- resize s genUnchecked- c <- resize t genUnchecked- d <- resize u genInvalid- e <- resize v genUnchecked- return (a, b, c, d, e)- , do a <- resize r genUnchecked- b <- resize s genUnchecked- c <- resize t genUnchecked- d <- resize u genUnchecked- e <- resize v genInvalid- return (a, b, c, d, e)- ]- instance GenUnchecked a => GenUnchecked (Maybe a) where- genUnchecked = oneof [pure Nothing, Just <$> genUnchecked]- shrinkUnchecked Nothing = []- shrinkUnchecked (Just a) = Nothing : (Just <$> shrinkUnchecked a)-+ genUnchecked = oneof [pure Nothing, Just <$> genUnchecked]+ shrinkUnchecked Nothing = []+ shrinkUnchecked (Just a) = Nothing : (Just <$> shrinkUnchecked a) instance GenValid a => GenValid (Maybe a) where- genValid = oneof [pure Nothing, Just <$> genValid]- shrinkValid Nothing = []- shrinkValid (Just a) = Nothing : (Just <$> shrinkValid a)+ genValid = oneof [pure Nothing, Just <$> genValid]+ shrinkValid Nothing = []+ shrinkValid (Just a) = Nothing : (Just <$> shrinkValid a) instance GenInvalid a => GenInvalid (Maybe a) where- genInvalid = Just <$> genInvalid- shrinkInvalid Nothing = [] -- Should not happen- shrinkInvalid (Just a) = Just <$> shrinkInvalid a+ genInvalid = Just <$> genInvalid+ shrinkInvalid Nothing = [] -- Should not happen+ shrinkInvalid (Just a) = Just <$> shrinkInvalid a #if MIN_VERSION_base(4,9,0) instance GenUnchecked a => GenUnchecked (NonEmpty a) where@@ -531,174 +590,187 @@ #endif instance GenUnchecked a => GenUnchecked [a] where- genUnchecked = genListOf genUnchecked- shrinkUnchecked = shrinkList shrinkUnchecked+ genUnchecked = genListOf genUnchecked+ shrinkUnchecked = shrinkList shrinkUnchecked -- | If we can generate values of a certain type, we can also generate lists of -- them. instance GenValid a => GenValid [a] where- genValid = genListOf genValid- shrinkValid = shrinkList shrinkValid+ genValid = genListOf genValid+ shrinkValid = shrinkList shrinkValid -- | This instance ensures that the generated list contains at least one element -- that satisfies 'isInvalid'. The rest is unchecked. instance (GenUnchecked a, GenInvalid a) => GenInvalid [a] where- genInvalid =- sized $ \n -> do- (x, y, z) <- genSplit3 n- before <- resize x $ genListOf genUnchecked- middle <- resize y genInvalid- after <- resize z $ genListOf genUnchecked- return $ before ++ [middle] ++ after+ genInvalid =+ sized $ \n -> do+ (x, y, z) <- genSplit3 n+ before <- resize x $ genListOf genUnchecked+ middle <- resize y genInvalid+ after <- resize z $ genListOf genUnchecked+ return $ before ++ [middle] ++ after instance GenUnchecked () where- genUnchecked = arbitrary- shrinkUnchecked = shrink+ genUnchecked = arbitrary+ shrinkUnchecked = shrink instance GenValid () where- genValid = genUnchecked- shrinkValid = shrinkUnchecked+ genValid = genUnchecked+ shrinkValid = shrinkUnchecked instance GenUnchecked Bool where- genUnchecked = arbitrary- shrinkUnchecked = shrink+ genUnchecked = arbitrary+ shrinkUnchecked = shrink instance GenValid Bool where- genValid = genUnchecked- shrinkValid = shrinkUnchecked+ genValid = genUnchecked+ shrinkValid = shrinkUnchecked instance GenUnchecked Ordering where- genUnchecked = arbitrary- shrinkUnchecked = shrink+ genUnchecked = arbitrary+ shrinkUnchecked = shrink instance GenValid Ordering where- genValid = genUnchecked- shrinkValid = shrinkUnchecked+ genValid = genUnchecked+ shrinkValid = shrinkUnchecked instance GenUnchecked Char where- genUnchecked = frequency [(9, choose (minBound, maxBound)), (1, genUtf16SurrogateCodePoint)]- shrinkUnchecked = shrink+ genUnchecked = frequency [(9, choose (minBound, maxBound)), (1, genUtf16SurrogateCodePoint)]+ shrinkUnchecked = shrink genUtf16SurrogateCodePoint :: Gen Char genUtf16SurrogateCodePoint = chr <$> oneof [choose (0xD800, 0xDBFF), choose (0xDC00, 0xDFFF)] instance GenValid Char where- genValid = genUnchecked- shrinkValid = shrinkUnchecked+ genValid = genUnchecked+ shrinkValid = shrinkUnchecked +genLineSeparator :: Gen Char+genLineSeparator = elements ['\n', '\r']++genNonLineSeparator :: Gen Char+genNonLineSeparator = genValid `suchThat` (not . isLineSeparator)++genSingleLineString :: Gen String+genSingleLineString = genListOf genNonLineSeparator+ instance GenUnchecked Int where- genUnchecked = genIntX- shrinkUnchecked = shrink+ genUnchecked = genIntX+ shrinkUnchecked = shrink instance GenValid Int where- genValid = genUnchecked- shrinkValid = shrinkUnchecked+ genValid = genUnchecked+ shrinkValid = shrinkUnchecked instance GenUnchecked Int8 where- genUnchecked = genUncheckedInt (I8#)- shrinkUnchecked = shrinkUncheckedInt (\(I# i#) -> I8# i#) (\(I8# i#) -> I# i#)+ genUnchecked = genUncheckedInt (I8#)+ shrinkUnchecked = shrinkUncheckedInt (\(I# i#) -> I8# i#) (\(I8# i#) -> I# i#) instance GenValid Int8 where- genValid = genIntX- shrinkValid = shrink+ genValid = genIntX+ shrinkValid = shrink instance GenUnchecked Int16 where- genUnchecked = genUncheckedInt (I16#)- shrinkUnchecked = shrinkUncheckedInt (\(I# i#) -> I16# i#) (\(I16# i#) -> I# i#)+ genUnchecked = genUncheckedInt (I16#)+ shrinkUnchecked = shrinkUncheckedInt (\(I# i#) -> I16# i#) (\(I16# i#) -> I# i#) instance GenValid Int16 where- genValid = genIntX- shrinkValid = shrink+ genValid = genIntX+ shrinkValid = shrink instance GenUnchecked Int32 where- genUnchecked = genUncheckedInt (I32#)- shrinkUnchecked = shrinkUncheckedInt (\(I# i#) -> I32# i#) (\(I32# i#) -> I# i#)+ genUnchecked = genUncheckedInt (I32#)+ shrinkUnchecked = shrinkUncheckedInt (\(I# i#) -> I32# i#) (\(I32# i#) -> I# i#) instance GenValid Int32 where- genValid = genIntX- shrinkValid = shrink+ genValid = genIntX+ shrinkValid = shrink instance GenUnchecked Int64 where- genUnchecked = genIntX- shrinkUnchecked = shrink+ genUnchecked = genIntX+ shrinkUnchecked = shrink instance GenValid Int64 where- genValid = genUnchecked- shrinkValid = shrinkUnchecked+ genValid = genUnchecked+ shrinkValid = shrinkUnchecked instance GenUnchecked Word where- genUnchecked = genWordX- shrinkUnchecked = shrink+ genUnchecked = genWordX+ shrinkUnchecked = shrink instance GenValid Word where- genValid = genUnchecked- shrinkValid = shrinkUnchecked+ genValid = genUnchecked+ shrinkValid = shrinkUnchecked instance GenUnchecked Word8 where- genUnchecked = genUncheckedWord (W8#)- shrinkUnchecked = shrinkUncheckedWord (\(W# w#) -> W8# w#) (\(W8# w#) -> W# w#)+ genUnchecked = genUncheckedWord (W8#)+ shrinkUnchecked = shrinkUncheckedWord (\(W# w#) -> W8# w#) (\(W8# w#) -> W# w#) instance GenValid Word8 where- genValid = genWordX- shrinkValid = shrink+ genValid = genWordX+ shrinkValid = shrink instance GenUnchecked Word16 where- genUnchecked = genUncheckedWord (W16#)- shrinkUnchecked = shrinkUncheckedWord (\(W# w#) -> W16# w#) (\(W16# w#) -> W# w#)+ genUnchecked = genUncheckedWord (W16#)+ shrinkUnchecked = shrinkUncheckedWord (\(W# w#) -> W16# w#) (\(W16# w#) -> W# w#) instance GenValid Word16 where- genValid = genWordX- shrinkValid = shrink+ genValid = genWordX+ shrinkValid = shrink instance GenUnchecked Word32 where- genUnchecked = genUncheckedWord (W32#)- shrinkUnchecked = shrinkUncheckedWord (\(W# w#) -> W32# w#) (\(W32# w#) -> W# w#)+ genUnchecked = genUncheckedWord (W32#)+ shrinkUnchecked = shrinkUncheckedWord (\(W# w#) -> W32# w#) (\(W32# w#) -> W# w#) instance GenValid Word32 where- genValid = genWordX- shrinkValid = shrink+ genValid = genWordX+ shrinkValid = shrink instance GenUnchecked Word64 where- genUnchecked = genWordX- shrinkUnchecked = shrink+ genUnchecked = genWordX+ shrinkUnchecked = shrink instance GenValid Word64 where- genValid = genUnchecked- shrinkValid = shrinkUnchecked+ genValid = genUnchecked+ shrinkValid = shrinkUnchecked -instance GenUnchecked Float where- genUnchecked = genFloat #if MIN_VERSION_QuickCheck(2,9,2)- shrinkUnchecked f = if- | isInfinite f -> []- | isNaN f -> []- | otherwise -> shrink f+instance GenUnchecked Float where+ genUnchecked = genFloat+ shrinkUnchecked f+ | isInfinite f = []+ | isNaN f = []+ | otherwise = shrink f #else- shrinkUnchecked _ = []+instance GenUnchecked Float where+ genUnchecked = genFloat+ shrinkUnchecked _ = [] #endif instance GenValid Float where- genValid = genUnchecked- shrinkValid = shrinkUnchecked+ genValid = genUnchecked+ shrinkValid = shrinkUnchecked -instance GenUnchecked Double where- genUnchecked = genDouble #if MIN_VERSION_QuickCheck(2,9,2)- shrinkUnchecked d = if- | isInfinite d -> []- | isNaN d -> []- | otherwise -> shrink d+instance GenUnchecked Double where+ genUnchecked = genDouble+ shrinkUnchecked d+ | isInfinite d = []+ | isNaN d = []+ | otherwise = shrink d #else- shrinkUnchecked _ = []+instance GenUnchecked Double where+ genUnchecked = genDouble+ shrinkUnchecked _ = [] #endif instance GenValid Double where- genValid = genUnchecked- shrinkValid = shrinkUnchecked+ genValid = genUnchecked+ shrinkValid = shrinkUnchecked instance GenUnchecked Integer where- genUnchecked = genInteger- shrinkUnchecked = shrink+ genUnchecked = genInteger+ shrinkUnchecked = shrink instance GenValid Integer @@ -712,26 +784,29 @@ #endif instance (Integral a, GenUnchecked a) => GenUnchecked (Ratio a) where- genUnchecked = (:%) <$> genUnchecked <*> genUnchecked- shrinkUnchecked (n :% d) = [n' :% d' | (n', d') <- shrinkUnchecked (n, d)]+ genUnchecked = (:%) <$> genUnchecked <*> genUnchecked+ shrinkUnchecked (n :% d) = [n' :% d' | (n', d') <- shrinkUnchecked (n, d)] 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') <- shrinkValid (n, d)- guard $ d' > 0- let candidate = n' :% d'- guard $ isValid candidate- pure $ n' % d'+ genValid =+ ( do+ n <- genValid+ d <- (genValid `suchThat` (> 0))+ pure $ n :% d+ )+ `suchThat` isValid+ shrinkValid (n :% d) = do+ (n', d') <- shrinkValid (n, d)+ guard $ d' > 0+ let candidate = n' :% d'+ guard $ isValid candidate+ pure $ n' % d' instance (Integral a, Num a, Ord a, Validity a, GenUnchecked a) => GenInvalid (Ratio a) instance HasResolution a => GenUnchecked (Fixed a) where- genUnchecked = MkFixed <$> genUnchecked- shrinkUnchecked (MkFixed i) = MkFixed <$> shrinkUnchecked i+ genUnchecked = MkFixed <$> genUnchecked+ shrinkUnchecked (MkFixed i) = MkFixed <$> shrinkUnchecked i instance HasResolution a => GenValid (Fixed a) @@ -739,23 +814,22 @@ genericGenUnchecked = to <$> gGenUnchecked class GGenUnchecked f where- gGenUnchecked :: Gen (f a)+ gGenUnchecked :: Gen (f a) instance GGenUnchecked U1 where- gGenUnchecked = pure U1+ gGenUnchecked = pure U1 instance (GGenUnchecked a, GGenUnchecked b) => GGenUnchecked (a :*: b) where- gGenUnchecked = (:*:) <$> gGenUnchecked <*> gGenUnchecked+ gGenUnchecked = (:*:) <$> gGenUnchecked <*> gGenUnchecked instance (GGenUnchecked a, GGenUnchecked b) => GGenUnchecked (a :+: b) where- gGenUnchecked = oneof [L1 <$> gGenUnchecked, R1 <$> gGenUnchecked]+ gGenUnchecked = oneof [L1 <$> gGenUnchecked, R1 <$> gGenUnchecked] instance (GGenUnchecked a) => GGenUnchecked (M1 i c a) where- gGenUnchecked = M1 <$> gGenUnchecked+ gGenUnchecked = M1 <$> gGenUnchecked instance (GenUnchecked a) => GGenUnchecked (K1 i a) where- gGenUnchecked = K1 <$> genUnchecked-+ gGenUnchecked = K1 <$> genUnchecked -- | Shrink a term to any of its immediate subterms, -- and also recursively shrink all subterms.@@ -772,8 +846,8 @@ instance (GUncheckedRecursivelyShrink f, GUncheckedRecursivelyShrink g) => GUncheckedRecursivelyShrink (f :*: g) where gUncheckedRecursivelyShrink (x :*: y) = ((:*:) <$> gUncheckedRecursivelyShrink x <*> gUncheckedRecursivelyShrink y)- ++ [ x' :*: y | x' <- gUncheckedRecursivelyShrink x ]- ++ [ x :*: y' | y' <- gUncheckedRecursivelyShrink y ]+ ++ [x' :*: y | x' <- gUncheckedRecursivelyShrink x]+ ++ [x :*: y' | y' <- gUncheckedRecursivelyShrink y] instance (GUncheckedRecursivelyShrink f, GUncheckedRecursivelyShrink g) => GUncheckedRecursivelyShrink (f :+: g) where gUncheckedRecursivelyShrink (L1 x) = map L1 (gUncheckedRecursivelyShrink x)@@ -792,12 +866,10 @@ -- The empty type can't be shrunk to anything. gUncheckedRecursivelyShrink _ = [] - -- | All immediate uncheckedSubterms of a term. uncheckedSubterms :: (Generic a, GUncheckedSubterms (Rep a) a) => a -> [a] uncheckedSubterms = gUncheckedSubterms . from - class GUncheckedSubterms f a where gUncheckedSubterms :: f a -> [a] @@ -820,7 +892,6 @@ instance GUncheckedSubterms (K1 i a) b where gUncheckedSubterms (K1 _) = [] - class GUncheckedSubtermsIncl f a where gUncheckedSubtermsIncl :: f a -> [a] @@ -847,7 +918,6 @@ instance OVERLAPPING_ GUncheckedSubtermsIncl (K1 i a) b where gUncheckedSubtermsIncl (K1 _) = [] - -- | Generate a valid value by generating all the sub parts using the 'Generic' instance, -- and trying that until a valid value has been generated --@@ -870,23 +940,22 @@ genValidStructurallyWithoutExtraChecking = to <$> gGenValid class GGenValid f where- gGenValid :: Gen (f a)+ gGenValid :: Gen (f a) instance GGenValid U1 where- gGenValid = pure U1+ gGenValid = pure U1 instance (GGenValid a, GGenValid b) => GGenValid (a :*: b) where- gGenValid = (:*:) <$> gGenValid <*> gGenValid+ gGenValid = (:*:) <$> gGenValid <*> gGenValid instance (GGenValid a, GGenValid b) => GGenValid (a :+: b) where- gGenValid = oneof [L1 <$> gGenValid, R1 <$> gGenValid]+ gGenValid = oneof [L1 <$> gGenValid, R1 <$> gGenValid] instance (GGenValid a) => GGenValid (M1 i c a) where- gGenValid = M1 <$> gGenValid+ gGenValid = M1 <$> gGenValid instance (GenValid a) => GGenValid (K1 i a) where- gGenValid = K1 <$> genValid-+ gGenValid = K1 <$> genValid -- | 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.@@ -918,8 +987,8 @@ 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 ]+ ++ [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)@@ -938,12 +1007,10 @@ -- 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] @@ -965,7 +1032,6 @@ instance GValidSubterms (K1 i a) b where gValidSubterms (K1 _) = []- class GValidSubtermsIncl f a where gValidSubtermsIncl :: f a -> [a]
src/Data/GenValidity/Utils.hs view
@@ -1,12 +1,10 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}+ #if __GLASGOW_HASKELL__ >= 710 #define OVERLAPPING_ {-# OVERLAPPING #-} #else@@ -17,46 +15,49 @@ {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} #endif module Data.GenValidity.Utils- ( -- ** Helper functions for implementing generators- upTo- , genSplit- , genSplit3- , genSplit4- , genSplit5- , genSplit6- , genSplit7- , genSplit8- , arbPartition- , shuffle- , genListLength- , genListOf+ ( -- ** Helper functions for implementing generators+ upTo,+ genSplit,+ genSplit3,+ genSplit4,+ genSplit5,+ genSplit6,+ genSplit7,+ genSplit8,+ arbPartition,+ shuffle,+ genListLength,+ genListOf, #if MIN_VERSION_base(4,9,0)- , genNonEmptyOf+ genNonEmptyOf, #endif- -- ** Helper functions for implementing shrinking functions- , shrinkTuple- , shrinkT2- , shrinkT3- , shrinkT4- , genIntX- , genWordX- , genFloat- , genDouble- , genFloatX- , genInteger- , genUncheckedInt- , shrinkUncheckedInt- , genUncheckedWord- , shrinkUncheckedWord- ) where -import Test.QuickCheck hiding (Fixed)-import System.Random-import GHC.Float-import GHC.Int (Int(..))-import GHC.Word (Word(..))-import GHC.Exts (Word#, Int#)+ -- ** Helper functions for implementing shrinking functions+ shrinkTuple,+ shrinkT2,+ shrinkT3,+ shrinkT4,+ genIntX,+ genWordX,+ genFloat,+ genDouble,+ genFloatX,+ genInteger,+ genUncheckedInt,+ shrinkUncheckedInt,+ genUncheckedWord,+ shrinkUncheckedWord,+ )+where+ import Data.Ratio+import GHC.Exts (Int#, Word#)+import GHC.Float (castWord32ToFloat, castWord64ToDouble)+import GHC.Int (Int (..))+import GHC.Word (Word (..))+import System.Random+import Test.QuickCheck hiding (Fixed)+ #if !MIN_VERSION_QuickCheck(2,8,0) import Data.List (sortBy) import Data.Ord (comparing)@@ -72,87 +73,86 @@ import Control.Applicative ((<$>), (<*>), pure) import Control.Monad (forM, replicateM) #endif+ -- | 'upTo' generates an integer between 0 (inclusive) and 'n'. upTo :: Int -> Gen Int upTo n- | n <= 0 = pure 0- | otherwise = choose (0, 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)+ | 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)+ | 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)+ | 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)+ | 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)+ | 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)+ | 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)-+ | 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)@@ -163,7 +163,7 @@ -- Use an exponential distribution for generating the -- sizes in the partition. invE :: Double -> Double -> Double- invE lambda u = - log (1 - u) / lambda+ invE lambda u = (- log (1 - u)) / lambda #if !MIN_VERSION_QuickCheck(2,8,0) -- | Generates a random permutation of the given list.@@ -200,10 +200,9 @@ 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))-+ in if u < fc+ then a + sqrt (u * (b - a) * (c - a))+ else b - sqrt ((1 - u) * (b - a) * (b - c)) -- | A version of @listOf@ that takes size into account more accurately. --@@ -211,15 +210,15 @@ -- 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+ sized $ \n -> do+ pars <- arbPartition n+ forM pars $ \i -> resize i func 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 ]+ ++ [(a', b) | a' <- sa a]+ ++ [(a, b') | b' <- sb b] -- | Turn a shrinking function into a function that shrinks tuples. shrinkT2 :: (a -> [a]) -> (a, a) -> [(a, a)]@@ -241,16 +240,17 @@ genIntX :: forall a. (Integral a, Bounded a, Random a) => Gen a genIntX = frequency- [ (1, extreme)- , (1, small)- , (8, uniform)+ [ (1, extreme),+ (1, small),+ (8, uniform) ] where extreme :: Gen a- extreme = sized $ \s -> oneof- [ choose (maxBound - fromIntegral s, maxBound)- , choose (minBound, minBound + fromIntegral s)- ]+ 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) uniform :: Gen a@@ -264,9 +264,9 @@ genWordX :: forall a. (Integral a, Bounded a, Random a) => Gen a genWordX = frequency- [ (1, extreme)- , (1, small)- , (8, uniform)+ [ (1, extreme),+ (1, small),+ (8, uniform) ] where extreme :: Gen a@@ -295,27 +295,27 @@ -- * 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 ::+ 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, viaEncoding)- , (1, uniformViaEncoding)- , (5, reallyUniform)+ [ (1, denormalised),+ (1, small),+ (1, aroundBounds),+ (1, uniformViaEncoding),+ (6, reallyUniform) ] where denormalised :: Gen a denormalised = elements- [ read "NaN"- , read "Infinity"- , read "-Infinity"- , read "-0"+ [ read "NaN",+ read "Infinity",+ read "-Infinity",+ read "-0" ] -- This is what Quickcheck does, -- but inlined so QuickCheck cannot change@@ -325,26 +325,26 @@ let n' = toInteger n let precision = 9999999999999 :: Integer b <- choose (1, precision)- a <- choose ((-n') * b, n' * b)+ a <- choose ((- n') * b, n' * b) pure (fromRational (a % b)) upperSignificand :: Integer upperSignificand = floatRadix (0.0 :: a) ^ floatDigits (0.0 :: a) lowerSignificand :: Integer- lowerSignificand = - upperSignificand+ lowerSignificand = (- upperSignificand) (lowerExponent, upperExponent) = floatRange (0.0 :: a) aroundBounds :: Gen a aroundBounds = do- 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)- ]+ 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- viaEncoding :: Gen a- viaEncoding = encodeFloat <$> arbitrary <*> genIntX uniformViaEncoding :: Gen a uniformViaEncoding = do s <- choose (lowerSignificand, upperSignificand)@@ -355,15 +355,16 @@ reallyUniform = func <$> choose (minBound, maxBound) genInteger :: Gen Integer-genInteger = sized $ \s -> oneof $- (if s >= 10 then (genBiggerInteger :) else id)- [ genIntSizedInteger- , small- ]+genInteger = sized $ \s ->+ oneof $+ (if s >= 10 then (genBiggerInteger :) else id)+ [ genIntSizedInteger,+ small+ ] where- small = sized $ \s -> choose (- toInteger s, toInteger s)+ small = sized $ \s -> choose (- toInteger s, toInteger s) genIntSizedInteger = toInteger <$> (genIntX :: Gen Int)- genBiggerInteger = sized $ \s ->do+ genBiggerInteger = sized $ \s -> do (a, b, c) <- genSplit3 s ai <- resize a genIntSizedInteger bi <- resize b genInteger
test/Data/GenValidity/GenericSpec.hs view
@@ -1,23 +1,20 @@-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} module Data.GenValidity.GenericSpec- ( spec- ) where--import GHC.Generics (Generic, Rep)+ ( spec,+ )+where import Control.Monad--import Test.Hspec-import Test.QuickCheck-+import Data.GenValidity import Data.Proxy import Data.Typeable--import Data.GenValidity+import GHC.Generics (Generic, Rep)+import Test.Hspec+import Test.QuickCheck spec :: Spec spec = do@@ -35,38 +32,37 @@ shrinkValidstructurallySpec (Proxy :: Proxy MyType) genValidstructurallySpec ::- forall a.- (Validity a, Show a, Eq a, Typeable a, Generic a, GGenValid (Rep a))- => Proxy a- -> Spec+ 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- , ""- ]+ 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.- ( Validity a- , Show a- , Eq a- , Typeable a- , Generic a- , GenValid a- , GValidRecursivelyShrink (Rep a)- , GValidSubterms (Rep a) a- )- => Proxy a- -> Spec+ 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 ->@@ -75,29 +71,31 @@ 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"- ]+ 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 ->+ ( 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."]+ expectationFailure $ unlines [show a, "was shrunk to itself."] nameOf ::- forall a. Typeable a- => Proxy a- -> String+ forall a.+ Typeable a =>+ Proxy a ->+ String nameOf = show . typeRep -data MyType =- MyType Double Ordering+data MyType+ = MyType Double Ordering deriving (Show, Eq, Generic, Typeable) instance Validity MyType
test/Data/GenValidity/ShrinkGenericSpec.hs view
@@ -2,42 +2,41 @@ module Data.GenValidity.ShrinkGenericSpec where +import Data.GenValidity import GHC.Generics (Generic)- import Test.Hspec -import Data.GenValidity- spec :: Spec spec = do- describe "genericShrinkUnchecked" $ do- it "shrinks tuples correctly" $- genericShrinkUnchecked ((A2, B3)) `shouldBe`- [(A1, B1), (A1, B2), (A1, B3), (A2, B1), (A2, B2)]- it "figures out the right shrinking function for Ex" $- genericShrinkUnchecked (Ex A2 B3) `shouldBe`- [Ex A1 B1, Ex A1 B2, Ex A1 B3, Ex A2 B1, Ex A2 B2]- describe "default shrinkValid" $ do- it "figures out the right shrinking function for A" $- shrinkValid A2 `shouldBe` [A1]- 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]+ describe "genericShrinkUnchecked" $ do+ it "shrinks tuples correctly" $+ genericShrinkUnchecked ((A2, B3))+ `shouldBe` [(A1, B1), (A1, B2), (A1, B3), (A2, B1), (A2, B2)]+ it "figures out the right shrinking function for Ex" $+ genericShrinkUnchecked (Ex A2 B3)+ `shouldBe` [Ex A1 B1, Ex A1 B2, Ex A1 B3, Ex A2 B1, Ex A2 B2]+ describe "default shrinkValid" $ do+ it "figures out the right shrinking function for A" $+ shrinkValid A2 `shouldBe` [A1]+ 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)+data Ex+ = Ex+ A+ B+ deriving (Show, Eq, Generic) instance Validity Ex @@ -46,32 +45,32 @@ instance GenValid Ex data A- = A1- | A2- deriving (Show, Eq, Generic)+ = A1+ | A2+ deriving (Show, Eq, Generic) instance Validity A instance GenUnchecked A where- shrinkUnchecked A1 = []- shrinkUnchecked A2 = [A1]+ shrinkUnchecked A1 = []+ shrinkUnchecked A2 = [A1] instance GenValid A data B- = B1- | B2- | B3- deriving (Show, Eq, Generic)+ = B1+ | B2+ | B3+ deriving (Show, Eq, Generic) instance Validity B where- validate B1 = valid- validate B2 = invalid "for test"- validate B3 = valid+ validate B1 = valid+ validate B2 = invalid "for test"+ validate B3 = valid instance GenUnchecked B where- shrinkUnchecked B1 = []- shrinkUnchecked B2 = [B1]- shrinkUnchecked B3 = [B1, B2]+ shrinkUnchecked B1 = []+ shrinkUnchecked B2 = [B1]+ shrinkUnchecked B3 = [B1, B2] instance GenValid B
test/Data/GenValiditySpec.hs view
@@ -1,73 +1,81 @@ module Data.GenValiditySpec- ( spec- ) where+ ( spec,+ )+where +import Data.GenValidity import Test.Hspec import Test.QuickCheck -import Data.GenValidity- spec :: Spec spec = do- describe "genUtf16SurrogateCodePoint" $- it "generates Utf16 surrogate codepoints" $- forAll genUtf16SurrogateCodePoint $ (`shouldSatisfy` isUtf16SurrogateCodePoint)- - 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)+ 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
@@ -1,31 +1,33 @@-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-} module Data.InstanceSpec- ( spec- ) where+ ( spec,+ )+where+ #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<*>), pure) import Data.Functor ((<$>)) #endif-import Data.Data-import Data.Int+ #if MIN_VERSION_base(4,9,0) import Data.List.NonEmpty (NonEmpty) #endif-import Data.Fixed-import Data.Ratio-import Data.Word import Control.Monad--import Test.Hspec-import Test.Hspec.Core.QuickCheck (modifyMaxSize, modifyMaxSuccess)-import Test.QuickCheck+import Data.Data+import Data.Fixed #if MIN_VERSION_base(4,8,0) import GHC.Natural #endif import Data.GenValidity+import Data.Int+import Data.Ratio+import Data.Word+import Test.Hspec+import Test.Hspec.Core.QuickCheck (modifyMaxSize, modifyMaxSuccess)+import Test.QuickCheck spec :: Spec spec = do@@ -46,6 +48,18 @@ twoTests (Proxy :: Proxy Integer) twoTests (Proxy :: Proxy Float) twoTupleTests (Proxy :: Proxy Float)+ -- Regression tests+ describe "shrinkUnchecked Float" $ do+ let sf :: Float -> Spec+ sf f = it (unwords ["Does not shrink", show f, "to itself"]) $ f `shouldNotSatisfy` (`elem` shrinkUnchecked f)++ sf (-2.1393704e20)+ sf 1.2223988e-12+ sf 2.7896812e10+ describe "shrinkUnchecked Double" $ do+ let sd :: Double -> Spec+ sd d = it (unwords ["Does not shrink", show d, "to itself"]) $ d `shouldNotSatisfy` (`elem` shrinkUnchecked d)+ sd (-1.032730679986007e18) twoTests (Proxy :: Proxy Double) twoTupleTests (Proxy :: Proxy Double) threeTests (Proxy :: Proxy (Ratio Int))@@ -54,18 +68,18 @@ twoTests (Proxy :: Proxy (Maybe Ordering)) twoTests (Proxy :: Proxy (Maybe (Maybe (Ordering)))) threeTests (Proxy :: Proxy (Ratio Integer))- -- threeTupleTests (Proxy :: Proxy (Ratio Integer))+ -- threeTupleTests (Proxy :: Proxy (Ratio Integer)) threeTests (Proxy :: Proxy (Ratio Int))- -- threeTupleTests (Proxy :: Proxy (Ratio Int))+ -- threeTupleTests (Proxy :: Proxy (Ratio Int)) threeTests (Proxy :: Proxy (Ratio Int8)) describe "shrinking (Ratio Int)" $ it "can shrink this example" $- let v = ((-9223372036854775808) % 9223372036854775761) :: Ratio Int- in v `notElem` shrinkValid v+ 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+ let v = ((-128) % 113) :: Ratio Int8+ in v `notElem` shrinkValid v twoTests (Proxy :: Proxy Uni) twoTupleTests (Proxy :: Proxy Uni) twoTests (Proxy :: Proxy Deci)@@ -80,6 +94,7 @@ twoTupleTests (Proxy :: Proxy Nano) twoTests (Proxy :: Proxy Pico) twoTupleTests (Proxy :: Proxy Pico)+ #if MIN_VERSION_base(4,8,0) twoTests (Proxy :: Proxy Natural) @@ -89,25 +104,28 @@ twoTests (Proxy :: Proxy (NonEmpty Ordering)) #endif twoTupleTests ::- forall a. (Show a, Eq a, Typeable a, GenUnchecked a, GenValid a)- => Proxy a- -> Spec+ forall a.+ (Show a, Eq a, Typeable a, GenUnchecked a, GenValid a) =>+ Proxy a ->+ Spec twoTupleTests proxy = do modifyMaxSuccess (`quot` 2) $ modifyMaxSize (`quot` 2) $ twoTests $ (,) <$> proxy <*> proxy twoTests ::- forall a. (Show a, Eq a, Typeable a, GenUnchecked a, GenValid a)- => Proxy a- -> Spec+ forall a.+ (Show a, Eq a, Typeable a, GenUnchecked a, GenValid a) =>+ Proxy a ->+ Spec twoTests proxy = describe (nameOf proxy) $ do genUncheckedTest proxy genValidTest proxy threeTests ::- forall a. (Show a, Eq a, Typeable a, GenUnchecked a, GenValid a, GenInvalid a)- => Proxy a- -> Spec+ forall a.+ (Show a, Eq a, Typeable a, GenUnchecked a, GenValid a, GenInvalid a) =>+ Proxy a ->+ Spec threeTests proxy = describe (nameOf proxy) $ do genUncheckedTest proxy@@ -115,9 +133,10 @@ genInvalidTest proxy genUncheckedTest ::- forall a. (Show a, Eq a, Typeable a, GenUnchecked a, GenValid a)- => Proxy a- -> Spec+ forall a.+ (Show a, Eq a, Typeable a, GenUnchecked a, GenValid a) =>+ Proxy a ->+ Spec genUncheckedTest proxy = do it (unwords ["genUnchecked of", nameOf proxy, "does not crash while validating"]) $ forAll genUnchecked $ \a ->@@ -126,27 +145,29 @@ Left err -> seq err True modifyMaxSuccess (`quot` 5) $ it- (unwords- [ "shrinkUnchecked of"- , nameOf proxy- , "only produces values that do not crash while validating"- ]) $- forAll genUnchecked $ \a ->- forM_ (shrinkUnchecked a) $ \v ->- case prettyValidate (v :: a) of- Right v_ -> seq v_ $ pure () :: IO ()- Left err -> seq err $ pure ()+ ( unwords+ [ "shrinkUnchecked of",+ nameOf proxy,+ "only produces values that do not crash while validating"+ ]+ )+ $ forAll genUnchecked $ \a ->+ forM_ (shrinkUnchecked a) $ \v ->+ case prettyValidate (v :: a) of+ Right v_ -> seq v_ $ pure () :: IO ()+ Left err -> seq err $ pure () modifyMaxSuccess (`quot` 5) $ it (unwords ["shrinkUnchecked of", nameOf proxy, "does not shrink to itself"]) $- forAll genValid $ \a ->- forM_ (shrinkUnchecked a) $ \a' ->- unless (a /= a') $- expectationFailure $ unlines ["The value", show (a :: a), "was shrunk to itself"]+ forAll genValid $ \a ->+ forM_ (shrinkUnchecked a) $ \a' ->+ unless (a /= a') $+ expectationFailure $ unlines ["The value", show (a :: a), "was shrunk to itself"] genValidTest ::- forall a. (Show a, Eq a, Typeable a, GenValid a)- => Proxy a- -> Spec+ 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 ->@@ -154,36 +175,38 @@ Right v -> seq v $ pure () Left err -> expectationFailure $- unlines ["'validate' reported this value to be invalid:", show a, err, ""]+ 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, ""]+ 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 ()+ ( 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"]+ forAll genValid $ \a ->+ forM_ (shrinkValid a) $ \a' ->+ unless (a /= a') $+ expectationFailure $ unlines ["The value", show (a :: a), "was shrunk to itself"] genInvalidTest ::- forall a. (Show a, Typeable a, GenInvalid a)- => Proxy a- -> Spec+ forall a.+ (Show a, Typeable a, GenInvalid a) =>+ Proxy a ->+ Spec genInvalidTest proxy = do it (unwords ["genInvalid of", nameOf proxy, "generates only invalid values"]) $ forAll genInvalid $ \a ->@@ -193,28 +216,30 @@ Left e -> seq e $ pure () modifyMaxSuccess (`quot` 5) $ it (unwords ["shrinkInvalid of", nameOf proxy, "shrinks to only invalid values"]) $- forAll genInvalid $ \a ->- forM_ (shrinkInvalid a) $ \v ->- case prettyValidate (v :: a) of- Right _ ->- expectationFailure $ unlines ["'validate' reported this value to be valid: ", show v]- Left e -> seq e $ pure ()+ forAll genInvalid $ \a ->+ forM_ (shrinkInvalid a) $ \v ->+ case prettyValidate (v :: a) of+ Right _ ->+ expectationFailure $ unlines ["'validate' reported this value to be valid: ", show v]+ Left e -> seq e $ pure () modifyMaxSuccess (`quot` 5) $ it- (unwords- [ "shrinkInvalid of"- , nameOf proxy- , "only produces values that do not crash while validating"- ]) $- forAll genInvalid $ \a ->- forM_ (shrinkInvalid a) $ \v ->- case prettyValidate (v :: a) of- Right _ ->- expectationFailure $ unlines ["'validate' reported this value to be valid: ", show v]- Left e -> seq e $ pure ()+ ( unwords+ [ "shrinkInvalid of",+ nameOf proxy,+ "only produces values that do not crash while validating"+ ]+ )+ $ forAll genInvalid $ \a ->+ forM_ (shrinkInvalid a) $ \v ->+ case prettyValidate (v :: a) of+ Right _ ->+ expectationFailure $ unlines ["'validate' reported this value to be valid: ", show v]+ Left e -> seq e $ pure () nameOf ::- forall a. Typeable a- => Proxy a- -> String+ forall a.+ Typeable a =>+ Proxy a ->+ String nameOf = show . typeRep