genvalidity-0.11.0.0/src/0000755000000000000000000000000013644617172013236 5ustar0000000000000000genvalidity-0.11.0.0/src/Data/0000755000000000000000000000000013645110574014102 5ustar0000000000000000genvalidity-0.11.0.0/src/Data/GenValidity/0000755000000000000000000000000013645110574016321 5ustar0000000000000000genvalidity-0.11.0.0/test/0000755000000000000000000000000013644617172013426 5ustar0000000000000000genvalidity-0.11.0.0/test/Data/0000755000000000000000000000000013644675212014276 5ustar0000000000000000genvalidity-0.11.0.0/test/Data/GenValidity/0000755000000000000000000000000013644617172016516 5ustar0000000000000000genvalidity-0.11.0.0/src/Data/GenRelativeValidity.hs0000644000000000000000000000140713644617172020360 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.11.0.0/src/Data/GenValidity.hs0000644000000000000000000011032413645110574016656 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 Definitely also look at the genvalidity-property and genvalidity-hspec packages for more info on how to use this package. -} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MagicHash #-} {-# 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 -- * Strange, possibly useful functions , genUtf16SurrogateCodePoint -- * 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((:|))) #endif #if MIN_VERSION_base(4,8,0) import Data.Word (Word64) import GHC.Word (Word8(..), Word16(..), Word32(..), Word(..)) #else import Data.Word (Word, Word64) import GHC.Word (Word8(..), Word16(..), Word32(..), Word(..)) #endif import 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) #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 -- -- If this is not possible because there is no 'GenUnchecked' instance available for one of the -- sub-parts of your type, __then do not instantiate 'GenUnchecked' for your type__. -- Just continue with 'GenValid' instead. -- -- __Step 2__: If an instatiation via 'Generic' is not possible, then you should emulate what -- 'genericGenUnchecked' does. -- This means that all sub-parts should be generated using 'genUnchecked'. -- Make sure to generate any possible value, valid or not, that can exist at runtime -- even when taking the existence of 'Unsafe.Coerce.unsafeCoerce' into account. -- -- === Warning: Invalid values can be funky -- -- Some types have serious validity constraints. See 'Rational' for example. -- These can behave very strangely when they are not valid. -- In that case, __do not override 'GenUnchecked' such that 'genUnchecked' only generates valid values__. -- In that case, do not override 'genUnchecked' at all. -- Instead, use 'genValid' from 'GenValid' (see below) instead and consider not instantiating 'GenUnchecked' at all. class GenUnchecked a where genUnchecked :: Gen a default genUnchecked :: (Generic a, GGenUnchecked (Rep a)) => Gen a genUnchecked = genericGenUnchecked shrinkUnchecked :: a -> [a] default shrinkUnchecked :: (Generic a, GUncheckedRecursivelyShrink (Rep a), GUncheckedSubterms (Rep a) a) => a -> [a] shrinkUnchecked = genericShrinkUnchecked -- | A class of types for which valid values can be generated. -- -- === How to instantiate 'GenValid' -- -- __Step 1__: Try to instantiate 'GenValid' without overriding any functions. -- This is only possible if your type has a 'GenUnchecked' instance. -- If it doesn't, go to step 2. -- It is possible that, if few values are valid or if validity -- checking is expensive, that the resulting generator is too slow. -- 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 => 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 -- | 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. -- -- === How to instantiate 'GenInvalid' -- -- __Step 1__: Realise that you probably do not want to. -- It makes no sense, and serves no purpose, to instantiate 'GenInvalid' for types -- which contain no invalid values. (In fact, the default implementation will go into -- an infinite loop for such types.) -- You should only instantiate 'GenInvalid' if you explicitly want to use it -- to write tests that deal with invalid values, or if you are writing a container -- for parametric values. -- -- __Step 2__: Instantiate 'GenInvalid' without overriding any functions. class Validity a => GenInvalid a where genInvalid :: Gen a -- | Generate an invalid datum, this should cover all possible invalid -- values -- -- > genInvalid = genUnchecked `suchThat` isInvalid -- -- To speed up testing, it may be a good idea to implement this yourself. -- If you do, make sure that it is possible to generate all possible -- invalid data, otherwise your testing may not cover all cases. default genInvalid :: GenUnchecked a => Gen a genInvalid = genUnchecked `suchThat` isInvalid shrinkInvalid :: a -> [a] default shrinkInvalid :: GenUnchecked a => a -> [a] shrinkInvalid = filter isInvalid . shrinkUnchecked instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (a, b) where genUnchecked = sized $ \n -> do (r, s) <- genSplit n a <- resize r genUnchecked b <- resize s genUnchecked return (a, b) shrinkUnchecked (a, b) = ((,) <$> shrinkUnchecked a <*> shrinkUnchecked b) ++ [ (a', b) | a' <- shrinkUnchecked a ] ++ [ (a, b') | b' <- shrinkUnchecked b ] 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 instance (GenUnchecked a, GenInvalid a, GenUnchecked b, GenInvalid b) => GenInvalid (a, b) where genInvalid = sized $ \n -> do (r, s) <- genSplit n oneof [ do a <- resize r genUnchecked b <- resize s genInvalid return (a, b) , do a <- resize r genInvalid b <- resize s genUnchecked return (a, b) ] instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (Either a b) where genUnchecked = oneof [Left <$> genUnchecked, Right <$> genUnchecked] shrinkUnchecked (Left a) = Left <$> shrinkUnchecked a shrinkUnchecked (Right b) = Right <$> shrinkUnchecked b instance (GenValid a, GenValid b) => GenValid (Either a b) where genValid = oneof [Left <$> genValid, Right <$> genValid] shrinkValid (Left a) = Left <$> shrinkValid a shrinkValid (Right b) = Right <$> shrinkValid b -- | This instance ensures that the generated tupse contains at least one invalid element. The other element is unchecked. instance (GenInvalid a, GenInvalid b) => GenInvalid (Either a b) where genInvalid = oneof [Left <$> genInvalid, Right <$> genInvalid] shrinkInvalid (Left v) = Left <$> shrinkInvalid v shrinkInvalid (Right v) = Right <$> shrinkInvalid v instance (GenUnchecked a, GenUnchecked b, GenUnchecked c) => GenUnchecked (a, b, c) where genUnchecked = sized $ \n -> do (r, s, t) <- genSplit3 n a <- resize r genUnchecked b <- resize s genUnchecked c <- resize t genUnchecked return (a, b, c) shrinkUnchecked (a, b, c) = [ (a', b', c') | (a', (b', c')) <- shrinkUnchecked (a, (b, c)) ] instance (GenValid a, GenValid b, GenValid c) => GenValid (a, b, c) where genValid = sized $ \n -> do (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) ] 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 ( GenUnchecked a, GenUnchecked b, GenUnchecked c, GenUnchecked d , GenInvalid a, GenInvalid b, GenInvalid c, GenInvalid d) => GenInvalid (a, b, c, d) where genInvalid = sized $ \n -> do (r, s, t, u) <- genSplit4 n oneof [ do a <- resize r genInvalid b <- resize s genUnchecked c <- resize t genUnchecked d <- resize u genUnchecked return (a, b, c, d) , do a <- resize r genUnchecked b <- resize s genInvalid c <- resize t genUnchecked d <- resize u genUnchecked return (a, b, c, d) , do a <- resize r genUnchecked b <- resize s genUnchecked c <- resize t genInvalid d <- resize u genUnchecked return (a, b, c, d) , do a <- resize r genUnchecked b <- resize s genUnchecked c <- resize t genUnchecked d <- resize u genInvalid return (a, b, c, d) ] instance (GenUnchecked a, GenUnchecked b, GenUnchecked c, GenUnchecked d, GenUnchecked e) => GenUnchecked (a, b, c, d, e) where genUnchecked = sized $ \n -> do (r, s, t, u, v) <- genSplit5 n a <- resize r genUnchecked b <- resize s genUnchecked c <- resize t genUnchecked d <- resize u genUnchecked e <- resize v genUnchecked return (a, b, c, d, e) shrinkUnchecked (a, b, c, d, e) = [ (a', b', c', d', e') | (a', (b', (c', (d', e')))) <- shrinkUnchecked (a, (b, (c, (d, e)))) ] 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) instance GenValid a => GenValid (Maybe a) where genValid = oneof [pure Nothing, Just <$> genValid] shrinkValid Nothing = [] shrinkValid (Just a) = Nothing : (Just <$> shrinkValid a) instance GenInvalid a => GenInvalid (Maybe a) where genInvalid = Just <$> genInvalid shrinkInvalid Nothing = [] -- Should not happen shrinkInvalid (Just a) = Just <$> shrinkInvalid a #if MIN_VERSION_base(4,9,0) instance GenUnchecked a => GenUnchecked (NonEmpty a) where genUnchecked = genNonEmptyOf genUnchecked shrinkUnchecked (v :| vs) = [ e :| es | (e, es) <- shrinkUnchecked (v, vs)] instance GenValid a => GenValid (NonEmpty a) where genValid = genNonEmptyOf genValid shrinkValid (v :| vs) = [ e :| es | (e, es) <- shrinkValid (v, vs)] instance (GenUnchecked a, GenInvalid a) => GenInvalid (NonEmpty a) where genInvalid = genNonEmptyOf genInvalid #endif instance 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 (GenUnchecked a, GenInvalid a) => GenInvalid [a] where genInvalid = sized $ \n -> do (x, y, z) <- genSplit3 n before <- resize x $ genListOf genUnchecked middle <- resize y genInvalid after <- resize z $ genListOf genUnchecked return $ before ++ [middle] ++ after instance GenUnchecked () where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid () where genValid = genUnchecked shrinkValid = shrinkUnchecked instance GenUnchecked Bool where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid Bool where genValid = genUnchecked shrinkValid = shrinkUnchecked instance GenUnchecked Ordering where genUnchecked = arbitrary shrinkUnchecked = shrink instance GenValid Ordering where genValid = genUnchecked shrinkValid = shrinkUnchecked instance GenUnchecked Char where 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 instance GenUnchecked Int where genUnchecked = genIntX shrinkUnchecked = shrink instance GenValid Int where genValid = genUnchecked shrinkValid = shrinkUnchecked instance GenUnchecked Int8 where genUnchecked = genUncheckedInt (I8#) shrinkUnchecked = shrinkUncheckedInt (\(I# i#) -> I8# i#) (\(I8# i#) -> I# i#) instance GenValid Int8 where genValid = genIntX shrinkValid = shrink instance GenUnchecked Int16 where genUnchecked = genUncheckedInt (I16#) shrinkUnchecked = shrinkUncheckedInt (\(I# i#) -> I16# i#) (\(I16# i#) -> I# i#) instance GenValid Int16 where genValid = genIntX shrinkValid = shrink instance GenUnchecked Int32 where genUnchecked = genUncheckedInt (I32#) shrinkUnchecked = shrinkUncheckedInt (\(I# i#) -> I32# i#) (\(I32# i#) -> I# i#) instance GenValid Int32 where genValid = genIntX shrinkValid = shrink instance GenUnchecked Int64 where genUnchecked = genIntX shrinkUnchecked = shrink instance GenValid Int64 where genValid = genUnchecked shrinkValid = shrinkUnchecked instance GenUnchecked Word where genUnchecked = genWordX shrinkUnchecked = shrink instance GenValid Word where genValid = genUnchecked shrinkValid = shrinkUnchecked instance GenUnchecked Word8 where genUnchecked = genUncheckedWord (W8#) shrinkUnchecked = shrinkUncheckedWord (\(W# w#) -> W8# w#) (\(W8# w#) -> W# w#) instance GenValid Word8 where genValid = genWordX shrinkValid = shrink instance GenUnchecked Word16 where genUnchecked = genUncheckedWord (W16#) shrinkUnchecked = shrinkUncheckedWord (\(W# w#) -> W16# w#) (\(W16# w#) -> W# w#) instance GenValid Word16 where genValid = genWordX shrinkValid = shrink instance GenUnchecked Word32 where genUnchecked = genUncheckedWord (W32#) shrinkUnchecked = shrinkUncheckedWord (\(W# w#) -> W32# w#) (\(W32# w#) -> W# w#) instance GenValid Word32 where genValid = genWordX shrinkValid = shrink instance GenUnchecked Word64 where genUnchecked = genWordX shrinkUnchecked = shrink instance GenValid Word64 where genValid = genUnchecked shrinkValid = shrinkUnchecked instance GenUnchecked Float where genUnchecked = genFloat #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 = genDouble #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 = genInteger shrinkUnchecked = shrink instance GenValid Integer #if MIN_VERSION_base(4,8,0) instance GenUnchecked Natural where genUnchecked = fromInteger . abs <$> genUnchecked shrinkUnchecked = fmap (fromInteger . abs) . shrinkUnchecked . toInteger 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 = (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 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.11.0.0/src/Data/GenValidity/Utils.hs0000644000000000000000000002643513645110574017767 0ustar0000000000000000{-# 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 {-# 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 , genSplit6 , genSplit7 , genSplit8 , arbPartition , shuffle , genListLength , genListOf #if MIN_VERSION_base(4,9,0) , 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#) import Data.Ratio #if !MIN_VERSION_QuickCheck(2,8,0) import Data.List (sortBy) import Data.Ord (comparing) #endif #if MIN_VERSION_base(4,9,0) import Data.List.NonEmpty(NonEmpty(..)) import qualified Data.List.NonEmpty as NE #endif #if MIN_VERSION_base(4,8,0) import Control.Monad (forM, replicateM) #else import Control.Applicative ((<$>), (<*>), pure) import Control.Monad (forM, replicateM) #endif -- | 'upTo' generates an integer between 0 (inclusive) and 'n'. upTo :: Int -> Gen Int upTo n | n <= 0 = pure 0 | otherwise = choose (0, n) -- | 'genSplit a' generates a tuple '(b, c)' such that 'b + c' equals 'a'. genSplit :: Int -> Gen (Int, Int) genSplit n | n < 0 = pure (0, 0) | otherwise = do i <- choose (0, n) let j = n - i pure (i, j) -- | 'genSplit3 a' generates a triple '(b, c, d)' such that 'b + c + d' equals 'a'. genSplit3 :: Int -> Gen (Int, Int, Int) genSplit3 n | n < 0 = pure (0, 0, 0) | otherwise = do (a, z) <- genSplit n (b, c) <- genSplit z return (a, b, c) -- | 'genSplit4 a' generates a quadruple '(b, c, d, e)' such that 'b + c + d + e' equals 'a'. genSplit4 :: Int -> Gen (Int, Int, Int, Int) genSplit4 n | n < 0 = pure (0, 0, 0, 0) | otherwise = do (y, z) <- genSplit n (a, b) <- genSplit y (c, d) <- genSplit z return (a, b, c, d) -- | 'genSplit5 a' generates a quintuple '(b, c, d, e, f)' such that 'b + c + d + e + f' equals 'a'. genSplit5 :: Int -> Gen (Int, Int, Int, Int, Int) genSplit5 n | n < 0 = pure (0, 0, 0, 0, 0) | otherwise = do (y, z) <- genSplit n (a, b, c) <- genSplit3 y (d, e) <- genSplit z return (a, b, c, d, e) -- | 'genSplit6 a' generates a sextuple '(b, c, d, e, f, g)' such that 'b + c + d + e + f + g' equals 'a'. genSplit6 :: Int -> Gen (Int, Int, Int, Int, Int, Int) genSplit6 n | n < 0 = pure (0, 0, 0, 0, 0, 0) | otherwise = do (y, z) <- genSplit n (a, b, c) <- genSplit3 y (d, e, f) <- genSplit3 z return (a, b, c, d, e, f) -- | 'genSplit7 a' generates a septtuple '(b, c, d, e, f, g)' such that 'b + c + d + e + f + g' equals 'a'. genSplit7 :: Int -> Gen (Int, Int, Int, Int, Int, Int, Int) genSplit7 n | n < 0 = pure (0, 0, 0, 0, 0, 0, 0) | otherwise = do (y, z) <- genSplit n (a, b, c) <- genSplit3 y (d, e, f, g) <- genSplit4 z return (a, b, c, d, e, f, g) -- | 'genSplit8 a' generates a octtuple '(b, c, d, e, f, g, h)' such that 'b + c + d + e + f + g + h' equals 'a'. genSplit8 :: Int -> Gen (Int, Int, Int, Int, Int, Int, Int, Int) genSplit8 n | n < 0 = pure (0, 0, 0, 0, 0, 0, 0, 0) | otherwise = do (y, z) <- genSplit n (a, b, c, d) <- genSplit4 y (e, f, g, h) <- genSplit4 z return (a, b, c, d, e, f, g, h) -- | 'arbPartition n' generates a list 'ls' such that 'sum ls' equals 'n', approximately. arbPartition :: Int -> Gen [Int] arbPartition 0 = pure [] arbPartition i = genListLengthWithSize i >>= go i where go :: Int -> Int -> Gen [Int] go size len = do us <- replicateM len $ choose (0, 1) let invs = map (invE 0.25) us -- Rescale the sizes to (approximately) sum to the given size. pure $ map (round . (* (fromIntegral size / sum invs))) invs -- Use an exponential distribution for generating the -- sizes in the partition. invE :: Double -> Double -> Double invE lambda u = - log (1 - u) / lambda #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 #if MIN_VERSION_base(4,9,0) genNonEmptyOf :: Gen a -> Gen (NonEmpty a) genNonEmptyOf gen = do l <- genListOf gen case NE.nonEmpty l of Nothing -> scale (+1) $ genNonEmptyOf gen Just ne -> pure ne #endif -- Uses 'genListLengthWithSize' with the size parameter genListLength :: Gen Int genListLength = sized genListLengthWithSize -- Generate a list length with the given size genListLengthWithSize :: Int -> Gen Int genListLengthWithSize maxLen = round . invT (fromIntegral maxLen) <$> choose (0, 1) where -- Use a triangle distribution for generating the -- length of the list -- with minimum length '0', mode length '2' -- and given max length. invT :: Double -> Double -> Double invT m u = let a = 0 b = m c = 2 fc = (c - a) / (b - a) in if u < fc then a + sqrt (u * (b - a) * (c - a) ) else b - sqrt ((1 - u) * (b - a) * (b - c)) -- | A version of @listOf@ that takes size into account more accurately. -- -- This generator distributes the size that is is given among the values -- in the list that it generates. genListOf :: Gen a -> Gen [a] genListOf func = sized $ \n -> do pars <- arbPartition n forM pars $ \i -> resize i func 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 ] -- | 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 -- | Generate Int, Int8, Int16, Int32 and Int64 values smartly. -- -- * Some at the border -- * Some around zero -- * Mostly uniformly genIntX :: forall a. (Integral a, Bounded a, Random a) => Gen a genIntX = frequency [ (1, extreme) , (1, small) , (8, uniform) ] where extreme :: Gen a extreme = sized $ \s -> oneof [ choose (maxBound - fromIntegral s, maxBound) , choose (minBound, minBound + fromIntegral s) ] small :: Gen a small = sized $ \s -> choose (- fromIntegral s, fromIntegral s) uniform :: Gen a uniform = choose (minBound, maxBound) -- | Generate Word, Word8, Word16, Word32 and Word64 values smartly. -- -- * Some at the border -- * Some around zero -- * Mostly uniformly genWordX :: forall a. (Integral a, Bounded a, Random a) => Gen a genWordX = frequency [ (1, extreme) , (1, small) , (8, uniform) ] where extreme :: Gen a extreme = sized $ \s -> choose (maxBound - fromIntegral s, maxBound) small :: Gen a small = sized $ \s -> choose (0, fromIntegral s) uniform :: Gen a uniform = choose (minBound, maxBound) -- | See 'genFloatX' genFloat :: Gen Float genFloat = genFloatX castWord32ToFloat -- | See 'genFloatX' genDouble :: Gen Double genDouble = genFloatX castWord64ToDouble -- | Generate floating point numbers smartly: -- -- * Some denormalised -- * Some around zero -- * Some around the bounds -- * Some by encoding an Integer and an Int to a floating point number. -- * Some accross the entire range -- * Mostly uniformly via the bitrepresentation -- -- The function parameter is to go from the bitrepresentation to the floating point value. genFloatX :: forall a w. (Read a, RealFloat a, Bounded w, Random w) => (w -> a) -> Gen a genFloatX func = frequency [ (1, denormalised) , (1, small) , (1, aroundBounds) , (1, viaEncoding) , (1, uniformViaEncoding) , (5, reallyUniform) ] where denormalised :: Gen a denormalised = elements [ read "NaN" , read "Infinity" , read "-Infinity" , read "-0" ] -- This is what Quickcheck does, -- but inlined so QuickCheck cannot change -- it behind the scenes in the future. small :: Gen a small = sized $ \n -> do let n' = toInteger n let precision = 9999999999999 :: Integer b <- choose (1, precision) a <- choose ((-n') * b, n' * b) pure (fromRational (a % b)) upperSignificand :: Integer upperSignificand = floatRadix (0.0 :: a) ^ floatDigits (0.0 :: a) lowerSignificand :: Integer lowerSignificand = - upperSignificand (lowerExponent, upperExponent) = floatRange (0.0 :: a) aroundBounds :: Gen a aroundBounds = do s <- sized $ \n -> oneof [ choose (lowerSignificand, lowerSignificand + fromIntegral n) , choose (upperSignificand - fromIntegral n, upperSignificand) ] e <- sized $ \n -> oneof [ choose (lowerExponent, lowerExponent + n) , choose (upperExponent - n, upperExponent) ] pure $ encodeFloat s e viaEncoding :: Gen a viaEncoding = encodeFloat <$> arbitrary <*> genIntX uniformViaEncoding :: Gen a uniformViaEncoding = do s <- choose (lowerSignificand, upperSignificand) e <- choose $ floatRange (0.0 :: a) pure $ encodeFloat s e -- Not really uniform, but good enough reallyUniform :: Gen a reallyUniform = func <$> choose (minBound, maxBound) genInteger :: Gen Integer genInteger = sized $ \s -> oneof $ (if s >= 10 then (genBiggerInteger :) else id) [ genIntSizedInteger , small ] where small = sized $ \s -> choose (- toInteger s, toInteger s) genIntSizedInteger = toInteger <$> (genIntX :: Gen Int) genBiggerInteger = sized $ \s ->do (a, b, c) <- genSplit3 s ai <- resize a genIntSizedInteger bi <- resize b genInteger ci <- resize c genIntSizedInteger pure $ ai * bi + ci genUncheckedInt :: (Int# -> a) -> Gen a genUncheckedInt func = do (I# i#) <- genIntX pure $ func i# shrinkUncheckedInt :: (Int -> a) -> (a -> Int) -> a -> [a] shrinkUncheckedInt fromInt toInt = fmap fromInt . shrink . toInt genUncheckedWord :: (Word# -> a) -> Gen a genUncheckedWord func = do (W# w#) <- genWordX pure $ func w# shrinkUncheckedWord :: (Word -> a) -> (a -> Word) -> a -> [a] shrinkUncheckedWord fromWord toWord = fmap fromWord . shrink . toWord genvalidity-0.11.0.0/test/Spec.hs0000644000000000000000000000005413644617172014653 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} genvalidity-0.11.0.0/test/Data/GenValidity/GenericSpec.hs0000644000000000000000000000564313644617172021251 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 Ordering)) genValidstructurallySpec (Proxy :: Proxy MyType) describe "shrinkValidStructurally" $ do shrinkValidstructurallySpec (Proxy :: Proxy Bool) shrinkValidstructurallySpec (Proxy :: Proxy Ordering) shrinkValidstructurallySpec (Proxy :: Proxy (Maybe Double)) shrinkValidstructurallySpec (Proxy :: Proxy (Either Double Ordering)) shrinkValidstructurallySpec (Proxy :: Proxy MyType) genValidstructurallySpec :: forall a. (Validity a, Show a, 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 Ordering deriving (Show, Eq, Generic, Typeable) instance Validity MyType instance GenUnchecked MyType instance GenValid MyType genvalidity-0.11.0.0/test/Data/GenValidity/ShrinkGenericSpec.hs0000644000000000000000000000402313644617172022417 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.11.0.0/test/Data/GenValiditySpec.hs0000644000000000000000000000616713644617172017677 0ustar0000000000000000module Data.GenValiditySpec ( spec ) where 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) genvalidity-0.11.0.0/test/Data/InstanceSpec.hs0000644000000000000000000001624113644617172017216 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 (Ratio Int)) modifyMaxSuccess (`quot` 2) $ modifyMaxSize (`quot` 2) $ twoTests (Proxy :: Proxy (Either Bool Ordering)) twoTests (Proxy :: Proxy (Maybe Ordering)) twoTests (Proxy :: Proxy (Maybe (Maybe (Ordering)))) threeTests (Proxy :: Proxy (Ratio Integer)) -- threeTupleTests (Proxy :: Proxy (Ratio Integer)) threeTests (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 describe "shrinking (Ratio Int8)" $ it "can shrink this example" $ let v = ((-128) % 113) :: Ratio Int8 in v `notElem` shrinkValid v twoTests (Proxy :: Proxy Uni) twoTupleTests (Proxy :: Proxy Uni) twoTests (Proxy :: Proxy Deci) twoTupleTests (Proxy :: Proxy Deci) twoTests (Proxy :: Proxy Centi) twoTupleTests (Proxy :: Proxy Centi) twoTests (Proxy :: Proxy Milli) twoTupleTests (Proxy :: Proxy Milli) twoTests (Proxy :: Proxy Micro) twoTupleTests (Proxy :: Proxy Micro) twoTests (Proxy :: Proxy Nano) twoTupleTests (Proxy :: Proxy Nano) twoTests (Proxy :: Proxy Pico) twoTupleTests (Proxy :: Proxy Pico) #if MIN_VERSION_base(4,8,0) twoTests (Proxy :: Proxy Natural) twoTupleTests (Proxy :: Proxy Natural) #endif #if MIN_VERSION_base(4,9,0) twoTests (Proxy :: Proxy (NonEmpty Ordering)) #endif twoTupleTests :: forall a. (Show a, Eq a, Typeable a, GenUnchecked a, GenValid a) => Proxy a -> Spec twoTupleTests proxy = do modifyMaxSuccess (`quot` 2) $ modifyMaxSize (`quot` 2) $ twoTests $ (,) <$> proxy <*> proxy twoTests :: forall a. (Show a, Eq a, Typeable a, GenUnchecked a, GenValid a) => Proxy a -> Spec twoTests proxy = describe (nameOf proxy) $ do genUncheckedTest proxy genValidTest proxy threeTests :: forall a. (Show a, Eq a, Typeable a, GenUnchecked a, GenValid a, GenInvalid a) => Proxy a -> Spec threeTests proxy = describe (nameOf proxy) $ do genUncheckedTest proxy genValidTest proxy genInvalidTest proxy genUncheckedTest :: 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 -> 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.11.0.0/LICENSE0000644000000000000000000000210413644617172013451 0ustar0000000000000000The MIT License (MIT) Copyright (c) 2016-2020 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.11.0.0/Setup.hs0000644000000000000000000000005713644617172014105 0ustar0000000000000000import Distribution.Simple main = defaultMain genvalidity-0.11.0.0/genvalidity.cabal0000644000000000000000000000542313644705444015756 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- -- hash: a5dc5e1588ff412e964237d33283651af0936a55506c5f8e6919d2ab901c77ec name: genvalidity version: 0.11.0.0 synopsis: Testing utilities for the validity library description: Note: There are companion instance packages for this library: . * . * . * . * . * . * . * . * . * . * category: Testing homepage: https://github.com/NorfairKing/validity#readme bug-reports: https://github.com/NorfairKing/validity/issues author: Tom Sydney Kerckhove maintainer: syd@cs-syd.eu copyright: Copyright: (c) 2016-2020 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.GenRelativeValidity Data.GenValidity Data.GenValidity.Utils other-modules: Paths_genvalidity hs-source-dirs: src build-depends: QuickCheck >=2.7 , base >=4.10 && <5 , random , 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 build-depends: QuickCheck , base >=4.10 && <5 , genvalidity , hspec , hspec-core default-language: Haskell2010