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