genvalidity-0.7.0.2/src/0000755000000000000000000000000013431122267013153 5ustar0000000000000000genvalidity-0.7.0.2/src/Data/0000755000000000000000000000000013440050021014010 5ustar0000000000000000genvalidity-0.7.0.2/src/Data/GenValidity/0000755000000000000000000000000013440050021016227 5ustar0000000000000000genvalidity-0.7.0.2/test/0000755000000000000000000000000013431122267013343 5ustar0000000000000000genvalidity-0.7.0.2/test/Data/0000755000000000000000000000000013440047640014215 5ustar0000000000000000genvalidity-0.7.0.2/test/Data/GenValidity/0000755000000000000000000000000013431122267016433 5ustar0000000000000000genvalidity-0.7.0.2/src/Data/GenValidity.hs0000644000000000000000000010347513440050021016575 0ustar0000000000000000{-| @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 -} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 710 #define OVERLAPPING_ {-# OVERLAPPING #-} #else {-# LANGUAGE OverlappingInstances #-} #define OVERLAPPING_ #endif #if MIN_VERSION_base(4,9,0) {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} #endif module Data.GenValidity ( GenUnchecked(..) , GenValid(..) , GenInvalid(..) -- * Helper functions , genValidStructurally , genValidStructurallyWithoutExtraChecking , shrinkValidStructurally , shrinkValidStructurallyWithoutExtraFiltering , module Data.GenValidity.Utils -- * Re-exports , module Data.Validity -- * The Generics magic , genericGenUnchecked , GGenUnchecked(..) , genericShrinkUnchecked , uncheckedRecursivelyShrink , GUncheckedRecursivelyShrink(..) , uncheckedSubterms , GUncheckedSubterms(..) , GUncheckedSubtermsIncl(..) , GGenValid(..) , GValidRecursivelyShrink(..) , structurallyValidSubterms , GValidSubterms(..) , GValidSubtermsIncl(..) ) where import Data.Validity import Data.Fixed (Fixed(..), HasResolution) #if MIN_VERSION_base(4,9,0) import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NE #endif #if MIN_VERSION_base(4,8,0) import Data.Word (Word8, Word16, Word32, Word64) #else import Data.Word (Word, Word8, Word16, Word32, Word64) #endif import Data.Int (Int8, Int16, Int32, Int64) import Data.Ratio ((%)) import GHC.Generics import GHC.Real (Ratio(..)) import Test.QuickCheck hiding (Fixed) #if MIN_VERSION_base(4,8,0) import GHC.Natural #else import Control.Applicative ((<*>), (<$>), pure) #endif import Data.GenValidity.Utils {-# ANN module "HLint: ignore Reduce duplication" #-} -- | A class of types for which truly arbitrary values can be generated. -- -- === How to instantiate 'GenUnchecked' -- -- __Step 1__: Try to instantiate 'GenUnchecked' via 'Generic'. -- __this is probably what you want__ -- -- An instance of this class can be made automatically if the type in question -- has a 'Generic' instance. This instance will try to use 'genUnchecked' to -- generate all structural sub-parts of the value that is being generated. -- -- Example: -- -- > {-# LANGUAGE DeriveGeneric #-} -- > -- > data MyType = MyType Rational String -- > deriving (Show, Eq, Generic) -- > -- > instance GenUnchecked MyType -- -- generates something like: -- -- > instance GenUnchecked MyType where -- > genUnchecked = MyType <$> genUnchecked <*> genUnchecked -- -- -- __Step 2__: If an instatiation via 'Generic' is not possible, then you should emulate what -- 'genericGenUnchecked' does. -- This means that all sub-parts should be generated using 'genUnchecked'. -- Make sure to generate any possible value, valid or not, that can exist at runtime -- even when taking the existence of 'Unsafe.Coerce.unsafeCoerce' into account. -- -- === Warning: Invalid values can be funky -- -- Some types have serious validity constraints. See 'Text' or 'ByteString' for example. -- These can behave very strangely when they are not valid. -- In that case, __do not override 'GenUnchecked' such that 'genUnchecked' only generates valid values__. -- In that case, do not override 'genUnchecked' at all. -- Instead, use 'genValid' from 'GenValid' (see below) instead. class GenUnchecked a where genUnchecked :: Gen a default genUnchecked :: (Generic a, GGenUnchecked (Rep a)) => Gen a genUnchecked = genericGenUnchecked shrinkUnchecked :: a -> [a] default shrinkUnchecked :: (Generic a, GUncheckedRecursivelyShrink (Rep a), GUncheckedSubterms (Rep a) a) => a -> [a] shrinkUnchecked = genericShrinkUnchecked -- | A class of types for which valid values can be generated. -- -- === 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, that the resulting generator is too slow. -- In that case, go to Step 2. -- -- __Step 2__: Try to instantiate 'GenValid' using the helper functions via 'Generic' -- This involves using 'genValidStructurally' to override 'genValid' and -- using 'shrinkValidStructurally' to override 'shrinkValid'. -- __Every time you override 'genValid', you should also override 'shrinkValid'__ -- -- __Step 3__: If the above is not possible due to lack of a 'Generic' instance, -- then you should emulate what 'genValidStructurally' does. -- This means that all sub-parts should be generated using 'genValid'. -- 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 -- -- > arbitrary = genValid -- > shrink = shrinkValid class (Validity a, GenUnchecked 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 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] shrinkValid = filter isValid . shrinkUnchecked -- | A class of types for which invalid values can be generated. -- -- === How to instantiate 'GenInvalid' -- -- __Step 1__: Realise that you probably do not want to. -- It makes no sense, and serves no purpose, to instantiate 'GenInvalid' for types -- which contain no invalid values. (In fact, the default implementation will go into -- an infinite loop for such types.) -- You should only instantiate 'GenInvalid' if you explicitly want to use it -- to write tests that deal with invalid values, or if you are writing a container -- for parametric values. -- -- __Step 2__: Instantiate 'GenInvalid' without overriding any functions. class (Validity a, GenUnchecked 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. genInvalid = genUnchecked `suchThat` isInvalid shrinkInvalid :: 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 ] 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 (a, b) = ((,) <$> shrinkValid a <*> shrinkValid b) ++ [ (a', b) | a' <- shrinkValid a ] ++ [ (a, b') | b' <- shrinkValid b ] instance (GenInvalid a, GenInvalid b) => GenInvalid (a, b) where genInvalid = sized $ \n -> do (r, s) <- genSplit n oneof [ do a <- resize r genUnchecked b <- resize s genInvalid return (a, b) , do a <- resize r genInvalid b <- resize s genUnchecked return (a, b) ] instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (Either a b) where genUnchecked = oneof [Left <$> genUnchecked, Right <$> genUnchecked] shrinkUnchecked (Left a) = Left <$> shrinkUnchecked a shrinkUnchecked (Right b) = Right <$> shrinkUnchecked b instance (GenValid a, GenValid b) => GenValid (Either a b) where genValid = oneof [Left <$> genValid, Right <$> genValid] shrinkValid (Left a) = Left <$> shrinkValid a shrinkValid (Right b) = Right <$> shrinkValid b -- | This instance ensures that the generated tupse contains at least one invalid element. The other element is unchecked. instance (GenInvalid a, GenInvalid b) => GenInvalid (Either a b) where genInvalid = oneof [Left <$> genInvalid, Right <$> genInvalid] 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 (GenInvalid a, GenInvalid b, GenInvalid c) => GenInvalid (a, b, c) where genInvalid = sized $ \n -> do (r, s, t) <- genSplit3 n oneof [ do a <- resize r genInvalid b <- resize s genUnchecked c <- resize t genUnchecked return (a, b, c) , do a <- resize r genUnchecked b <- resize s genInvalid c <- resize t genUnchecked return (a, b, c) , do a <- resize r genUnchecked b <- resize s genUnchecked c <- resize t genInvalid return (a, b, c) ] instance (GenUnchecked a, GenUnchecked b, GenUnchecked c, GenUnchecked d) => GenUnchecked (a, b, c, d) where genUnchecked = sized $ \n -> do (r, s, t, u) <- genSplit4 n a <- resize r genUnchecked b <- resize s genUnchecked c <- resize t genUnchecked d <- resize u genUnchecked return (a, b, c, d) shrinkUnchecked (a, b, c, d) = [ (a', b', c', d') | (a', (b', (c', d'))) <- shrinkUnchecked (a, (b, (c, d))) ] 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))) ] -- | This instance ensures that the generated triple contains at least one invalid element. The other two are unchecked. instance (GenInvalid a, GenInvalid b, GenInvalid c, GenInvalid d) => GenInvalid (a, b, c, d) where genInvalid = sized $ \n -> do (r, s, t, u) <- genSplit4 n oneof [ do a <- resize r genInvalid b <- resize s genUnchecked c <- resize t genUnchecked d <- resize u genUnchecked return (a, b, c, d) , do a <- resize r genUnchecked b <- resize s genInvalid c <- resize t genUnchecked d <- resize u genUnchecked return (a, b, c, d) , do a <- resize r genUnchecked b <- resize s genUnchecked c <- resize t genInvalid d <- resize u genUnchecked return (a, b, c, d) , do a <- resize r genUnchecked b <- resize s genUnchecked c <- resize t genUnchecked d <- resize u genInvalid return (a, b, c, d) ] instance (GenUnchecked a, GenUnchecked b, GenUnchecked c, GenUnchecked d, GenUnchecked e) => GenUnchecked (a, b, c, d, e) where genUnchecked = sized $ \n -> do (r, s, t, u, v) <- genSplit5 n a <- resize r genUnchecked b <- resize s genUnchecked c <- resize t genUnchecked d <- resize u genUnchecked e <- resize v genUnchecked return (a, b, c, d, e) shrinkUnchecked (a, b, c, d, e) = [ (a', b', c', d', e') | (a', (b', (c', (d', e')))) <- shrinkUnchecked (a, (b, (c, (d, e)))) ] 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 (GenInvalid a, GenInvalid b, GenInvalid c, GenInvalid d, GenInvalid e) => GenInvalid (a, b, c, d, e) where genInvalid = sized $ \n -> do (r, s, t, u, v) <- genSplit5 n oneof [ do a <- resize r genInvalid b <- resize s genUnchecked c <- resize t genUnchecked d <- resize u genUnchecked e <- resize v genUnchecked return (a, b, c, d, e) , do a <- resize r genUnchecked b <- resize s genInvalid c <- resize t genUnchecked d <- resize u genUnchecked e <- resize v genUnchecked return (a, b, c, d, e) , do a <- resize r genUnchecked b <- resize s genUnchecked c <- resize t genInvalid d <- resize u genUnchecked e <- resize v genUnchecked return (a, b, c, d, e) , do a <- resize r genUnchecked b <- resize s genUnchecked c <- resize t genUnchecked d <- resize u genInvalid e <- resize v genUnchecked return (a, b, c, d, e) , do a <- resize r genUnchecked b <- resize s genUnchecked c <- resize t genUnchecked d <- resize u genUnchecked e <- resize v genInvalid return (a, b, c, d, e) ] instance GenUnchecked a => GenUnchecked (Maybe a) where genUnchecked = oneof [pure Nothing, Just <$> genUnchecked] shrinkUnchecked Nothing = [] shrinkUnchecked (Just a) = Nothing : (Just <$> shrinkUnchecked a) instance GenValid a => GenValid (Maybe a) where genValid = oneof [pure Nothing, Just <$> genValid] shrinkValid Nothing = [] shrinkValid (Just a) = Nothing : (Just <$> shrinkValid a) instance GenInvalid a => GenInvalid (Maybe a) where genInvalid = Just <$> genInvalid #if MIN_VERSION_base(4,9,0) instance GenUnchecked a => GenUnchecked (NonEmpty a) where genUnchecked = do l <- genUnchecked case NE.nonEmpty l of Nothing -> scale (+1) genUnchecked Just ne -> pure ne shrinkUnchecked (v :| vs) = [ e :| es | (e, es) <- shrinkUnchecked (v, vs)] instance GenValid a => GenValid (NonEmpty a) where genValid = do l <- genValid case NE.nonEmpty l of Nothing -> scale (+1) genValid Just ne -> pure ne shrinkValid (v :| vs) = [ e :| es | (e, es) <- shrinkValid (v, vs)] instance GenInvalid a => GenInvalid (NonEmpty a) where genInvalid = do l <- genInvalid case NE.nonEmpty l of Nothing -> scale (+1) genInvalid Just ne -> pure ne #endif instance GenUnchecked a => GenUnchecked [a] where 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 -- | This instance ensures that the generated list contains at least one element -- that satisfies 'isInvalid'. The rest is unchecked. instance GenInvalid a => GenInvalid [a] where genInvalid = sized $ \n -> do (x, y, z) <- genSplit3 n before <- resize x $ genListOf genUnchecked middle <- resize y genInvalid after <- resize z $ genListOf genUnchecked return $ before ++ [middle] ++ after instance GenUnchecked () where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid () instance GenUnchecked Bool where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid Bool instance GenUnchecked Ordering where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid Ordering instance GenUnchecked Char where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid Char instance GenUnchecked Int where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid Int instance GenUnchecked Int8 where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid Int8 instance GenUnchecked Int16 where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid Int16 instance GenUnchecked Int32 where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid Int32 instance GenUnchecked Int64 where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid Int64 where genValid = arbitrary shrinkValid = shrink instance GenUnchecked Word where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid Word instance GenUnchecked Word8 where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid Word8 instance GenUnchecked Word16 where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid Word16 instance GenUnchecked Word32 where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid Word32 instance GenUnchecked Word64 where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid Word64 instance GenUnchecked Float where genUnchecked = frequency [(9, arbitrary), (1, elements [read "NaN", read "Infinity", read "-Infinity", read "-0"])] #if MIN_VERSION_QuickCheck(2,9,2) shrinkUnchecked f = if | isInfinite f -> [] | isNaN f -> [] | otherwise -> shrink f #else shrinkUnchecked _ = [] #endif instance GenValid Float where genValid = genUnchecked shrinkValid = shrinkUnchecked instance GenUnchecked Double where genUnchecked = frequency [(9, arbitrary), (1, elements [read "NaN", read "Infinity", read "-Infinity", read "-0"])] #if MIN_VERSION_QuickCheck(2,9,2) shrinkUnchecked d = if | isInfinite d -> [] | isNaN d -> [] | otherwise -> shrink d #else shrinkUnchecked _ = [] #endif instance GenValid Double where genValid = genUnchecked shrinkValid = shrinkUnchecked instance GenUnchecked Integer where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid Integer #if MIN_VERSION_base(4,8,0) instance GenUnchecked Natural where genUnchecked = fromInteger . abs <$> genUnchecked shrinkUnchecked 0 = [] shrinkUnchecked n = [0 .. n-1] instance GenValid Natural where genValid = fromInteger . abs <$> genValid #endif instance (Integral a, GenUnchecked a) => GenUnchecked (Ratio a) where genUnchecked = (:%) <$> genUnchecked <*> genUnchecked shrinkUnchecked (n :% d) = [n' :% d' | (n', d') <- shrinkUnchecked (n, d)] instance (Integral a, Num a, Ord a, GenValid a) => GenValid (Ratio a) where genValid = (%) <$> genValid <*> (genValid `suchThat` (> 0)) shrinkValid (n :% d) = [n' % d' | (n', d') <- shrinkValid (n, d), d' > 0] instance (Integral a, Num a, Ord a, GenValid a) => GenInvalid (Ratio a) instance HasResolution a => GenUnchecked (Fixed a) where genUnchecked = MkFixed <$> genUnchecked shrinkUnchecked (MkFixed i) = MkFixed <$> shrinkUnchecked i instance HasResolution a => GenValid (Fixed a) genericGenUnchecked :: (Generic a, GGenUnchecked (Rep a)) => Gen a genericGenUnchecked = to <$> gGenUnchecked class GGenUnchecked f where gGenUnchecked :: Gen (f a) instance GGenUnchecked U1 where gGenUnchecked = pure U1 instance (GGenUnchecked a, GGenUnchecked b) => GGenUnchecked (a :*: b) where gGenUnchecked = (:*:) <$> gGenUnchecked <*> gGenUnchecked instance (GGenUnchecked a, GGenUnchecked b) => GGenUnchecked (a :+: b) where gGenUnchecked = oneof [L1 <$> gGenUnchecked, R1 <$> gGenUnchecked] instance (GGenUnchecked a) => GGenUnchecked (M1 i c a) where gGenUnchecked = M1 <$> gGenUnchecked instance (GenUnchecked a) => GGenUnchecked (K1 i a) where gGenUnchecked = K1 <$> genUnchecked -- | Shrink a term to any of its immediate subterms, -- and also recursively shrink all subterms. genericShrinkUnchecked :: (Generic a, GUncheckedRecursivelyShrink (Rep a), GUncheckedSubterms (Rep a) a) => a -> [a] genericShrinkUnchecked x = uncheckedSubterms x ++ uncheckedRecursivelyShrink x -- | Recursively shrink all immediate uncheckedSubterms. uncheckedRecursivelyShrink :: (Generic a, GUncheckedRecursivelyShrink (Rep a)) => a -> [a] uncheckedRecursivelyShrink = map to . gUncheckedRecursivelyShrink . from class GUncheckedRecursivelyShrink f where gUncheckedRecursivelyShrink :: f a -> [f a] instance (GUncheckedRecursivelyShrink f, GUncheckedRecursivelyShrink g) => GUncheckedRecursivelyShrink (f :*: g) where gUncheckedRecursivelyShrink (x :*: y) = ((:*:) <$> gUncheckedRecursivelyShrink x <*> gUncheckedRecursivelyShrink y) ++ [ x' :*: y | x' <- gUncheckedRecursivelyShrink x ] ++ [ x :*: y' | y' <- gUncheckedRecursivelyShrink y ] instance (GUncheckedRecursivelyShrink f, GUncheckedRecursivelyShrink g) => GUncheckedRecursivelyShrink (f :+: g) where gUncheckedRecursivelyShrink (L1 x) = map L1 (gUncheckedRecursivelyShrink x) gUncheckedRecursivelyShrink (R1 x) = map R1 (gUncheckedRecursivelyShrink x) instance GUncheckedRecursivelyShrink f => GUncheckedRecursivelyShrink (M1 i c f) where gUncheckedRecursivelyShrink (M1 x) = map M1 (gUncheckedRecursivelyShrink x) instance GenUnchecked a => GUncheckedRecursivelyShrink (K1 i a) where gUncheckedRecursivelyShrink (K1 x) = map K1 (shrinkUnchecked x) instance GUncheckedRecursivelyShrink U1 where gUncheckedRecursivelyShrink U1 = [] instance GUncheckedRecursivelyShrink V1 where -- The empty type can't be shrunk to anything. gUncheckedRecursivelyShrink _ = [] -- | All immediate uncheckedSubterms of a term. uncheckedSubterms :: (Generic a, GUncheckedSubterms (Rep a) a) => a -> [a] uncheckedSubterms = gUncheckedSubterms . from class GUncheckedSubterms f a where gUncheckedSubterms :: f a -> [a] instance GUncheckedSubterms V1 a where gUncheckedSubterms _ = [] instance GUncheckedSubterms U1 a where gUncheckedSubterms U1 = [] instance (GUncheckedSubtermsIncl f a, GUncheckedSubtermsIncl g a) => GUncheckedSubterms (f :*: g) a where gUncheckedSubterms (l :*: r) = gUncheckedSubtermsIncl l ++ gUncheckedSubtermsIncl r instance (GUncheckedSubtermsIncl f a, GUncheckedSubtermsIncl g a) => GUncheckedSubterms (f :+: g) a where gUncheckedSubterms (L1 x) = gUncheckedSubtermsIncl x gUncheckedSubterms (R1 x) = gUncheckedSubtermsIncl x instance GUncheckedSubterms f a => GUncheckedSubterms (M1 i c f) a where gUncheckedSubterms (M1 x) = gUncheckedSubterms x instance GUncheckedSubterms (K1 i a) b where gUncheckedSubterms (K1 _) = [] class GUncheckedSubtermsIncl f a where gUncheckedSubtermsIncl :: f a -> [a] instance GUncheckedSubtermsIncl V1 a where gUncheckedSubtermsIncl _ = [] instance GUncheckedSubtermsIncl U1 a where gUncheckedSubtermsIncl U1 = [] instance (GUncheckedSubtermsIncl f a, GUncheckedSubtermsIncl g a) => GUncheckedSubtermsIncl (f :*: g) a where gUncheckedSubtermsIncl (l :*: r) = gUncheckedSubtermsIncl l ++ gUncheckedSubtermsIncl r instance (GUncheckedSubtermsIncl f a, GUncheckedSubtermsIncl g a) => GUncheckedSubtermsIncl (f :+: g) a where gUncheckedSubtermsIncl (L1 x) = gUncheckedSubtermsIncl x gUncheckedSubtermsIncl (R1 x) = gUncheckedSubtermsIncl x instance GUncheckedSubtermsIncl f a => GUncheckedSubtermsIncl (M1 i c f) a where gUncheckedSubtermsIncl (M1 x) = gUncheckedSubtermsIncl x -- This is the important case: We've found a term of the same type. instance OVERLAPPING_ GUncheckedSubtermsIncl (K1 i a) a where gUncheckedSubtermsIncl (K1 x) = [x] instance OVERLAPPING_ GUncheckedSubtermsIncl (K1 i a) b where gUncheckedSubtermsIncl (K1 _) = [] -- | Generate a valid value by generating all the sub parts using the 'Generic' instance, -- and trying that until a valid value has been generated -- -- > 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 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 class GGenValid f where gGenValid :: Gen (f a) instance GGenValid U1 where gGenValid = pure U1 instance (GGenValid a, GGenValid b) => GGenValid (a :*: b) where gGenValid = (:*:) <$> gGenValid <*> gGenValid instance (GGenValid a, GGenValid b) => GGenValid (a :+: b) where gGenValid = oneof [L1 <$> gGenValid, R1 <$> gGenValid] instance (GGenValid a) => GGenValid (M1 i c a) where gGenValid = M1 <$> gGenValid instance (GenValid a) => GGenValid (K1 i a) where 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. -- -- > 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 -- | 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 -- | 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 _) = [] genvalidity-0.7.0.2/src/Data/GenRelativeValidity.hs0000644000000000000000000000140713431122267020275 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} module Data.GenRelativeValidity ( module Data.RelativeValidity , module Data.GenRelativeValidity ) where import Data.GenValidity import Data.RelativeValidity import Test.QuickCheck class (GenUnchecked a, RelativeValidity a b) => GenRelativeUnchecked a b where genUncheckedFor :: b -> Gen a genUncheckedFor _ = genUnchecked class (GenValid a, RelativeValidity a b) => GenRelativeValid a b where genValidFor :: b -> Gen a genValidFor b = genValid `suchThat` (`isValidFor` b) class (GenUnchecked a, RelativeValidity a b, GenRelativeUnchecked a b) => GenRelativeInvalid a b where genInvalidFor :: b -> Gen a genInvalidFor b = genUncheckedFor b `suchThat` (not . (`isValidFor` b)) genvalidity-0.7.0.2/src/Data/GenValidity/Utils.hs0000644000000000000000000000740513440050021017671 0ustar0000000000000000{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE CPP #-} #if __GLASGOW_HASKELL__ >= 710 #define OVERLAPPING_ {-# OVERLAPPING #-} #else {-# LANGUAGE OverlappingInstances #-} #define OVERLAPPING_ #endif #if MIN_VERSION_base(4,9,0) {-# OPTIONS_GHC -fno-warn-redundant-constraints #-} #endif module Data.GenValidity.Utils ( -- ** Helper functions for implementing generators upTo , genSplit , genSplit3 , genSplit4 , genSplit5 , arbPartition , shuffle , genListOf -- ** Helper functions for implementing shrinking functions , shrinkT2 , shrinkT3 , shrinkT4 ) where import Test.QuickCheck hiding (Fixed) #if !MIN_VERSION_QuickCheck(2,8,0) import Data.List (sortBy) import Data.Ord (comparing) #endif #if MIN_VERSION_base(4,8,0) import Control.Monad (forM) #else import Control.Applicative ((<$>), (<*>), pure) import Control.Monad (forM) #endif -- | '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) -- | 'arbPartition n' generates a list 'ls' such that 'sum ls' equals 'n'. arbPartition :: Int -> Gen [Int] arbPartition i = go i >>= shuffle where go k | k <= 0 = pure [] | otherwise = do first <- choose (1, k) rest <- arbPartition $ k - first return $ first : rest #if !MIN_VERSION_QuickCheck(2,8,0) -- | Generates a random permutation of the given list. shuffle :: [a] -> Gen [a] shuffle xs = do ns <- vectorOf (length xs) (choose (minBound :: Int, maxBound)) return (map snd (sortBy (comparing fst) (zip ns xs))) #endif -- | 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 size <- upTo n pars <- arbPartition size forM pars $ \i -> resize i func -- | Turn a shrinking function into a function that shrinks tuples. shrinkT2 :: (a -> [a]) -> (a, a) -> [(a, a)] shrinkT2 s (a, b) = (,) <$> s a <*> s b -- | Turn a shrinking function into a function that shrinks triples. shrinkT3 :: (a -> [a]) -> (a, a, a) -> [(a, a, a)] shrinkT3 s (a, b, c) = (,,) <$> s a <*> s b <*> s c -- | Turn a shrinking function into a function that shrinks quadruples. shrinkT4 :: (a -> [a]) -> (a, a, a, a) -> [(a, a, a, a)] shrinkT4 s (a, b, c, d) = (,,,) <$> s a <*> s b <*> s c <*> s d genvalidity-0.7.0.2/test/Spec.hs0000644000000000000000000000005413431122267014570 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} genvalidity-0.7.0.2/test/Data/GenValidity/GenericSpec.hs0000644000000000000000000000643113431122267021162 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} module Data.GenValidity.GenericSpec ( spec ) where import GHC.Generics (Generic, Rep) import Control.Monad import Test.Hspec import Test.QuickCheck import Data.Proxy import Data.Typeable import Data.GenValidity 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 Rational)) 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 Rational)) shrinkValidstructurallySpec (Proxy :: Proxy MyType) genValidstructurallySpec :: forall a. (Validity a, Show a, Eq 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. ( Validity 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 Rational deriving (Show, Eq, Generic, Typeable) instance Validity MyType instance GenUnchecked MyType instance GenValid MyType genvalidity-0.7.0.2/test/Data/GenValidity/ShrinkGenericSpec.hs0000644000000000000000000000402313431122267022334 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Data.GenValidity.ShrinkGenericSpec where 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] data Ex = Ex A B deriving (Show, Eq, Generic) instance Validity Ex instance GenUnchecked Ex instance GenValid Ex data A = A1 | A2 deriving (Show, Eq, Generic) instance Validity A instance GenUnchecked A where shrinkUnchecked A1 = [] shrinkUnchecked A2 = [A1] instance GenValid A 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 GenUnchecked B where shrinkUnchecked B1 = [] shrinkUnchecked B2 = [B1] shrinkUnchecked B3 = [B1, B2] instance GenValid B genvalidity-0.7.0.2/test/Data/GenValiditySpec.hs0000644000000000000000000000623713431122267017612 0ustar0000000000000000module Data.GenValiditySpec ( spec ) where import Test.Hspec import Test.QuickCheck import Data.GenValidity spec :: Spec spec = do 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 strictly positive integers" $ forAll arbitrary $ \n -> forAll (arbPartition n) $ \p -> p `shouldSatisfy` all (> 0) it "returns a list of integers that sum to the original positive integer" $ forAll (arbitrary `suchThat` (>= 0)) $ \n -> forAll (arbPartition n) $ \p -> sum p `shouldBe` n genvalidity-0.7.0.2/test/Data/InstanceSpec.hs0000644000000000000000000002312113440047640017127 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} module Data.InstanceSpec ( 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 #if MIN_VERSION_base(4,8,0) import GHC.Natural #endif import Data.GenValidity spec :: Spec spec = do twoTests (Proxy :: Proxy ()) twoTests (Proxy :: Proxy Bool) twoTests (Proxy :: Proxy Ordering) twoTests (Proxy :: Proxy Char) twoTests (Proxy :: Proxy Word) twoTests (Proxy :: Proxy Word8) twoTests (Proxy :: Proxy Word16) twoTests (Proxy :: Proxy Word32) twoTests (Proxy :: Proxy Word64) twoTests (Proxy :: Proxy Int) twoTests (Proxy :: Proxy Int8) twoTests (Proxy :: Proxy Int16) twoTests (Proxy :: Proxy Int32) twoTests (Proxy :: Proxy Int64) twoTests (Proxy :: Proxy Integer) twoTests (Proxy :: Proxy Float) twoTupleTests (Proxy :: Proxy Float) twoTests (Proxy :: Proxy Double) twoTupleTests (Proxy :: Proxy Double) threeTests (Proxy :: Proxy Rational) threeTupleTests (Proxy :: Proxy Rational) modifyMaxSuccess (`quot` 2) $ modifyMaxSize (`quot` 2) $ threeTests (Proxy :: Proxy (Either Rational Rational)) threeTests (Proxy :: Proxy (Maybe Rational)) threeTests (Proxy :: Proxy (Maybe (Maybe Rational))) threeTests (Proxy :: Proxy [Rational]) threeTests (Proxy :: Proxy (Ratio Integer)) threeTests (Proxy :: Proxy (Ratio Integer)) threeTupleTests (Proxy :: Proxy (Ratio Integer)) threeTests (Proxy :: Proxy (Ratio Int)) threeTupleTests (Proxy :: Proxy (Ratio Int)) twoTests (Proxy :: Proxy Uni) twoTupleTests (Proxy :: Proxy Uni) twoTests (Proxy :: Proxy Deci) twoTupleTests (Proxy :: Proxy Deci) twoTests (Proxy :: Proxy Centi) twoTupleTests (Proxy :: Proxy Centi) twoTests (Proxy :: Proxy Milli) twoTupleTests (Proxy :: Proxy Milli) twoTests (Proxy :: Proxy Micro) twoTupleTests (Proxy :: Proxy Micro) twoTests (Proxy :: Proxy Nano) twoTupleTests (Proxy :: Proxy Nano) twoTests (Proxy :: Proxy Pico) twoTupleTests (Proxy :: Proxy Pico) #if MIN_VERSION_base(4,8,0) twoTests (Proxy :: Proxy Natural) twoTupleTests (Proxy :: Proxy Natural) twoTests (Proxy :: Proxy (Ratio Integer)) twoTupleTests (Proxy :: Proxy (Ratio Int)) #endif #if MIN_VERSION_base(4,9,0) threeTests (Proxy :: Proxy (NonEmpty Rational)) #endif twoTupleTests :: forall a. (Show a, Eq a, Typeable a, GenValid a) => Proxy a -> Spec twoTupleTests proxy = do modifyMaxSuccess (`quot` 2) $ modifyMaxSize (`quot` 2) $ twoTests $ (,) <$> proxy <*> proxy modifyMaxSuccess (`quot` 3) $ modifyMaxSize (`quot` 3) $ twoTests $ (,,) <$> proxy <*> proxy <*> proxy modifyMaxSuccess (`quot` 4) $ modifyMaxSize (`quot` 4) $ twoTests $ (,,,) <$> proxy <*> proxy <*> proxy <*> proxy modifyMaxSuccess (`quot` 5) $ modifyMaxSize (`quot` 5) $ twoTests $ (,,,,) <$> proxy <*> proxy <*> proxy <*> proxy <*> proxy threeTupleTests :: forall a. (Show a, Eq a, Typeable a, GenValid a, GenInvalid a) => Proxy a -> Spec threeTupleTests proxy = do modifyMaxSuccess (`quot` 2) $ modifyMaxSize (`quot` 2) $ threeTests $ (,) <$> proxy <*> proxy modifyMaxSuccess (`quot` 3) $ modifyMaxSize (`quot` 3) $ threeTests $ (,,) <$> proxy <*> proxy <*> proxy modifyMaxSuccess (`quot` 4) $ modifyMaxSize (`quot` 4) $ threeTests $ (,,,) <$> proxy <*> proxy <*> proxy <*> proxy modifyMaxSuccess (`quot` 5) $ modifyMaxSize (`quot` 5) $ threeTests $ (,,,,) <$> proxy <*> proxy <*> proxy <*> proxy <*> proxy twoTests :: forall a. (Show a, Eq a, Typeable 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, GenValid a, GenInvalid a) => Proxy a -> Spec threeTests proxy = describe (nameOf proxy) $ do genUncheckedTest proxy genValidTest proxy genInvalidTest proxy genUncheckedTest :: forall a. (Show a, Eq a, Typeable a, GenValid a) => Proxy a -> Spec genUncheckedTest proxy = do it (unwords ["genUnchecked of", nameOf proxy, "does not crash while validating"]) $ forAll genUnchecked $ \a -> case prettyValidate (a :: a) of Right v -> seq v True Left err -> seq err True modifyMaxSuccess (`quot` 5) $ it (unwords [ "shrinkUnchecked of" , nameOf proxy , "only produces values that do not crash while validating" ]) $ forAll genUnchecked $ \a -> forM_ (shrinkUnchecked a) $ \v -> case prettyValidate (v :: a) of Right v_ -> seq v_ $ pure () :: IO () Left err -> seq err $ pure () modifyMaxSuccess (`quot` 5) $ it (unwords [ "shrinkUnchecked of" , nameOf proxy , "does not shrink to itself" ]) $ forAll genValid $ \a -> forM_ (shrinkUnchecked a) $ \a' -> unless (a /= a') $ expectationFailure $ unlines ["The value", show (a :: a), "was shrunk to itself"] 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"] genInvalidTest :: forall a. (Show a, Typeable a, GenInvalid a) => Proxy a -> Spec genInvalidTest proxy = do it (unwords ["genInvalid of", nameOf proxy, "generates only invalid values"]) $ forAll genInvalid $ \a -> case prettyValidate (a :: a) of Right _ -> expectationFailure $ unlines ["'validate' reported this value to be valid: ", show a] Left e -> seq e $ pure () modifyMaxSuccess (`quot` 5) $ it (unwords [ "shrinkInvalid of" , nameOf proxy , "shrinks to only invalid values" ]) $ forAll genInvalid $ \a -> forM_ (shrinkInvalid a) $ \v -> case prettyValidate (v :: a) of Right _ -> expectationFailure $ unlines [ "'validate' reported this value to be valid: " , show v ] Left e -> seq e $ pure () modifyMaxSuccess (`quot` 5) $ it (unwords [ "shrinkInvalid of" , nameOf proxy , "only produces values that do not crash while validating" ]) $ forAll genInvalid $ \a -> forM_ (shrinkInvalid a) $ \v -> case prettyValidate (v :: a) of Right _ -> expectationFailure $ unlines [ "'validate' reported this value to be valid: " , show v ] Left e -> seq e $ pure () nameOf :: forall a. Typeable a => Proxy a -> String nameOf = show . typeRep genvalidity-0.7.0.2/LICENSE0000644000000000000000000000207713431122267013377 0ustar0000000000000000The MIT License (MIT) Copyright (c) 2016 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 in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. genvalidity-0.7.0.2/Setup.hs0000644000000000000000000000005713431122267014022 0ustar0000000000000000import Distribution.Simple main = defaultMain genvalidity-0.7.0.2/genvalidity.cabal0000644000000000000000000000551413437505710015700 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack -- -- hash: 13e57f7aafc2a2db6d022ffcae38acf8fe9e764b697a451f92daca9e03535e1a name: genvalidity version: 0.7.0.2 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.kerckhove@gmail.com, nick.van.den.broeck666@gmail.com copyright: Copyright: (c) 2016-2018 Tom Sydney Kerckhove license: MIT license-file: LICENSE build-type: Simple source-repository head type: git location: https://github.com/NorfairKing/validity library exposed-modules: Data.GenValidity Data.GenRelativeValidity other-modules: Data.GenValidity.Utils Paths_genvalidity hs-source-dirs: src build-depends: QuickCheck >=2.7 , base >=4.7 && <5 , validity >=0.9 if impl(ghc >=8.0.0) ghc-options: -Wno-redundant-constraints default-language: Haskell2010 test-suite genvalidity-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: Data.GenValidity.GenericSpec Data.GenValidity.ShrinkGenericSpec Data.GenValiditySpec Data.InstanceSpec Paths_genvalidity hs-source-dirs: test ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -fno-warn-name-shadowing build-depends: QuickCheck , base , genvalidity , hspec , hspec-core default-language: Haskell2010