diff --git a/genvalidity.cabal b/genvalidity.cabal --- a/genvalidity.cabal +++ b/genvalidity.cabal @@ -1,5 +1,5 @@ name: genvalidity -version: 0.3.2.0 +version: 0.4.0.0 cabal-version: >=1.10 build-type: Simple license: MIT @@ -11,13 +11,26 @@ description: Note: There are companion instance packages for this library: . - * + * . - * + * . * . * + . + * + . + * + . + * + . + * + . + * + . + * + . category: Testing author: Tom Sydney Kerckhove @@ -26,17 +39,18 @@ location: https://github.com/NorfairKing/validity library + + if impl(ghc >=8.0.0) + ghc-options: -Wno-redundant-constraints exposed-modules: Data.GenValidity Data.GenRelativeValidity build-depends: - base >= 4.7 && <5, - validity >=0.3 && <0.4, + base >=4.7 && <5, + validity >=0.4 && <0.5, QuickCheck >=2.7 && <2.10 default-language: Haskell2010 hs-source-dirs: src - if impl(ghc >= 8.0.0) - ghc-options: -Wno-redundant-constraints test-suite genvalidity-test type: exitcode-stdio-1.0 @@ -44,7 +58,7 @@ build-depends: base -any, hspec -any, - QuickCheck, + QuickCheck -any, genvalidity -any default-language: Haskell2010 hs-source-dirs: test diff --git a/src/Data/GenValidity.hs b/src/Data/GenValidity.hs --- a/src/Data/GenValidity.hs +++ b/src/Data/GenValidity.hs @@ -33,19 +33,27 @@ Typical examples of tests involving validity could look as follows: > it "succeeds when given valid input" $ do - > forAll genValid $ \input -> + > forAllValid $ \input -> > myFunction input `shouldSatisfy` isRight > it "produces valid output when it succeeds" $ do - > forAll genUnchecked $ \input -> + > forAllUnchecked $ \input -> > case myFunction input of > Nothing -> return () -- Can happen > Just output -> output `shouldSatisfy` isValid -} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 710 +#define OVERLAPPING_ {-# OVERLAPPING #-} +#else +{-# LANGUAGE OverlappingInstances #-} +#define OVERLAPPING_ +#endif module Data.GenValidity ( module Data.Validity @@ -55,22 +63,49 @@ import Data.Validity import Data.Fixed (Fixed(..), HasResolution) -import Data.Word (Word, Word8, Word16) +import Data.Word (Word, Word8, Word16, Word32, Word64) import GHC.Generics import GHC.Real (Ratio(..)) import Test.QuickCheck hiding (Fixed) -import Control.Applicative ((<$>), pure) +import Control.Applicative ((<*>), (<$>), pure) import Control.Monad (forM) +{-# ANN module "HLint: ignore Reduce duplication" #-} + -- | A class of types for which truly arbitrary values can be generated. +-- +-- === Automatic instances with 'Generic' +-- 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 Double String +-- > deriving (Show, Eq, Generic) +-- > +-- > instance GenUnchecked MyType +-- +-- generates something like: +-- +-- > instance GenUnchecked MyType where +-- > genUnchecked = MyType <$> genUnchecked <*> genUnchecked class GenUnchecked a where genUnchecked :: Gen a default genUnchecked :: (Generic a, GGenUnchecked (Rep a)) => Gen a genUnchecked = to <$> gGenUnchecked + shrinkUnchecked :: a -> [a] + default shrinkUnchecked :: + (Generic a, GUncheckedRecursivelyShrink (Rep a), GUncheckedSubterms (Rep a) a) => + a -> [a] + shrinkUnchecked = gShrinkUnchecked + -- | A class of types for which valid values can be generated. -- -- If you also write @Arbitrary@ instances for @GenValid@ types, it may be @@ -90,6 +125,9 @@ -- data, otherwise your testing may not cover all cases. genValid = genUnchecked `suchThat` isValid + shrinkValid :: a -> [a] + shrinkValid = filter isValid . shrinkUnchecked + -- | A class of types for which invalid values can be generated. class (Validity a, GenUnchecked a) => GenInvalid a where @@ -97,15 +135,17 @@ -- | Generate an invalid datum, this should cover all possible invalid -- values -- - -- > genInvalid = genUnchecked `suchThat` (not . isValid) + -- > genInvalid = genUnchecked `suchThat` isInvalid -- -- To speed up testing, it may be a good idea to implement this yourself. -- If you do, make sure that it is possible to generate all possible -- invalid data, otherwise your testing may not cover all cases. - genInvalid = genUnchecked `suchThat` (not . isValid) + genInvalid = genUnchecked `suchThat` isInvalid -instance (GenUnchecked a, GenUnchecked b) => - GenUnchecked (a, b) where + shrinkInvalid :: a -> [a] + shrinkInvalid = filter isInvalid . shrinkUnchecked + +instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (a, b) where genUnchecked = sized $ \n -> do (r, s) <- genSplit n @@ -113,8 +153,7 @@ b <- resize s genUnchecked return (a, b) -instance (GenValid a, GenValid b) => - GenValid (a, b) where +instance (GenValid a, GenValid b) => GenValid (a, b) where genValid = sized $ \n -> do (r, s) <- genSplit n @@ -122,8 +161,7 @@ b <- resize s genValid return (a, b) -instance (GenInvalid a, GenInvalid b) => - GenInvalid (a, b) where +instance (GenInvalid a, GenInvalid b) => GenInvalid (a, b) where genInvalid = sized $ \n -> do (r, s) <- genSplit n @@ -136,17 +174,14 @@ return (a, b) ] -instance (GenUnchecked a, GenUnchecked b) => - GenUnchecked (Either a b) where +instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (Either a b) where genUnchecked = oneof [Left <$> genUnchecked, Right <$> genUnchecked] -instance (GenValid a, GenValid b) => - GenValid (Either a b) where +instance (GenValid a, GenValid b) => GenValid (Either a b) where genValid = oneof [Left <$> genValid, Right <$> genValid] -- | 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 +instance (GenInvalid a, GenInvalid b) => GenInvalid (Either a b) where genInvalid = oneof [Left <$> genInvalid, Right <$> genInvalid] instance (GenUnchecked a, GenUnchecked b, GenUnchecked c) => @@ -159,8 +194,7 @@ c <- resize t genUnchecked return (a, b, c) -instance (GenValid a, GenValid b, GenValid c) => - GenValid (a, b, c) where +instance (GenValid a, GenValid b, GenValid c) => GenValid (a, b, c) where genValid = sized $ \n -> do (r, s, t) <- genSplit3 n @@ -190,32 +224,78 @@ return (a, b, c) ] -instance GenUnchecked a => - GenUnchecked (Maybe a) where +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) + +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) + +-- | This instance ensures that the generated triple contains at least one invalid element. The other two are unchecked. +instance (GenInvalid a, GenInvalid b, GenInvalid c, GenInvalid d) => + GenInvalid (a, b, c, d) where + genInvalid = + sized $ \n -> do + (r, s, t, u) <- genSplit4 n + oneof + [ do a <- resize r genInvalid + b <- resize s genUnchecked + c <- resize t genUnchecked + d <- resize u genUnchecked + return (a, b, c, d) + , do a <- resize r genUnchecked + b <- resize s genInvalid + c <- resize t genUnchecked + d <- resize u genUnchecked + return (a, b, c, d) + , do a <- resize r genUnchecked + b <- resize s genUnchecked + c <- resize t genInvalid + d <- resize u genUnchecked + return (a, b, c, d) + , do a <- resize r genUnchecked + b <- resize s genUnchecked + c <- resize t genUnchecked + d <- resize u genInvalid + return (a, b, c, d) + ] + +instance GenUnchecked a => GenUnchecked (Maybe a) where genUnchecked = oneof [pure Nothing, Just <$> genUnchecked] -instance GenValid a => - GenValid (Maybe a) where +instance GenValid a => GenValid (Maybe a) where genValid = oneof [pure Nothing, Just <$> genValid] -instance GenInvalid a => - GenInvalid (Maybe a) where +instance GenInvalid a => GenInvalid (Maybe a) where genInvalid = Just <$> genInvalid -instance GenUnchecked a => - GenUnchecked [a] where +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 +instance GenValid a => GenValid [a] where genValid = genListOf genValid -- | This instance ensures that the generated list contains at least one element -- that satisfies 'isInvalid'. The rest is unchecked. -instance GenInvalid a => - GenInvalid [a] where +instance GenInvalid a => GenInvalid [a] where genInvalid = sized $ \n -> do (x, y, z) <- genSplit3 n @@ -226,46 +306,67 @@ instance GenUnchecked () where genUnchecked = arbitrary + shrinkUnchecked = shrink instance GenValid () instance GenUnchecked Bool where genUnchecked = arbitrary + shrinkUnchecked = shrink instance GenValid Bool instance GenUnchecked Ordering where genUnchecked = arbitrary + shrinkUnchecked = shrink instance GenValid Ordering instance GenUnchecked Char where genUnchecked = arbitrary + shrinkUnchecked = shrink instance GenValid Char instance GenUnchecked Int where genUnchecked = arbitrary + shrinkUnchecked = shrink instance GenValid Int instance GenUnchecked Word where genUnchecked = arbitrary + shrinkUnchecked = shrink instance GenValid Word instance GenUnchecked Word8 where genUnchecked = arbitrary + shrinkUnchecked = shrink instance GenValid Word8 instance GenUnchecked Word16 where genUnchecked = arbitrary + shrinkUnchecked = shrink instance GenValid Word16 +instance GenUnchecked Word32 where + genUnchecked = arbitrary + shrinkUnchecked = shrink + +instance GenValid Word32 + +instance GenUnchecked Word64 where + genUnchecked = arbitrary + shrinkUnchecked = shrink + +instance GenValid Word64 + instance GenUnchecked Float where genUnchecked = arbitrary + shrinkUnchecked = shrink instance GenValid Float where genValid = arbitrary @@ -276,6 +377,7 @@ instance GenUnchecked Double where genUnchecked = arbitrary + shrinkUnchecked = shrink instance GenValid Double @@ -285,6 +387,7 @@ instance GenUnchecked Integer where genUnchecked = arbitrary + shrinkUnchecked = shrink instance GenValid Integer @@ -293,16 +396,27 @@ n <- genUnchecked d <- genUnchecked pure $ n :% d + shrinkUnchecked = shrink instance GenValid (Ratio Integer) -instance HasResolution a => - GenUnchecked (Fixed a) where +instance HasResolution a => GenUnchecked (Fixed a) where genUnchecked = MkFixed <$> genUnchecked + shrinkUnchecked = shrink -instance HasResolution a => - GenValid (Fixed a) +instance HasResolution a => GenValid (Fixed a) +shrinkT2 + :: (a -> [a]) + -> (a, a) -> [(a, a)] +shrinkT2 s (a, b) = (,) <$> s a <*> s b + +shrinkT3 + :: (a -> [a]) + -> (a, a, a) -> [(a, a, a)] +shrinkT3 s (a, b, c) = (,,) <$> s a <*> s b <*> s c + + -- | 'upTo' generates an integer between 0 (inclusive) and 'n'. upTo :: Int -> Gen Int upTo n @@ -313,9 +427,12 @@ genSplit :: Int -> Gen (Int, Int) genSplit n | n < 0 = pure (0, 0) - | otherwise = elements [(i, n - i) | i <- [0 .. n]] + | otherwise = do + i <- choose (0, n) + let j = n - i + pure (i, j) --- | 'genSplit a' generates a triple '(b, c, d)' such that 'b + c + d' equals 'a'. +-- | '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) @@ -324,6 +441,16 @@ (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) + -- | 'arbPartition n' generates a list 'ls' such that 'sum ls' equals 'n'. arbPartition :: Int -> Gen [Int] arbPartition k @@ -347,21 +474,108 @@ instance GGenUnchecked U1 where gGenUnchecked = pure U1 -instance (GGenUnchecked a, GGenUnchecked b) => - GGenUnchecked (a :*: b) where +instance (GGenUnchecked a, GGenUnchecked b) => GGenUnchecked (a :*: b) where gGenUnchecked = do g1 <- gGenUnchecked g2 <- gGenUnchecked pure $ g1 :*: g2 -instance (GGenUnchecked a, GGenUnchecked b) => - GGenUnchecked (a :+: b) where +instance (GGenUnchecked a, GGenUnchecked b) => GGenUnchecked (a :+: b) where gGenUnchecked = oneof [L1 <$> gGenUnchecked, R1 <$> gGenUnchecked] -instance (GGenUnchecked a) => - GGenUnchecked (M1 i c a) where +instance (GGenUnchecked a) => GGenUnchecked (M1 i c a) where gGenUnchecked = M1 <$> gGenUnchecked -instance (GenUnchecked a) => - GGenUnchecked (K1 i a) where +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. +gShrinkUnchecked :: (Generic a, GUncheckedRecursivelyShrink (Rep a), GUncheckedSubterms (Rep a) a) => a -> [a] +gShrinkUnchecked 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) = + [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 _) = [] + diff --git a/test/Data/GenValiditySpec.hs b/test/Data/GenValiditySpec.hs --- a/test/Data/GenValiditySpec.hs +++ b/test/Data/GenValiditySpec.hs @@ -9,26 +9,26 @@ spec :: Spec spec = do - describe "upTo" $ do - it "returns only positive integers" $ do + describe "upTo" $ + it "returns only positive integers" $ forAll arbitrary $ \n -> forAll (upTo n) (`shouldSatisfy` (>= 0)) describe "genSplit" $ do - it "returns positive integers" $ 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" $ do + it "returns two integers such that the sum is the original integer" $ forAll (arbitrary `suchThat` (>= 0)) $ \i -> forAll (genSplit i) $ \(a, b) -> a + b `shouldBe` i describe "arbPartition" $ do - it "returns an empty list upon strictly negative input" $ do + it "returns an empty list upon strictly negative input" $ forAll (arbitrary `suchThat` (< 0)) $ \n -> forAll (arbPartition n) (`shouldBe` []) - it "returns a list of strictly positive integers" $ do + it "returns a list of strictly positive integers" $ forAll arbitrary $ \n -> forAll (arbPartition n) $ \p -> p `shouldSatisfy` all (> 0) it - "returns a list of integers that sum to the original positive integer" $ do + "returns a list of integers that sum to the original positive integer" $ forAll (arbitrary `suchThat` (>= 0)) $ \n -> forAll (arbPartition n) $ \p -> sum p `shouldBe` n