diff --git a/genvalidity-hspec.cabal b/genvalidity-hspec.cabal --- a/genvalidity-hspec.cabal +++ b/genvalidity-hspec.cabal @@ -1,7 +1,13 @@ name: genvalidity-hspec -version: 0.2.0.5 +version: 0.3.0.0 synopsis: Standard spec's for GenValidity instances -description: Please see README.md +description: + Note: There are companion packages for this library: + . + * + . + * + homepage: https://github.com/NorfairKing/validity#readme license: MIT license-file: LICENSE @@ -10,42 +16,46 @@ copyright: Copyright: (c) 2016 Tom Sydney Kerckhove category: Testing build-type: Simple --- extra-source-files: cabal-version: >=1.10 library hs-source-dirs: src exposed-modules: Test.Validity + , Test.Validity.Applicative , Test.Validity.Arbitrary , Test.Validity.Eq - , Test.Validity.Ord , Test.Validity.Functions , Test.Validity.Functions.CanFail , Test.Validity.Functions.Equivalence , Test.Validity.Functions.Idempotence , Test.Validity.Functions.Inverse , Test.Validity.Functions.Validity - , Test.Validity.GenValidity + , Test.Validity.Functor , Test.Validity.GenRelativeValidity + , Test.Validity.GenValidity + , Test.Validity.Monad + , Test.Validity.Monoid , Test.Validity.Operations - , Test.Validity.Operations.Identity , Test.Validity.Operations.Associativity , Test.Validity.Operations.Commutativity + , Test.Validity.Operations.Identity + , Test.Validity.Ord , Test.Validity.Relations + , Test.Validity.Relations.Antireflexivity , Test.Validity.Relations.Antisymmetry , Test.Validity.Relations.Reflexivity , Test.Validity.Relations.Symmetry , Test.Validity.Relations.Transitivity , Test.Validity.RelativeValidity , Test.Validity.Types - other-modules: - Test.Validity.Utils - build-depends: base < 5 - , validity >= 0.3 && < 0.4 - , genvalidity - , QuickCheck - , hspec >= 2.2 && < 2.3 + , Test.Validity.Utils + build-depends: + base < 5 + , validity >= 0.3 && < 0.4 + , genvalidity >= 0.3 && < 0.4 + , QuickCheck + , hspec >= 2.2 && < 2.4 default-language: Haskell2010 @@ -58,6 +68,30 @@ build-depends: base , doctest >= 0.11 && < 0.12 , genvalidity-hspec + +test-suite genvalidity-hspec-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Validity.ApplicativeSpec + , Test.Validity.ArbitrarySpec + , Test.Validity.EqSpec + , Test.Validity.FunctorSpec + , Test.Validity.GenRelativeValiditySpec + , Test.Validity.GenValiditySpec + , Test.Validity.MonoidSpec + , Test.Validity.MonadSpec + , Test.Validity.OrdSpec + , Test.Validity.RelativeValiditySpec + build-depends: + base >=4.9 && <=5, + genvalidity >= 0.3 && < 0.4, + genvalidity-hspec, + hspec >= 2.2 && < 2.3 + default-language: Haskell2010 + hs-source-dirs: test/ + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + source-repository head type: git diff --git a/src/Test/Validity.hs b/src/Test/Validity.hs --- a/src/Test/Validity.hs +++ b/src/Test/Validity.hs @@ -1,34 +1,29 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | To use the 'Spec' functions in this module, you will need @TypeApplications@. module Test.Validity ( module Data.GenValidity - , Proxy(Proxy) - -- * Tests for Arbitrary instances involving Validity , arbitrarySpec , arbitraryGeneratesOnlyValid - , shrinkProducesOnlyValids - -- * Tests for GenValidity instances , genValiditySpec - , genValidityValidGeneratesValid + , genValidSpec + , genInvalidSpec + , genValidGeneratesValid , genGeneratesValid - , genValidityInvalidGeneratesInvalid + , genInvalidGeneratesInvalid , genGeneratesInvalid - -- * Tests for RelativeValidity instances , relativeValiditySpec , relativeValidityImpliesValidA , relativeValidityImpliesValidB - -- * Tests for GenRelativeValidity instances , genRelativeValiditySpec - , genRelativeValidityValidGeneratesValid - , genRelativeValidityInvalidGeneratesInvalid - - + , genRelativeValidGeneratesValid + , genRelativeInvalidGeneratesInvalid -- * Standard tests involving functions - -- ** Standard tests involving validity , producesValidsOnGen , producesValidsOnValids @@ -42,62 +37,78 @@ , producesValidsOnValids3 , producesValid3 , producesValidsOnArbitrary3 - -- ** Standard tests involving functions that can fail , CanFail(..) - , succeedsOnGen , succeedsOnValid , succeeds , succeedsOnArbitrary - , succeedsOnGens2 , succeedsOnValids2 , succeeds2 , succeedsOnArbitrary2 - , failsOnGen , failsOnInvalid - , failsOnGens2 , failsOnInvalid2 - , validIfSucceedsOnGen , validIfSucceedsOnValid , validIfSucceedsOnArbitrary , validIfSucceeds - , validIfSucceedsOnGens2 , validIfSucceedsOnValids2 , validIfSucceeds2 , validIfSucceedsOnArbitrary2 - -- ** Standard tests involving equivalence of functions + -- *** Simple functions + -- **** One argument , equivalentOnGen , equivalentOnValid , equivalent + , equivalentOnArbitrary + -- **** Two arguments , equivalentOnGens2 , equivalentOnValids2 , equivalent2 + , equivalentOnArbitrary2 + -- **** Three arguments + , equivalentOnGens3 + , equivalentOnValids3 + , equivalent3 + , equivalentOnArbitrary3 + -- *** First function can fail + -- **** One argument , equivalentWhenFirstSucceedsOnGen , equivalentWhenFirstSucceedsOnValid , equivalentWhenFirstSucceeds + , equivalentWhenFirstSucceedsOnArbitrary + -- **** Two arguments , equivalentWhenFirstSucceedsOnGens2 , equivalentWhenFirstSucceedsOnValids2 , equivalentWhenFirstSucceeds2 + , equivalentWhenFirstSucceedsOnArbitrary2 + -- *** Second function can fail + -- **** One argument , equivalentWhenSecondSucceedsOnGen , equivalentWhenSecondSucceedsOnValid , equivalentWhenSecondSucceeds + , equivalentWhenSecondSucceedsOnArbitrary + -- **** Two arguments , equivalentWhenSecondSucceedsOnGens2 , equivalentWhenSecondSucceedsOnValids2 , equivalentWhenSecondSucceeds2 + , equivalentWhenSecondSucceedsOnArbitrary2 + -- *** Both functions can fail + -- **** One argument , equivalentWhenSucceedOnGen , equivalentWhenSucceedOnValid , equivalentWhenSucceed + , equivalentWhenSucceedOnArbitrary + -- **** Two arguments , equivalentWhenSucceedOnGens2 , equivalentWhenSucceedOnValids2 , equivalentWhenSucceed2 - + , equivalentWhenSucceedOnArbitrary2 -- ** Standard tests involving inverse functions , inverseFunctionsOnGen , inverseFunctionsOnValid @@ -115,99 +126,120 @@ , inverseFunctionsIfSucceedOnValid , inverseFunctionsIfSucceed , inverseFunctionsIfSucceedOnArbitrary - -- ** Properties involving idempotence , idempotentOnGen , idempotentOnValid , idempotent , idempotentOnArbitrary - - -- * Properties of relations - -- ** Reflexivity , reflexiveOnElem , reflexivityOnGen , reflexivityOnValid , reflexivity , reflexivityOnArbitrary - -- ** Transitivity , transitiveOnElems , transitivityOnGens , transitivityOnValid , transitivity , transitivityOnArbitrary - -- ** Antisymmetry , antisymmetricOnElemsWithEquality , antisymmetryOnGensWithEquality - , antisymmetryOnGensEq + , antisymmetryOnGens , antisymmetryOnValid , antisymmetry , antisymmetryOnArbitrary - + -- ** Antireflexivity + , antireflexiveOnElem + , antireflexivityOnGen + , antireflexivityOnValid + , antireflexivity + , antireflexivityOnArbitrary -- ** Symmetry , symmetricOnElems , symmetryOnGens , symmetryOnValid , symmetry , symmetryOnArbitrary - - -- * Properties of operations - -- ** Identity element - -- *** Left Identity , leftIdentityOnElemWithEquality , leftIdentityOnGenWithEquality , leftIdentityOnGen , leftIdentityOnValid , leftIdentity - + , leftIdentityOnArbitrary -- *** Right Identity , rightIdentityOnElemWithEquality , rightIdentityOnGenWithEquality , rightIdentityOnGen , rightIdentityOnValid , rightIdentity - + , rightIdentityOnArbitrary -- *** Identity , identityOnGen , identityOnValid , identity - + , identityOnArbitrary -- ** Associativity , associativeOnGens , associativeOnValids , associative , associativeOnArbitrary - -- ** Commutativity , commutativeOnGens , commutativeOnValids , commutative , commutativeOnArbitrary - - -- * Eq properties + , eqSpecOnValid , eqSpec - + , eqSpecOnArbitrary + , eqSpecOnGen -- * Ord properties + , ordSpecOnGen + , ordSpecOnValid , ordSpec + , ordSpecOnArbitrary + -- * Monoid properties + , monoidSpecOnValid + , monoidSpec + , monoidSpecOnArbitrary + , monoidSpecOnGen + -- * Functor properties + , functorSpecOnValid + , functorSpec + , functorSpecOnArbitrary + , functorSpecOnGens + -- * Applicative properties + , applicativeSpecOnValid + , applicativeSpec + , applicativeSpecOnArbitrary + , applicativeSpecOnGens + -- * Monad properties + , monadSpecOnValid + , monadSpec + , monadSpecOnArbitrary + , monadSpecOnGens ) where -import Data.GenValidity -import Data.Data +import Data.Data +import Data.GenValidity -import Test.Validity.Arbitrary -import Test.Validity.Eq -import Test.Validity.Functions -import Test.Validity.GenRelativeValidity -import Test.Validity.GenValidity -import Test.Validity.Operations -import Test.Validity.Ord -import Test.Validity.Relations -import Test.Validity.RelativeValidity -import Test.Validity.Types +import Test.Validity.Arbitrary +import Test.Validity.Eq +import Test.Validity.Functions +import Test.Validity.Functor +import Test.Validity.Applicative +import Test.Validity.Monad +import Test.Validity.GenRelativeValidity +import Test.Validity.GenValidity +import Test.Validity.Monoid +import Test.Validity.Operations +import Test.Validity.Ord +import Test.Validity.Relations +import Test.Validity.RelativeValidity +import Test.Validity.Types diff --git a/src/Test/Validity/Applicative.hs b/src/Test/Validity/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Applicative.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Applicative properties +-- +-- You will need @TypeApplications@ to use these. +module Test.Validity.Applicative + ( applicativeSpecOnValid + , applicativeSpec + , applicativeSpecOnArbitrary + , applicativeSpecOnGens + ) where + +import Data.Data + +import Data.GenValidity + +import Test.Hspec +import Test.QuickCheck + +import Test.Validity.Functions +import Test.Validity.Operations +import Test.Validity.Relations +import Test.Validity.Utils + +pureTypeStr + :: forall (f :: * -> *). + (Typeable f) + => String +pureTypeStr = unwords ["pure", "::", "a", "->", nameOf @f, "a"] + +seqTypeStr + :: forall (f :: * -> *). + (Typeable f) + => String +seqTypeStr = + unwords + [ "(<*>)" + , "::" + , nameOf @f + , "(a" + , "->" + , "b)" + , "->" + , nameOf @f + , "a" + , "->" + , nameOf @f + , "b" + ] + +seqrTypeStr + :: forall (f :: * -> *). + (Typeable f) + => String +seqrTypeStr = + unwords + [ "(*>)" + , "::" + , nameOf @f + , "a" + , "->" + , nameOf @f + , "b" + , "->" + , nameOf @f + , "b" + ] + +seqlTypeStr + :: forall (f :: * -> *). + (Typeable f) + => String +seqlTypeStr = + unwords + [ "(<*)" + , "::" + , nameOf @f + , "a" + , "->" + , nameOf @f + , "b" + , "->" + , nameOf @f + , "a" + ] + +-- | Standard test spec for properties of Applicative instances for values generated with GenValid instances +-- +-- Example usage: +-- +-- > applicativeSpecOnArbitrary @[] +applicativeSpecOnValid + :: forall (f :: * -> *). + (Eq (f Int), Show (f Int), Applicative f, Typeable f, GenValid (f Int)) + => Spec +applicativeSpecOnValid = applicativeSpecWithInts @f genValid + +-- | Standard test spec for properties of Applicative instances for values generated with GenUnchecked instances +-- +-- Example usage: +-- +-- > applicativeSpecOnArbitrary @[] +applicativeSpec + :: forall (f :: * -> *). + ( Eq (f Int) + , Show (f Int) + , Applicative f + , Typeable f + , GenUnchecked (f Int) + ) + => Spec +applicativeSpec = applicativeSpecWithInts @f genUnchecked + +-- | Standard test spec for properties of Applicative instances for values generated with Arbitrary instances +-- +-- Example usage: +-- +-- > applicativeSpecOnArbitrary @[] +applicativeSpecOnArbitrary + :: forall (f :: * -> *). + (Eq (f Int), Show (f Int), Applicative f, Typeable f, Arbitrary (f Int)) + => Spec +applicativeSpecOnArbitrary = applicativeSpecWithInts @f arbitrary + +applicativeSpecWithInts + :: forall (f :: * -> *). + (Show (f Int), Eq (f Int), Applicative f, Typeable f) + => Gen (f Int) -> Spec +applicativeSpecWithInts gen = + applicativeSpecOnGens + @f + @Int + genUnchecked + "int" + gen + (unwords [nameOf @f, "of ints"]) + gen + (unwords [nameOf @f, "of ints"]) + ((+) <$> genUnchecked) + "increments" + (pure <$> ((+) <$> genUnchecked)) + (unwords [nameOf @f, "of increments"]) + (pure <$> ((*) <$> genUnchecked)) + (unwords [nameOf @f, "of scalings"]) + +-- | Standard test spec for properties of Applicative instances for values generated by given generators (and names for those generator). +-- +-- Unless you are building a specific regression test, you probably want to use the other 'applicativeSpec' functions. +-- +-- Example usage: +-- +-- > applicativeSpecOnGens +-- > @Maybe +-- > @String +-- > (pure "ABC") +-- > "ABC" +-- > (Just <$> pure "ABC") +-- > "Just an ABC" +-- > (pure Nothing) +-- > "purely Nothing" +-- > ((++) <$> genValid) +-- > "prepends" +-- > (pure <$> ((++) <$> genValid)) +-- > "prepends in a Just" +-- > (pure <$> (flip (++) <$> genValid)) +-- > "appends in a Just" +applicativeSpecOnGens + :: forall (f :: * -> *) (a :: *) (b :: *) (c :: *). + ( Show a + , Eq a + , Show (f a) + , Eq (f a) + , Show (f b) + , Eq (f b) + , Show (f c) + , Eq (f c) + , Applicative f + , Typeable f + , Typeable a + , Typeable b + , Typeable c + ) + => Gen a + -> String + -> Gen (f a) + -> String + -> Gen (f b) + -> String + -> Gen (a -> b) + -> String + -> Gen (f (a -> b)) + -> String + -> Gen (f (b -> c)) + -> String + -> Spec +applicativeSpecOnGens gena genaname gen genname genb genbname genfa genfaname genffa genffaname genffb genffbname = + parallel $ + describe ("Applicative " ++ nameOf @f) $ do + describe (unwords [pureTypeStr @f, "and", seqTypeStr @f]) $ do + it + (unwords + [ "satisfy the identity law: 'pure id <*> v = v' for" + , genDescr @(f a) genname + ]) $ + equivalentOnGen (pure id <*>) id gen + it + (unwords + [ "satisfy the composition law: 'pure (.) <*> u <*> v <*> w = u <*> (v <*> w)' for" + , genDescr @(f (b -> c)) genffbname + , "composed with" + , genDescr @(f (a -> b)) genffaname + , "and applied to" + , genDescr @(f a) genname + ]) $ + equivalentOnGens3 + (\(Anon u) (Anon v) w -> + pure (.) <*> (u :: f (b -> c)) <*> (v :: f (a -> b)) <*> + (w :: f a) :: f c) + (\(Anon u) (Anon v) w -> u <*> (v <*> w) :: f c) + ((,,) <$> (Anon <$> genffb) <*> (Anon <$> genffa) <*> gen) + it + (unwords + [ "satisfy the homomorphism law: 'pure f <*> pure x = pure (f x)' for" + , genDescr @(a -> b) genfaname + , "sequenced with" + , genDescr @a genaname + ]) $ + equivalentOnGens2 + (\(Anon f) x -> pure f <*> pure x :: f b) + (\(Anon f) x -> pure $ f x :: f b) + ((,) <$> (Anon <$> genfa) <*> gena) + it + (unwords + [ "satisfy the interchange law: 'u <*> pure y = pure ($ y) <*> u' for" + , genDescr @(f (a -> b)) genffaname + , "sequenced with" + , genDescr @a genaname + ]) $ + equivalentOnGens2 + (\(Anon u) y -> u <*> pure y :: f b) + (\(Anon u) y -> pure ($ y) <*> u :: f b) + ((,) <$> (Anon <$> genffa) <*> gena) + it + (unwords + [ "satisfy the law about the functor instance: fmap f x = pure f <*> x for" + , genDescr @(a -> b) genfaname + , "mapped over" + , genDescr @(f a) genname + ]) $ + equivalentOnGens2 + (\(Anon f) x -> fmap f x) + (\(Anon f) x -> pure f <*> x) + ((,) <$> (Anon <$> genfa) <*> gen) + describe (seqrTypeStr @f) $ do + it + (unwords + [ "is equivalent to its default implementation 'u *> v = pure (const id) <*> u <*> v' for" + , genDescr @(f a) genname + , "in front of" + , genDescr @b genbname + ]) $ + equivalentOnGens2 + (\u v -> u *> v) + (\u v -> pure (const id) <*> u <*> v) + ((,) <$> gen <*> genb) + describe (seqlTypeStr @f) $ do + it + (unwords + [ "is equivalent to its default implementation 'u <* v = pure const <*> u <*> v' for" + , genDescr @b genbname + , "behind" + , genDescr @(f a) genname + ]) $ + equivalentOnGens2 + (\u v -> u <* v) + (\u v -> pure const <*> u <*> v) + ((,) <$> gen <*> genb) diff --git a/src/Test/Validity/Arbitrary.hs b/src/Test/Validity/Arbitrary.hs --- a/src/Test/Validity/Arbitrary.hs +++ b/src/Test/Validity/Arbitrary.hs @@ -1,60 +1,45 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} + +-- | Tests for Arbitrary instances involving Validity module Test.Validity.Arbitrary - ( -- * Tests for Arbitrary instances involving Validity - arbitrarySpec + ( arbitrarySpec , arbitraryGeneratesOnlyValid - , shrinkProducesOnlyValids ) where -import Data.Data -import Data.Proxy +import Data.Data -import Data.GenValidity +import Data.GenValidity -import Test.Hspec -import Test.QuickCheck +import Test.Hspec +import Test.QuickCheck -import Test.Validity.Utils -import Test.Validity.GenValidity +import Test.Validity.GenValidity +import Test.Validity.Utils -- | A @Spec@ that specifies that @arbitrary@ only generates data that --- satisfy @isValid@ and that @shrink@ only produces data that satisfy --- @isValid@. +-- satisfy @isValid@ -- -- Example usage: -- --- > arbitrarySpec (Proxy :: Proxy MyData) +-- > arbitrarySpec @Int arbitrarySpec - :: (Typeable a, Show a, Validity a, Arbitrary a) - => Proxy a - -> Spec -arbitrarySpec proxy = do - let name = nameOf proxy - describe ("Arbitrary " ++ name) $ do - it ("is instantiated such that 'arbitrary' only generates valid \'" - ++ name - ++ "\'s.") $ - arbitraryGeneratesOnlyValid proxy - - it ("is instantiated such that 'shrink' only produces valid \'" - ++ name - ++ "\'s.") $ - forAll arbitrary $ \a -> - shrink (a `asProxyTypeOf` proxy) `shouldSatisfy` all isValid + :: forall a. + (Typeable a, Show a, Validity a, Arbitrary a) + => Spec +arbitrarySpec = do + let name = nameOf @a + describe ("Arbitrary " ++ name) $ + describe ("arbitrary :: Gen " ++ name) $ + it "only generates valid values" $ arbitraryGeneratesOnlyValid @a -- | @arbitrary@ only generates valid data +-- +-- prop> arbitraryGeneratesOnlyValid @Int arbitraryGeneratesOnlyValid - :: forall a. (Show a, Validity a, Arbitrary a) - => Proxy a - -> Property -arbitraryGeneratesOnlyValid _ = - genGeneratesValid (arbitrary :: Gen a) - --- | @shrink@, applied to valid data only produces valid data -shrinkProducesOnlyValids - :: forall a. (Show a, Validity a, Arbitrary a) - => Proxy a - -> Property -shrinkProducesOnlyValids _ = - genGeneratesValid (shrink <$> arbitrary :: Gen [a]) + :: forall a. + (Show a, Validity a, Arbitrary a) + => Property +arbitraryGeneratesOnlyValid = genGeneratesValid @a arbitrary diff --git a/src/Test/Validity/Eq.hs b/src/Test/Validity/Eq.hs --- a/src/Test/Validity/Eq.hs +++ b/src/Test/Validity/Eq.hs @@ -1,47 +1,134 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Eq properties +-- +-- You will need @TypeApplications@ to use these. module Test.Validity.Eq - ( -- * Eq properties - eqSpec + ( eqSpecOnValid + , eqSpec + , eqSpecOnArbitrary + , eqSpecOnGen ) where -import Data.Data -import Data.Proxy +import Data.Data -import Data.GenValidity +import Data.GenValidity -import Test.Hspec +import Test.Hspec +import Test.QuickCheck -import Test.Validity.Relations -import Test.Validity.Utils +import Test.Validity.Functions +import Test.Validity.Relations +import Test.Validity.Utils -eqSpec - :: (Show a, Eq a, Typeable a, GenValidity a) - => Proxy a - -> Spec -eqSpec proxy = do - let name = nameOf proxy - funeqstr = unwords - [ "(==) ::" - , name - , "->" - , name - , "-> Bool" - ] - eq a b = a `asProxyTypeOf` proxy == b - describe ("Eq " ++ name) $ do - it ("is instantated such that " - ++ funeqstr - ++ " is reflexive") $ - reflexivity eq +eqTypeStr + :: forall a. + Typeable a + => String +eqTypeStr = binRelStr @a "==" - it ("is instantated such that " - ++ funeqstr - ++ " is symmetric") $ - symmetry eq +neqTypeStr + :: forall a. + Typeable a + => String +neqTypeStr = binRelStr @a "/=" - it ("is instantated such that " - ++ funeqstr - ++ " is transitive") $ - transitivity eq +-- | Standard test spec for properties of Eq instances for valid values +-- +-- Example usage: +-- +-- > eqSpecOnValid @Double +eqSpecOnValid + :: forall a. + (Show a, Eq a, Typeable a, GenValid a) + => Spec +eqSpecOnValid = eqSpecOnGen @a genValid "valid" +-- | Standard test spec for properties of Eq instances for unchecked values +-- +-- Example usage: +-- +-- > eqSpec @Int +eqSpec + :: forall a. + (Show a, Eq a, Typeable a, GenUnchecked a) + => Spec +eqSpec = eqSpecOnGen @a genUnchecked "unchecked" + +-- | Standard test spec for properties of Eq instances for arbitrary values +-- +-- Example usage: +-- +-- > eqSpecOnArbitrary @Int +eqSpecOnArbitrary + :: forall a. + (Show a, Eq a, Typeable a, Arbitrary a) + => Spec +eqSpecOnArbitrary = eqSpecOnGen @a arbitrary "arbitrary" + +-- | Standard test spec for properties of Eq instances for values generated by a given generator (and name for that generator). +-- +-- Example usage: +-- +-- > eqSpecOnGen ((* 2) <$> genValid @Int) "even" +eqSpecOnGen + :: forall a. + (Show a, Eq a, Typeable a) + => Gen a -> String -> Spec +eqSpecOnGen gen genname = + parallel $ do + let name = nameOf @a + funeqstr = eqTypeStr @a + funneqstr = neqTypeStr @a + gen2 = (,) <$> gen <*> gen + gen3 = (,,) <$> gen <*> gen <*> gen + describe ("Eq " ++ name) $ do + let eq = (==) @a + neq = (/=) @a + describe funeqstr $ do + it + (unwords + [ "is reflexive for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + reflexivityOnGen eq gen + it + (unwords + [ "is symmetric for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + symmetryOnGens eq gen2 + it + (unwords + [ "is transitive for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + transitivityOnGens eq gen3 + it + (unwords + [ "is equivalent to (\\a b -> not $ a /= b) for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + equivalentOnGens2 eq (\a b -> not $ a `neq` b) gen2 + describe funneqstr $ do + it + (unwords + [ "is antireflexive for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + antireflexivityOnGen neq gen + it + (unwords + [ "is equivalent to (\\a b -> not $ a == b) for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + equivalentOnGens2 neq (\a b -> not $ a `eq` b) gen2 diff --git a/src/Test/Validity/Functions.hs b/src/Test/Validity/Functions.hs --- a/src/Test/Validity/Functions.hs +++ b/src/Test/Validity/Functions.hs @@ -1,10 +1,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Functions - ( -- * Validity tests involving functions +{-# LANGUAGE ScopedTypeVariables #-} - -- ** Standard tests involving validity - producesValidsOnGen +-- | Validity tests involving functions +module Test.Validity.Functions + ( producesValidsOnGen , producesValidsOnValids , producesValid , producesValidsOnArbitrary @@ -16,61 +15,62 @@ , producesValidsOnValids3 , producesValid3 , producesValidsOnArbitrary3 - - -- ** Standard tests involving functions that can fail , succeedsOnGen , succeedsOnValid , succeeds , succeedsOnArbitrary - , succeedsOnGens2 , succeedsOnValids2 , succeeds2 , succeedsOnArbitrary2 - , failsOnGen , failsOnInvalid - , failsOnGens2 , failsOnInvalid2 - , validIfSucceedsOnGen , validIfSucceedsOnValid , validIfSucceedsOnArbitrary , validIfSucceeds - , validIfSucceedsOnGens2 , validIfSucceedsOnValids2 , validIfSucceeds2 , validIfSucceedsOnArbitrary2 - - -- ** Standard tests involving equivalence of functions , equivalentOnGen , equivalentOnValid , equivalent + , equivalentOnArbitrary , equivalentOnGens2 , equivalentOnValids2 , equivalent2 + , equivalentOnArbitrary2 , equivalentWhenFirstSucceedsOnGen , equivalentWhenFirstSucceedsOnValid , equivalentWhenFirstSucceeds + , equivalentWhenFirstSucceedsOnArbitrary , equivalentWhenFirstSucceedsOnGens2 , equivalentWhenFirstSucceedsOnValids2 , equivalentWhenFirstSucceeds2 + , equivalentWhenFirstSucceedsOnArbitrary2 , equivalentWhenSecondSucceedsOnGen , equivalentWhenSecondSucceedsOnValid , equivalentWhenSecondSucceeds + , equivalentWhenSecondSucceedsOnArbitrary , equivalentWhenSecondSucceedsOnGens2 , equivalentWhenSecondSucceedsOnValids2 , equivalentWhenSecondSucceeds2 + , equivalentWhenSecondSucceedsOnArbitrary2 , equivalentWhenSucceedOnGen , equivalentWhenSucceedOnValid , equivalentWhenSucceed + , equivalentWhenSucceedOnArbitrary , equivalentWhenSucceedOnGens2 , equivalentWhenSucceedOnValids2 , equivalentWhenSucceed2 - - -- ** Standard tests involving inverse functions + , equivalentWhenSucceedOnArbitrary2 + , equivalentOnGens3 + , equivalentOnValids3 + , equivalent3 + , equivalentOnArbitrary3 , inverseFunctionsOnGen , inverseFunctionsOnValid , inverseFunctions @@ -87,17 +87,14 @@ , inverseFunctionsIfSucceedOnValid , inverseFunctionsIfSucceed , inverseFunctionsIfSucceedOnArbitrary - - -- ** Properties involving idempotence , idempotentOnGen , idempotentOnValid , idempotent , idempotentOnArbitrary ) where -import Test.Validity.Functions.CanFail -import Test.Validity.Functions.Equivalence -import Test.Validity.Functions.Idempotence -import Test.Validity.Functions.Inverse -import Test.Validity.Functions.Validity - +import Test.Validity.Functions.CanFail +import Test.Validity.Functions.Equivalence +import Test.Validity.Functions.Idempotence +import Test.Validity.Functions.Inverse +import Test.Validity.Functions.Validity diff --git a/src/Test/Validity/Functions/CanFail.hs b/src/Test/Validity/Functions/CanFail.hs --- a/src/Test/Validity/Functions/CanFail.hs +++ b/src/Test/Validity/Functions/CanFail.hs @@ -1,223 +1,198 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Test.Validity.Functions.CanFail - ( -- ** Standard tests involving functions that can fail - succeedsOnGen + ( succeedsOnGen , succeedsOnValid , succeeds , succeedsOnArbitrary - , succeedsOnGens2 , succeedsOnValids2 , succeeds2 , succeedsOnArbitrary2 - , failsOnGen , failsOnInvalid - , failsOnGens2 , failsOnInvalid2 - , validIfSucceedsOnGen , validIfSucceedsOnValid , validIfSucceedsOnArbitrary , validIfSucceeds - , validIfSucceedsOnGens2 , validIfSucceedsOnValids2 , validIfSucceeds2 , validIfSucceedsOnArbitrary2 ) where -import Data.GenValidity +import Data.GenValidity -import Test.Hspec -import Test.QuickCheck +import Test.Hspec +import Test.QuickCheck -import Test.Validity.Types +import Test.Validity.Types -- | The function succeeds if the input is generated by the given generator succeedsOnGen :: (Show a, Show b, Show (f b), CanFail f) - => (a -> f b) - -> Gen a - -> Property -succeedsOnGen func gen - = forAll gen $ \a -> func a `shouldNotSatisfy` hasFailed + => (a -> f b) -> Gen a -> Property +succeedsOnGen func gen = forAll gen $ \a -> func a `shouldNotSatisfy` hasFailed -- | The function succeeds if the input is generated by @genValid@ succeedsOnValid - :: (Show a, Show b, Show (f b), GenValidity a, CanFail f) - => (a -> f b) - -> Property + :: (Show a, Show b, Show (f b), GenValid a, CanFail f) + => (a -> f b) -> Property succeedsOnValid = (`succeedsOnGen` genValid) -- | The function succeeds if the input is generated by @genUnchecked@ succeeds - :: (Show a, Show b, Show (f b), GenValidity a, CanFail f) - => (a -> f b) - -> Property + :: (Show a, Show b, Show (f b), GenUnchecked a, CanFail f) + => (a -> f b) -> Property succeeds = (`succeedsOnGen` genUnchecked) -- | The function succeeds if the input is generated by @arbitrary@ succeedsOnArbitrary :: (Show a, Show b, Show (f b), Arbitrary a, CanFail f) - => (a -> f b) - -> Property + => (a -> f b) -> Property succeedsOnArbitrary = (`succeedsOnGen` arbitrary) -- | The function fails if the input is generated by the given generator failsOnGen :: (Show a, Show b, Show (f b), CanFail f) - => (a -> f b) - -> Gen a - -> Property -failsOnGen func gen - = forAll gen $ \a -> func a `shouldSatisfy` hasFailed + => (a -> f b) -> Gen a -> Property +failsOnGen func gen = forAll gen $ \a -> func a `shouldSatisfy` hasFailed -- | The function fails if the input is generated by @genInvalid@ failsOnInvalid - :: (Show a, Show b, Show (f b), GenValidity a, CanFail f) - => (a -> f b) - -> Property + :: (Show a, Show b, Show (f b), GenInvalid a, CanFail f) + => (a -> f b) -> Property failsOnInvalid = (`failsOnGen` genInvalid) -- | The function produces output that satisfies @isValid@ if it is given input -- that is generated by the given generator. validIfSucceedsOnGen :: (Show a, Show b, Show (f b), Validity b, CanFail f) - => (a -> f b) - -> Gen a - -> Property -validIfSucceedsOnGen func gen - = forAll gen $ \a -> + => (a -> f b) -> Gen a -> Property +validIfSucceedsOnGen func gen = + forAll gen $ \a -> case resultIfSucceeded (func a) of - Nothing -> return () -- Can happen + Nothing -> return () -- Can happen Just res -> res `shouldSatisfy` isValid -- | The function produces output that satisfies @isValid@ if it is given input -- that is generated by @arbitrary@. validIfSucceedsOnValid - :: (Show a, Show b, Show (f b), GenValidity a, Validity b, CanFail f) - => (a -> f b) - -> Property + :: (Show a, Show b, Show (f b), GenValid a, Validity b, CanFail f) + => (a -> f b) -> Property validIfSucceedsOnValid = (`validIfSucceedsOnGen` genValid) - -- | The function produces output that satisfies @isValid@ if it is given input -- that is generated by @arbitrary@. validIfSucceedsOnArbitrary :: (Show a, Show b, Show (f b), Arbitrary a, Validity b, CanFail f) - => (a -> f b) - -> Property + => (a -> f b) -> Property validIfSucceedsOnArbitrary = (`validIfSucceedsOnGen` arbitrary) -- | The function produces output that satisfies @isValid@ if it is given input -- that is generated by @genUnchecked@. validIfSucceeds - :: (Show a, Show b, Show (f b), GenValidity a, Validity b, CanFail f) - => (a -> f b) - -> Property + :: (Show a, Show b, Show (f b), GenUnchecked a, Validity b, CanFail f) + => (a -> f b) -> Property validIfSucceeds = (`validIfSucceedsOnGen` genUnchecked) - succeedsOnGens2 - :: (Show a, Show b, Show c, Show (f c), - CanFail f) - => (a -> b -> f c) - -> Gen (a, b) - -> Property + :: (Show a, Show b, Show c, Show (f c), CanFail f) + => (a -> b -> f c) -> Gen (a, b) -> Property succeedsOnGens2 func gen = - forAll gen $ \(a, b) -> - func a b `shouldNotSatisfy` hasFailed - + forAll gen $ \(a, b) -> func a b `shouldNotSatisfy` hasFailed succeedsOnValids2 - :: (Show a, Show b, Show c, Show (f c), - GenValidity a, GenValidity b, - CanFail f) - => (a -> b -> f c) - -> Property -succeedsOnValids2 func - = succeedsOnGens2 func genValid + :: (Show a, Show b, Show c, Show (f c), GenValid a, GenValid b, CanFail f) + => (a -> b -> f c) -> Property +succeedsOnValids2 func = succeedsOnGens2 func genValid succeeds2 - :: (Show a, Show b, Show c, Show (f c), - GenValidity a, GenValidity b, - CanFail f) - => (a -> b -> f c) - -> Property -succeeds2 func - = succeedsOnGens2 func genUnchecked + :: ( Show a + , Show b + , Show c + , Show (f c) + , GenUnchecked a + , GenUnchecked b + , CanFail f + ) + => (a -> b -> f c) -> Property +succeeds2 func = succeedsOnGens2 func genUnchecked succeedsOnArbitrary2 - :: (Show a, Show b, Show c, Show (f c), - Arbitrary a, Arbitrary b, - CanFail f) - => (a -> b -> f c) - -> Property -succeedsOnArbitrary2 func - = succeedsOnGens2 func arbitrary - + :: (Show a, Show b, Show c, Show (f c), Arbitrary a, Arbitrary b, CanFail f) + => (a -> b -> f c) -> Property +succeedsOnArbitrary2 func = succeedsOnGens2 func arbitrary failsOnGens2 - :: (Show a, Show b, Show c, Show (f c), - CanFail f) - => (a -> b -> f c) - -> Gen a -> Gen b - -> Property + :: (Show a, Show b, Show c, Show (f c), CanFail f) + => (a -> b -> f c) -> Gen a -> Gen b -> Property failsOnGens2 func genA genB = - forAll genA $ \a -> - forAll genB $ \b -> - func a b `shouldSatisfy` hasFailed - + forAll genA $ \a -> forAll genB $ \b -> func a b `shouldSatisfy` hasFailed failsOnInvalid2 - :: (Show a, Show b, Show c, Show (f c), - GenValidity a, GenValidity b, - CanFail f) - => (a -> b -> f c) - -> Property -failsOnInvalid2 func - = failsOnGens2 func genInvalid genUnchecked - .&&. failsOnGens2 func genUnchecked genInvalid - + :: ( Show a + , Show b + , Show c + , Show (f c) + , GenInvalid a + , GenUnchecked a + , GenInvalid b + , GenUnchecked b + , CanFail f + ) + => (a -> b -> f c) -> Property +failsOnInvalid2 func = + failsOnGens2 func genInvalid genUnchecked .&&. + failsOnGens2 func genUnchecked genInvalid validIfSucceedsOnGens2 - :: (Show a, Show b, Show c, Show (f c), - Validity c, CanFail f) - => (a -> b -> f c) - -> Gen (a, b) - -> Property + :: (Show a, Show b, Show c, Show (f c), Validity c, CanFail f) + => (a -> b -> f c) -> Gen (a, b) -> Property validIfSucceedsOnGens2 func gen = forAll gen $ \(a, b) -> case resultIfSucceeded (func a b) of - Nothing -> return () -- Can happen + Nothing -> return () -- Can happen Just res -> res `shouldSatisfy` isValid validIfSucceedsOnValids2 - :: (Show a, Show b, Show c, Show (f c), - GenValidity a, GenValidity b, - Validity c, CanFail f) - => (a -> b -> f c) - -> Property -validIfSucceedsOnValids2 func - = validIfSucceedsOnGens2 func genValid + :: ( Show a + , Show b + , Show c + , Show (f c) + , GenValid a + , GenValid b + , Validity c + , CanFail f + ) + => (a -> b -> f c) -> Property +validIfSucceedsOnValids2 func = validIfSucceedsOnGens2 func genValid validIfSucceeds2 - :: (Show a, Show b, Show c, Show (f c), - GenValidity a, GenValidity b, - Validity c, CanFail f) - => (a -> b -> f c) - -> Property -validIfSucceeds2 func - = validIfSucceedsOnGens2 func genUnchecked + :: ( Show a + , Show b + , Show c + , Show (f c) + , GenUnchecked a + , GenUnchecked b + , Validity c + , CanFail f + ) + => (a -> b -> f c) -> Property +validIfSucceeds2 func = validIfSucceedsOnGens2 func genUnchecked validIfSucceedsOnArbitrary2 - :: (Show a, Show b, Show c, Show (f c), - Arbitrary a, Arbitrary b, - Validity c, CanFail f) - => (a -> b -> f c) - -> Property -validIfSucceedsOnArbitrary2 func - = validIfSucceedsOnGens2 func arbitrary + :: ( Show a + , Show b + , Show c + , Show (f c) + , Arbitrary a + , Arbitrary b + , Validity c + , CanFail f + ) + => (a -> b -> f c) -> Property +validIfSucceedsOnArbitrary2 func = validIfSucceedsOnGens2 func arbitrary diff --git a/src/Test/Validity/Functions/Equivalence.hs b/src/Test/Validity/Functions/Equivalence.hs --- a/src/Test/Validity/Functions/Equivalence.hs +++ b/src/Test/Validity/Functions/Equivalence.hs @@ -1,135 +1,136 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Test.Validity.Functions.Equivalence - ( -- ** Standard tests involving equivalence of functions - equivalentOnGen + ( equivalentOnGen , equivalentOnValid , equivalent + , equivalentOnArbitrary , equivalentOnGens2 , equivalentOnValids2 , equivalent2 + , equivalentOnArbitrary2 , equivalentWhenFirstSucceedsOnGen , equivalentWhenFirstSucceedsOnValid , equivalentWhenFirstSucceeds + , equivalentWhenFirstSucceedsOnArbitrary , equivalentWhenFirstSucceedsOnGens2 , equivalentWhenFirstSucceedsOnValids2 , equivalentWhenFirstSucceeds2 + , equivalentWhenFirstSucceedsOnArbitrary2 , equivalentWhenSecondSucceedsOnGen , equivalentWhenSecondSucceedsOnValid , equivalentWhenSecondSucceeds + , equivalentWhenSecondSucceedsOnArbitrary , equivalentWhenSecondSucceedsOnGens2 , equivalentWhenSecondSucceedsOnValids2 , equivalentWhenSecondSucceeds2 + , equivalentWhenSecondSucceedsOnArbitrary2 , equivalentWhenSucceedOnGen , equivalentWhenSucceedOnValid , equivalentWhenSucceed + , equivalentWhenSucceedOnArbitrary , equivalentWhenSucceedOnGens2 , equivalentWhenSucceedOnValids2 , equivalentWhenSucceed2 + , equivalentWhenSucceedOnArbitrary2 + , equivalentOnGens3 + , equivalentOnValids3 + , equivalent3 + , equivalentOnArbitrary3 ) where -import Data.GenValidity +import Data.GenValidity -import Test.Hspec -import Test.QuickCheck +import Test.Hspec +import Test.QuickCheck -import Test.Validity.Types +import Test.Validity.Types equivalentOnGen :: (Show a, Eq a, Show b, Eq b) - => (a -> b) - -> (a -> b) - -> Gen a - -> Property -equivalentOnGen f g gen = - forAll gen $ \a -> - f a `shouldBe` g a + => (a -> b) -> (a -> b) -> Gen a -> Property +equivalentOnGen f g gen = forAll gen $ \a -> f a `shouldBe` g a equivalentOnValid - :: (Show a, Eq a, GenValidity a, Show b, Eq b) - => (a -> b) - -> (a -> b) - -> Property -equivalentOnValid f g - = equivalentOnGen f g genValid + :: (Show a, Eq a, GenValid a, Show b, Eq b) + => (a -> b) -> (a -> b) -> Property +equivalentOnValid f g = equivalentOnGen f g genValid equivalent - :: (Show a, Eq a, GenValidity a, Show b, Eq b) - => (a -> b) - -> (a -> b) - -> Property -equivalent f g - = equivalentOnGen f g genUnchecked + :: (Show a, Eq a, GenUnchecked a, Show b, Eq b) + => (a -> b) -> (a -> b) -> Property +equivalent f g = equivalentOnGen f g genUnchecked +-- | +-- +-- prop> equivalentOnArbitrary ((* 2) . (+ 1)) ((+ 2) . (* 2) :: Int -> Int) +equivalentOnArbitrary + :: (Show a, Eq a, Arbitrary a, Show b, Eq b) + => (a -> b) -> (a -> b) -> Property +equivalentOnArbitrary f g = equivalentOnGen f g arbitrary + equivalentOnGens2 - :: (Show a, Eq a, - Show b, Eq b, - Show c, Eq c) - => (a -> b -> c) - -> (a -> b -> c) - -> Gen (a, b) - -> Property -equivalentOnGens2 f g gen = - forAll gen $ \(a, b) -> - f a b `shouldBe` g a b + :: (Show a, Show b, Show c, Eq c) + => (a -> b -> c) -> (a -> b -> c) -> Gen (a, b) -> Property +equivalentOnGens2 f g gen = forAll gen $ \(a, b) -> f a b `shouldBe` g a b equivalentOnValids2 - :: (Show a, Eq a, GenValidity a, - Show b, Eq b, GenValidity b, - Show c, Eq c) - => (a -> b -> c) - -> (a -> b -> c) - -> Property -equivalentOnValids2 f g - = equivalentOnGens2 f g genValid + :: (Show a, Eq a, GenValid a, Show b, Eq b, GenValid b, Show c, Eq c) + => (a -> b -> c) -> (a -> b -> c) -> Property +equivalentOnValids2 f g = equivalentOnGens2 f g genValid equivalent2 - :: (Show a, Eq a, GenValidity a, - Show b, Eq b, GenValidity b, - Show c, Eq c) - => (a -> b -> c) - -> (a -> b -> c) - -> Property -equivalent2 f g - = equivalentOnGens2 f g genUnchecked + :: ( Show a + , Eq a + , GenUnchecked a + , Show b + , Eq b + , GenUnchecked b + , Show c + , Eq c + ) + => (a -> b -> c) -> (a -> b -> c) -> Property +equivalent2 f g = equivalentOnGens2 f g genUnchecked +-- | +-- +-- prop> equivalentOnArbitrary2 (+) ((+) :: Int -> Int -> Int) +equivalentOnArbitrary2 + :: (Show a, Eq a, Arbitrary a, Show b, Eq b, Arbitrary b, Show c, Eq c) + => (a -> b -> c) -> (a -> b -> c) -> Property +equivalentOnArbitrary2 f g = equivalentOnGens2 f g arbitrary + equivalentWhenFirstSucceedsOnGen :: (Show a, Eq a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> b) - -> Gen a - -> Property + => (a -> f b) -> (a -> b) -> Gen a -> Property equivalentWhenFirstSucceedsOnGen f g gen = forAll gen $ \a -> case resultIfSucceeded (f a) of Nothing -> return () -- fine - Just r -> r `shouldBe` g a + Just r -> r `shouldBe` g a equivalentWhenFirstSucceedsOnValid - :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> b) - -> Property -equivalentWhenFirstSucceedsOnValid f g - = equivalentWhenFirstSucceedsOnGen f g genValid + :: (Show a, Eq a, GenValid a, Show b, Eq b, CanFail f) + => (a -> f b) -> (a -> b) -> Property +equivalentWhenFirstSucceedsOnValid f g = + equivalentWhenFirstSucceedsOnGen f g genValid +equivalentWhenFirstSucceedsOnArbitrary + :: (Show a, Eq a, Arbitrary a, Show b, Eq b, CanFail f) + => (a -> f b) -> (a -> b) -> Property +equivalentWhenFirstSucceedsOnArbitrary f g = + equivalentWhenFirstSucceedsOnGen f g arbitrary + equivalentWhenFirstSucceeds - :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> b) - -> Property -equivalentWhenFirstSucceeds f g - = equivalentWhenFirstSucceedsOnGen f g genUnchecked + :: (Show a, Eq a, GenUnchecked a, Show b, Eq b, CanFail f) + => (a -> f b) -> (a -> b) -> Property +equivalentWhenFirstSucceeds f g = + equivalentWhenFirstSucceedsOnGen f g genUnchecked equivalentWhenFirstSucceedsOnGens2 - :: (Show a, Eq a, - Show b, Eq b, - Show c, Eq c, - CanFail f) - => (a -> b -> f c) - -> (a -> b -> c) - -> Gen (a, b) - -> Property + :: (Show a, Eq a, Show b, Eq b, Show c, Eq c, CanFail f) + => (a -> b -> f c) -> (a -> b -> c) -> Gen (a, b) -> Property equivalentWhenFirstSucceedsOnGens2 f g gen = forAll gen $ \(a, b) -> case resultIfSucceeded (f a b) of @@ -137,64 +138,80 @@ Just rs -> rs `shouldBe` g a b equivalentWhenFirstSucceedsOnValids2 - :: (Show a, Eq a, GenValidity a, - Show b, Eq b, GenValidity b, - Show c, Eq c, - CanFail f) - => (a -> b -> f c) - -> (a -> b -> c) - -> Property -equivalentWhenFirstSucceedsOnValids2 f g - = equivalentWhenFirstSucceedsOnGens2 f g genValid + :: ( Show a + , Eq a + , GenValid a + , Show b + , Eq b + , GenValid b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> f c) -> (a -> b -> c) -> Property +equivalentWhenFirstSucceedsOnValids2 f g = + equivalentWhenFirstSucceedsOnGens2 f g genValid +equivalentWhenFirstSucceedsOnArbitrary2 + :: ( Show a + , Eq a + , Arbitrary a + , Show b + , Eq b + , Arbitrary b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> f c) -> (a -> b -> c) -> Property +equivalentWhenFirstSucceedsOnArbitrary2 f g = + equivalentWhenFirstSucceedsOnGens2 f g arbitrary + equivalentWhenFirstSucceeds2 - :: (Show a, Eq a, GenValidity a, - Show b, Eq b, GenValidity b, - Show c, Eq c, - CanFail f) - => (a -> b -> f c) - -> (a -> b -> c) - -> Property -equivalentWhenFirstSucceeds2 f g - = equivalentWhenFirstSucceedsOnGens2 f g genUnchecked + :: ( Show a + , Eq a + , GenUnchecked a + , Show b + , Eq b + , GenUnchecked b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> f c) -> (a -> b -> c) -> Property +equivalentWhenFirstSucceeds2 f g = + equivalentWhenFirstSucceedsOnGens2 f g genUnchecked equivalentWhenSecondSucceedsOnGen :: (Show a, Eq a, Show b, Eq b, CanFail f) - => (a -> b) - -> (a -> f b) - -> Gen a - -> Property + => (a -> b) -> (a -> f b) -> Gen a -> Property equivalentWhenSecondSucceedsOnGen f g gen = forAll gen $ \a -> case resultIfSucceeded (g a) of Nothing -> return () -- fine - Just r -> r `shouldBe` f a + Just r -> r `shouldBe` f a equivalentWhenSecondSucceedsOnValid - :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f) - => (a -> b) - -> (a -> f b) - -> Property -equivalentWhenSecondSucceedsOnValid f g - = equivalentWhenSecondSucceedsOnGen f g genValid + :: (Show a, Eq a, GenValid a, Show b, Eq b, CanFail f) + => (a -> b) -> (a -> f b) -> Property +equivalentWhenSecondSucceedsOnValid f g = + equivalentWhenSecondSucceedsOnGen f g genValid +equivalentWhenSecondSucceedsOnArbitrary + :: (Show a, Eq a, Arbitrary a, Show b, Eq b, CanFail f) + => (a -> b) -> (a -> f b) -> Property +equivalentWhenSecondSucceedsOnArbitrary f g = + equivalentWhenSecondSucceedsOnGen f g arbitrary + equivalentWhenSecondSucceeds - :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f) - => (a -> b) - -> (a -> f b) - -> Property -equivalentWhenSecondSucceeds f g - = equivalentWhenSecondSucceedsOnGen f g genUnchecked + :: (Show a, Eq a, GenUnchecked a, Show b, Eq b, CanFail f) + => (a -> b) -> (a -> f b) -> Property +equivalentWhenSecondSucceeds f g = + equivalentWhenSecondSucceedsOnGen f g genUnchecked equivalentWhenSecondSucceedsOnGens2 - :: (Show a, Eq a, - Show b, Eq b, - Show c, Eq c, - CanFail f) - => (a -> b -> c) - -> (a -> b -> f c) - -> Gen (a, b) - -> Property + :: (Show a, Eq a, Show b, Eq b, Show c, Eq c, CanFail f) + => (a -> b -> c) -> (a -> b -> f c) -> Gen (a, b) -> Property equivalentWhenSecondSucceedsOnGens2 f g gen = forAll gen $ \(a, b) -> case resultIfSucceeded (g a b) of @@ -202,94 +219,180 @@ Just rs -> rs `shouldBe` f a b equivalentWhenSecondSucceedsOnValids2 - :: (Show a, Eq a, GenValidity a, - Show b, Eq b, GenValidity b, - Show c, Eq c, - CanFail f) - => (a -> b -> c) - -> (a -> b -> f c) - -> Property -equivalentWhenSecondSucceedsOnValids2 f g - = equivalentWhenSecondSucceedsOnGens2 f g genValid + :: ( Show a + , Eq a + , GenValid a + , Show b + , Eq b + , GenValid b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> c) -> (a -> b -> f c) -> Property +equivalentWhenSecondSucceedsOnValids2 f g = + equivalentWhenSecondSucceedsOnGens2 f g genValid +equivalentWhenSecondSucceedsOnArbitrary2 + :: ( Show a + , Eq a + , Arbitrary a + , Show b + , Eq b + , Arbitrary b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> c) -> (a -> b -> f c) -> Property +equivalentWhenSecondSucceedsOnArbitrary2 f g = + equivalentWhenSecondSucceedsOnGens2 f g arbitrary + equivalentWhenSecondSucceeds2 - :: (Show a, Eq a, GenValidity a, - Show b, Eq b, GenValidity b, - Show c, Eq c, - CanFail f) - => (a -> b -> c) - -> (a -> b -> f c) - -> Property -equivalentWhenSecondSucceeds2 f g - = equivalentWhenSecondSucceedsOnGens2 f g genUnchecked + :: ( Show a + , Eq a + , GenUnchecked a + , Show b + , Eq b + , GenUnchecked b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> c) -> (a -> b -> f c) -> Property +equivalentWhenSecondSucceeds2 f g = + equivalentWhenSecondSucceedsOnGens2 f g genUnchecked equivalentWhenSucceedOnGen :: (Show a, Eq a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> f b) - -> Gen a - -> Property + => (a -> f b) -> (a -> f b) -> Gen a -> Property equivalentWhenSucceedOnGen f g gen = forAll gen $ \a -> case do fa <- resultIfSucceeded $ f a ga <- resultIfSucceeded $ g a - return (fa, ga) - of + return (fa, ga) of Nothing -> return () -- fine - Just (fa, ga) -> fa `shouldBe` ga + Just (fa, ga) -> fa `shouldBe` ga equivalentWhenSucceedOnValid - :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> f b) - -> Property -equivalentWhenSucceedOnValid f g - = equivalentWhenSucceedOnGen f g genValid + :: (Show a, Eq a, GenValid a, Show b, Eq b, CanFail f) + => (a -> f b) -> (a -> f b) -> Property +equivalentWhenSucceedOnValid f g = equivalentWhenSucceedOnGen f g genValid equivalentWhenSucceed - :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> f b) - -> Property -equivalentWhenSucceed f g - = equivalentWhenSucceedOnGen f g genUnchecked + :: (Show a, Eq a, GenUnchecked a, Show b, Eq b, CanFail f) + => (a -> f b) -> (a -> f b) -> Property +equivalentWhenSucceed f g = equivalentWhenSucceedOnGen f g genUnchecked +equivalentWhenSucceedOnArbitrary + :: (Show a, Eq a, Arbitrary a, Show b, Eq b, CanFail f) + => (a -> f b) -> (a -> f b) -> Property +equivalentWhenSucceedOnArbitrary f g = equivalentWhenSucceedOnGen f g arbitrary + equivalentWhenSucceedOnGens2 - :: (Show a, Eq a, - Show b, Eq b, - Show c, Eq c, - CanFail f) - => (a -> b -> f c) - -> (a -> b -> f c) - -> Gen (a, b) - -> Property + :: (Show a, Eq a, Show b, Eq b, Show c, Eq c, CanFail f) + => (a -> b -> f c) -> (a -> b -> f c) -> Gen (a, b) -> Property equivalentWhenSucceedOnGens2 f g gen = forAll gen $ \(a, b) -> case do fab <- resultIfSucceeded $ f a b gab <- resultIfSucceeded $ g a b - return (fab, gab) - of + return (fab, gab) of Nothing -> return () -- fine Just (fab, gab) -> fab `shouldBe` gab equivalentWhenSucceedOnValids2 - :: (Show a, Eq a, GenValidity a, - Show b, Eq b, GenValidity b, - Show c, Eq c, - CanFail f) - => (a -> b -> f c) - -> (a -> b -> f c) - -> Property -equivalentWhenSucceedOnValids2 f g - = equivalentWhenSucceedOnGens2 f g genValid + :: ( Show a + , Eq a + , GenValid a + , Show b + , Eq b + , GenValid b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> f c) -> (a -> b -> f c) -> Property +equivalentWhenSucceedOnValids2 f g = equivalentWhenSucceedOnGens2 f g genValid +equivalentWhenSucceedOnArbitrary2 + :: ( Show a + , Eq a + , Arbitrary a + , Show b + , Eq b + , Arbitrary b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> f c) -> (a -> b -> f c) -> Property +equivalentWhenSucceedOnArbitrary2 f g = + equivalentWhenSucceedOnGens2 f g arbitrary + equivalentWhenSucceed2 - :: (Show a, Eq a, GenValidity a, - Show b, Eq b, GenValidity b, - Show c, Eq c, - CanFail f) - => (a -> b -> f c) - -> (a -> b -> f c) - -> Property -equivalentWhenSucceed2 f g - = equivalentWhenSucceedOnGens2 f g genUnchecked + :: ( Show a + , Eq a + , GenUnchecked a + , Show b + , Eq b + , GenUnchecked b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> f c) -> (a -> b -> f c) -> Property +equivalentWhenSucceed2 f g = equivalentWhenSucceedOnGens2 f g genUnchecked + +equivalentOnGens3 + :: (Show a, Show b, Show c, Show d, Eq d) + => (a -> b -> c -> d) -> (a -> b -> c -> d) -> Gen (a, b, c) -> Property +equivalentOnGens3 f g gen = + forAll gen $ \(a, b, c) -> f a b c `shouldBe` g a b c + +equivalentOnValids3 + :: ( Show a + , Eq a + , GenValid a + , Show b + , Eq b + , GenValid b + , Show c + , Eq c + , GenValid c + , Show d + , Eq d + ) + => (a -> b -> c -> d) -> (a -> b -> c -> d) -> Property +equivalentOnValids3 f g = equivalentOnGens3 f g genValid + +equivalent3 + :: ( Show a + , Eq a + , GenUnchecked a + , Show b + , Eq b + , GenUnchecked b + , Show c + , Eq c + , GenUnchecked c + , Show d + , Eq d + ) + => (a -> b -> c -> d) -> (a -> b -> c -> d) -> Property +equivalent3 f g = equivalentOnGens3 f g genUnchecked + +equivalentOnArbitrary3 + :: ( Show a + , Eq a + , Arbitrary a + , Show b + , Eq b + , Arbitrary b + , Show c + , Eq c + , Arbitrary c + , Show d + , Eq d + ) + => (a -> b -> c -> d) -> (a -> b -> c -> d) -> Property +equivalentOnArbitrary3 f g = equivalentOnGens3 f g arbitrary diff --git a/src/Test/Validity/Functions/Idempotence.hs b/src/Test/Validity/Functions/Idempotence.hs --- a/src/Test/Validity/Functions/Idempotence.hs +++ b/src/Test/Validity/Functions/Idempotence.hs @@ -23,13 +23,13 @@ f (f a) `shouldBe` f a idempotentOnValid - :: (Show a, Eq a, GenValidity a) + :: (Show a, Eq a, GenValid a) => (a -> a) -> Property idempotentOnValid func = idempotentOnGen func genValid idempotent - :: (Show a, Eq a, GenValidity a) + :: (Show a, Eq a, GenUnchecked a) => (a -> a) -> Property idempotent func = idempotentOnGen func genUnchecked diff --git a/src/Test/Validity/Functions/Inverse.hs b/src/Test/Validity/Functions/Inverse.hs --- a/src/Test/Validity/Functions/Inverse.hs +++ b/src/Test/Validity/Functions/Inverse.hs @@ -1,8 +1,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Standard tests involving inverse functions module Test.Validity.Functions.Inverse - ( -- ** Standard tests involving inverse functions - inverseFunctionsOnGen + ( inverseFunctionsOnGen , inverseFunctionsOnValid , inverseFunctions , inverseFunctionsOnArbitrary @@ -20,166 +21,113 @@ , inverseFunctionsIfSucceedOnArbitrary ) where -import Data.GenValidity +import Data.GenValidity -import Test.Hspec -import Test.QuickCheck +import Test.Hspec +import Test.QuickCheck -import Test.Validity.Types +import Test.Validity.Types inverseFunctionsOnGen :: (Show a, Eq a) - => (a -> b) - -> (b -> a) - -> Gen a - -> Property -inverseFunctionsOnGen f g gen = - forAll gen $ \a -> - g (f a) `shouldBe` a - + => (a -> b) -> (b -> a) -> Gen a -> Property +inverseFunctionsOnGen f g gen = forAll gen $ \a -> g (f a) `shouldBe` a inverseFunctionsOnValid - :: (Show a, Eq a, GenValidity a) - => (a -> b) - -> (b -> a) - -> Property -inverseFunctionsOnValid f g - = inverseFunctionsOnGen f g genValid - + :: (Show a, Eq a, GenValid a) + => (a -> b) -> (b -> a) -> Property +inverseFunctionsOnValid f g = inverseFunctionsOnGen f g genValid inverseFunctions - :: (Show a, Eq a, GenValidity a) - => (a -> b) - -> (b -> a) - -> Property -inverseFunctions f g - = inverseFunctionsOnGen f g genUnchecked + :: (Show a, Eq a, GenUnchecked a) + => (a -> b) -> (b -> a) -> Property +inverseFunctions f g = inverseFunctionsOnGen f g genUnchecked -- | -- 'id' is its own inverse function for every type: -- prop> inverseFunctionsOnArbitrary id (id :: Int -> Int) inverseFunctionsOnArbitrary :: (Show a, Eq a, Arbitrary a) - => (a -> b) - -> (b -> a) - -> Property -inverseFunctionsOnArbitrary f g - = inverseFunctionsOnGen f g arbitrary - + => (a -> b) -> (b -> a) -> Property +inverseFunctionsOnArbitrary f g = inverseFunctionsOnGen f g arbitrary inverseFunctionsIfFirstSucceedsOnGen :: (Show a, Eq a, CanFail f) - => (a -> f b) - -> (b -> a) - -> Gen a - -> Property + => (a -> f b) -> (b -> a) -> Gen a -> Property inverseFunctionsIfFirstSucceedsOnGen f g gen = forAll gen $ \a -> - case resultIfSucceeded (f a) of - Nothing -> return () -- fine - Just b -> g b `shouldBe` a - + case resultIfSucceeded (f a) of + Nothing -> return () -- fine + Just b -> g b `shouldBe` a inverseFunctionsIfFirstSucceedsOnValid - :: (Show a, Eq a, GenValidity a, CanFail f) - => (a -> f b) - -> (b -> a) - -> Property -inverseFunctionsIfFirstSucceedsOnValid f g - = inverseFunctionsIfFirstSucceedsOnGen f g genValid - + :: (Show a, Eq a, GenValid a, CanFail f) + => (a -> f b) -> (b -> a) -> Property +inverseFunctionsIfFirstSucceedsOnValid f g = + inverseFunctionsIfFirstSucceedsOnGen f g genValid inverseFunctionsIfFirstSucceeds - :: (Show a, Eq a, GenValidity a, CanFail f) - => (a -> f b) - -> (b -> a) - -> Property -inverseFunctionsIfFirstSucceeds f g - = inverseFunctionsIfFirstSucceedsOnGen f g genUnchecked + :: (Show a, Eq a, GenUnchecked a, CanFail f) + => (a -> f b) -> (b -> a) -> Property +inverseFunctionsIfFirstSucceeds f g = + inverseFunctionsIfFirstSucceedsOnGen f g genUnchecked inverseFunctionsIfFirstSucceedsOnArbitrary :: (Show a, Eq a, Arbitrary a, CanFail f) - => (a -> f b) - -> (b -> a) - -> Property -inverseFunctionsIfFirstSucceedsOnArbitrary f g - = inverseFunctionsIfFirstSucceedsOnGen f g arbitrary - + => (a -> f b) -> (b -> a) -> Property +inverseFunctionsIfFirstSucceedsOnArbitrary f g = + inverseFunctionsIfFirstSucceedsOnGen f g arbitrary inverseFunctionsIfSecondSucceedsOnGen :: (Show a, Eq a, CanFail f) - => (a -> b) - -> (b -> f a) - -> Gen a - -> Property + => (a -> b) -> (b -> f a) -> Gen a -> Property inverseFunctionsIfSecondSucceedsOnGen f g gen = forAll gen $ \a -> - case resultIfSucceeded (g (f a)) of - Nothing -> return () -- fine - Just r -> r `shouldBe` a - + case resultIfSucceeded (g (f a)) of + Nothing -> return () -- fine + Just r -> r `shouldBe` a inverseFunctionsIfSecondSucceedsOnValid - :: (Show a, Eq a, GenValidity a, CanFail f) - => (a -> b) - -> (b -> f a) - -> Property -inverseFunctionsIfSecondSucceedsOnValid f g - = inverseFunctionsIfSecondSucceedsOnGen f g genValid - + :: (Show a, Eq a, GenValid a, CanFail f) + => (a -> b) -> (b -> f a) -> Property +inverseFunctionsIfSecondSucceedsOnValid f g = + inverseFunctionsIfSecondSucceedsOnGen f g genValid inverseFunctionsIfSecondSucceeds - :: (Show a, Eq a, GenValidity a, CanFail f) - => (a -> b) - -> (b -> f a) - -> Property -inverseFunctionsIfSecondSucceeds f g - = inverseFunctionsIfSecondSucceedsOnGen f g genUnchecked + :: (Show a, Eq a, GenUnchecked a, CanFail f) + => (a -> b) -> (b -> f a) -> Property +inverseFunctionsIfSecondSucceeds f g = + inverseFunctionsIfSecondSucceedsOnGen f g genUnchecked inverseFunctionsIfSecondSucceedsOnArbitrary :: (Show a, Eq a, Arbitrary a, CanFail f) - => (a -> b) - -> (b -> f a) - -> Property -inverseFunctionsIfSecondSucceedsOnArbitrary f g - = inverseFunctionsIfSecondSucceedsOnGen f g arbitrary - + => (a -> b) -> (b -> f a) -> Property +inverseFunctionsIfSecondSucceedsOnArbitrary f g = + inverseFunctionsIfSecondSucceedsOnGen f g arbitrary inverseFunctionsIfSucceedOnGen :: (Show a, Eq a, CanFail f, CanFail g) - => (a -> f b) - -> (b -> g a) - -> Gen a - -> Property + => (a -> f b) -> (b -> g a) -> Gen a -> Property inverseFunctionsIfSucceedOnGen f g gen = forAll gen $ \a -> - case do fa <- resultIfSucceeded $ f a - resultIfSucceeded $ g fa - of - Nothing -> return () -- fine - Just r -> r `shouldBe` a - + case do fa <- resultIfSucceeded $ f a + resultIfSucceeded $ g fa of + Nothing -> return () -- fine + Just r -> r `shouldBe` a inverseFunctionsIfSucceedOnValid - :: (Show a, Eq a, GenValidity a, CanFail f, CanFail g) - => (a -> f b) - -> (b -> g a) - -> Property -inverseFunctionsIfSucceedOnValid f g - = inverseFunctionsIfSucceedOnGen f g genValid + :: (Show a, Eq a, GenValid a, CanFail f, CanFail g) + => (a -> f b) -> (b -> g a) -> Property +inverseFunctionsIfSucceedOnValid f g = + inverseFunctionsIfSucceedOnGen f g genValid inverseFunctionsIfSucceed - :: (Show a, Eq a, GenValidity a, CanFail f, CanFail g) - => (a -> f b) - -> (b -> g a) - -> Property -inverseFunctionsIfSucceed f g - = inverseFunctionsIfSucceedOnGen f g genUnchecked + :: (Show a, Eq a, GenUnchecked a, CanFail f, CanFail g) + => (a -> f b) -> (b -> g a) -> Property +inverseFunctionsIfSucceed f g = inverseFunctionsIfSucceedOnGen f g genUnchecked inverseFunctionsIfSucceedOnArbitrary :: (Show a, Eq a, Arbitrary a, CanFail f, CanFail g) - => (a -> f b) - -> (b -> g a) - -> Property -inverseFunctionsIfSucceedOnArbitrary f g - = inverseFunctionsIfSucceedOnGen f g arbitrary + => (a -> f b) -> (b -> g a) -> Property +inverseFunctionsIfSucceedOnArbitrary f g = + inverseFunctionsIfSucceedOnGen f g arbitrary diff --git a/src/Test/Validity/Functions/Validity.hs b/src/Test/Validity/Functions/Validity.hs --- a/src/Test/Validity/Functions/Validity.hs +++ b/src/Test/Validity/Functions/Validity.hs @@ -1,8 +1,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Standard tests involving validity module Test.Validity.Functions.Validity - ( -- ** Standard tests involving validity - producesValidsOnGen + ( producesValidsOnGen , producesValidsOnValids , producesValid , producesValidsOnArbitrary @@ -16,107 +17,101 @@ , producesValidsOnArbitrary3 ) where -import Data.GenValidity +import Data.GenValidity -import Test.Hspec -import Test.QuickCheck +import Test.Hspec +import Test.QuickCheck -- | The function produces valid output when the input is generated as -- specified by the given generator. producesValidsOnGen :: (Show a, Show b, Validity b) - => (a -> b) - -> Gen a - -> Property -producesValidsOnGen func gen - = forAll gen $ \a -> func a `shouldSatisfy` isValid + => (a -> b) -> Gen a -> Property +producesValidsOnGen func gen = forAll gen $ \a -> func a `shouldSatisfy` isValid -- | The function produces valid output when the input is generated by --- @arbitrary@ -producesValidsOnArbitrary - :: (Show a, Show b, Arbitrary a, Validity b) - => (a -> b) - -> Property -producesValidsOnArbitrary = (`producesValidsOnGen` arbitrary) +-- @genValid@ +producesValidsOnValids + :: (Show a, Show b, GenValid a, Validity b) + => (a -> b) -> Property +producesValidsOnValids = (`producesValidsOnGen` genValid) -- | The function produces valid output when the input is generated by -- @genUnchecked@ producesValid - :: (Show a, Show b, GenValidity a, Validity b) - => (a -> b) - -> Property + :: (Show a, Show b, GenUnchecked a, Validity b) + => (a -> b) -> Property producesValid = (`producesValidsOnGen` genUnchecked) -- | The function produces valid output when the input is generated by --- @genValid@ -producesValidsOnValids - :: (Show a, Show b, GenValidity a, Validity b) - => (a -> b) - -> Property -producesValidsOnValids = (`producesValidsOnGen` genValid) +-- @arbitrary@ +producesValidsOnArbitrary + :: (Show a, Show b, Arbitrary a, Validity b) + => (a -> b) -> Property +producesValidsOnArbitrary = (`producesValidsOnGen` arbitrary) producesValidsOnGens2 :: (Show a, Show b, Show c, Validity c) - => (a -> b -> c) - -> Gen (a, b) - -> Property -producesValidsOnGens2 func gen - = forAll gen $ \(a, b) -> - func a b `shouldSatisfy` isValid + => (a -> b -> c) -> Gen (a, b) -> Property +producesValidsOnGens2 func gen = + forAll gen $ \(a, b) -> func a b `shouldSatisfy` isValid producesValidsOnValids2 - :: (Show a, Show b, Show c, GenValidity a, GenValidity b, Validity c) - => (a -> b -> c) - -> Property -producesValidsOnValids2 func - = producesValidsOnGens2 func genValid + :: (Show a, Show b, Show c, GenValid a, GenValid b, Validity c) + => (a -> b -> c) -> Property +producesValidsOnValids2 func = producesValidsOnGens2 func genValid +producesValid2 + :: (Show a, Show b, Show c, GenUnchecked a, GenUnchecked b, Validity c) + => (a -> b -> c) -> Property +producesValid2 func = producesValidsOnGens2 func genUnchecked + producesValidsOnArbitrary2 :: (Show a, Show b, Show c, Arbitrary a, Arbitrary b, Validity c) - => (a -> b -> c) - -> Property -producesValidsOnArbitrary2 func - = producesValidsOnGens2 func arbitrary - -producesValid2 - :: (Show a, Show b, Show c, GenValidity a, GenValidity b, Validity c) - => (a -> b -> c) - -> Property -producesValid2 func - = producesValidsOnGens2 func genUnchecked + => (a -> b -> c) -> Property +producesValidsOnArbitrary2 func = producesValidsOnGens2 func arbitrary producesValidsOnGens3 :: (Show a, Show b, Show c, Show d, Validity d) - => (a -> b -> c -> d) - -> Gen (a, b, c) - -> Property -producesValidsOnGens3 func gen - = forAll gen $ \(a, b, c) -> - func a b c `shouldSatisfy` isValid - -producesValid3 - :: (Show a, Show b, Show c, Show d, - GenValidity a, GenValidity b, GenValidity c, - Validity d) - => (a -> b -> c -> d) - -> Property -producesValid3 func - = producesValidsOnGens3 func genUnchecked + => (a -> b -> c -> d) -> Gen (a, b, c) -> Property +producesValidsOnGens3 func gen = + forAll gen $ \(a, b, c) -> func a b c `shouldSatisfy` isValid producesValidsOnValids3 - :: (Show a, Show b, Show c, Show d, - GenValidity a, GenValidity b, GenValidity c, - Validity d) - => (a -> b -> c -> d) - -> Property -producesValidsOnValids3 func - = producesValidsOnGens3 func genValid + :: ( Show a + , Show b + , Show c + , Show d + , GenValid a + , GenValid b + , GenValid c + , Validity d + ) + => (a -> b -> c -> d) -> Property +producesValidsOnValids3 func = producesValidsOnGens3 func genValid +producesValid3 + :: ( Show a + , Show b + , Show c + , Show d + , GenUnchecked a + , GenUnchecked b + , GenUnchecked c + , Validity d + ) + => (a -> b -> c -> d) -> Property +producesValid3 func = producesValidsOnGens3 func genUnchecked + producesValidsOnArbitrary3 - :: (Show a, Show b, Show c, Show d, - Arbitrary a, Arbitrary b, Arbitrary c, - Validity d) - => (a -> b -> c -> d) - -> Property -producesValidsOnArbitrary3 func - = producesValidsOnGens3 func arbitrary + :: ( Show a + , Show b + , Show c + , Show d + , Arbitrary a + , Arbitrary b + , Arbitrary c + , Validity d + ) + => (a -> b -> c -> d) -> Property +producesValidsOnArbitrary3 func = producesValidsOnGens3 func arbitrary diff --git a/src/Test/Validity/Functor.hs b/src/Test/Validity/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Functor.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Functor properties +-- +-- You will need @TypeApplications@ to use these. +module Test.Validity.Functor + ( functorSpecOnValid + , functorSpec + , functorSpecOnArbitrary + , functorSpecOnGens + ) where + +import Data.Data + +import Data.GenValidity + +import Test.Hspec +import Test.QuickCheck + +import Test.Validity.Functions +import Test.Validity.Operations +import Test.Validity.Relations +import Test.Validity.Utils + +fmapTypeStr + :: forall (f :: * -> *). + (Typeable f) + => String +fmapTypeStr = + unwords + [ "fmap" + , "::" + , "(a" + , "->" + , "b)" + , "->" + , nameOf @f + , "a" + , "->" + , nameOf @f + , "b" + ] + +flTypeStr + :: forall (f :: * -> *). + (Typeable f) + => String +flTypeStr = + unwords ["(<$)", "::", "a", "->", nameOf @f, "b", "->", nameOf @f, "a"] + +-- | Standard test spec for properties of Functor instances for values generated with GenValid instances +-- +-- Example usage: +-- +-- > functorSpecOnArbitrary @[] +functorSpecOnValid + :: forall (f :: * -> *). + (Eq (f Int), Show (f Int), Functor f, Typeable f, GenValid (f Int)) + => Spec +functorSpecOnValid = functorSpecWithInts @f genValid + +-- | Standard test spec for properties of Functor instances for values generated with GenUnchecked instances +-- +-- Example usage: +-- +-- > functorSpecOnArbitrary @[] +functorSpec + :: forall (f :: * -> *). + (Eq (f Int), Show (f Int), Functor f, Typeable f, GenUnchecked (f Int)) + => Spec +functorSpec = functorSpecWithInts @f genUnchecked + +-- | Standard test spec for properties of Functor instances for values generated with Arbitrary instances +-- +-- Example usage: +-- +-- > functorSpecOnArbitrary @[] +functorSpecOnArbitrary + :: forall (f :: * -> *). + (Eq (f Int), Show (f Int), Functor f, Typeable f, Arbitrary (f Int)) + => Spec +functorSpecOnArbitrary = functorSpecWithInts @f arbitrary + +functorSpecWithInts + :: forall (f :: * -> *). + (Eq (f Int), Show (f Int), Functor f, Typeable f) + => Gen (f Int) -> Spec +functorSpecWithInts gen = + functorSpecOnGens + @f + @Int + genUnchecked + "int" + gen + (unwords [nameOf @f, "of ints"]) + ((+) <$> genUnchecked) + "increments" + ((*) <$> genUnchecked) + "scalings" + +-- | Standard test spec for properties of Functor instances for values generated by given generators (and names for those generator). +-- +-- Example usage: +-- +-- > functorSpecOnGens +-- > @[] +-- > @Int +-- > (pure 4) "four" +-- > (genListOf $ pure 5) "list of fives" +-- > ((+) <$> genValid) "additions" +-- > ((*) <$> genValid) "multiplications" +functorSpecOnGens + :: forall (f :: * -> *) (a :: *) (b :: *) (c :: *). + ( Show a + , Show (f a) + , Show (f c) + , Eq (f a) + , Eq (f c) + , Functor f + , Typeable f + , Typeable a + , Typeable b + , Typeable c + ) + => Gen a + -> String + -> Gen (f a) + -> String + -> Gen (b -> c) + -> String + -> Gen (a -> b) + -> String + -> Spec +functorSpecOnGens gena genaname gen genname genf genfname geng gengname = + parallel $ + describe ("Functor " ++ nameOf @f) $ do + describe (fmapTypeStr @f) $ do + it + (unwords + [ "satisfies the first Fuctor law: 'fmap id == id' for" + , genDescr @(f a) genname + ]) $ + equivalentOnGen (fmap @f id) (id @(f a)) gen + it + (unwords + [ "satisfieds the second Functor law: 'fmap (f . g) == fmap f . fmap g' for" + , genDescr @(f a) genname + , "'s" + , "given to" + , genDescr @(b -> c) genfname + , "and" + , genDescr @(a -> b) gengname + ]) $ + forAll (Anon <$> genf) $ \(Anon f) -> + forAll (Anon <$> geng) $ \(Anon g) -> + equivalentOnGen (fmap (f . g)) (fmap f . fmap g) gen + describe (flTypeStr @f) $ + it + (unwords + [ "is equivalent to its default implementation for" + , genDescr @a genaname + , "and" + , genDescr @(f a) genname + ]) $ + forAll gena $ \a -> equivalentOnGen ((<$) a) (fmap $ const a) gen diff --git a/src/Test/Validity/GenRelativeValidity.hs b/src/Test/Validity/GenRelativeValidity.hs --- a/src/Test/Validity/GenRelativeValidity.hs +++ b/src/Test/Validity/GenRelativeValidity.hs @@ -1,22 +1,28 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for GenRelativeValidity instances +-- +-- You will need @TypeApplications@ to use these. module Test.Validity.GenRelativeValidity - ( -- * Tests for GenRelativeValidity instances - genRelativeValiditySpec - , genRelativeValidityValidGeneratesValid - , genRelativeValidityInvalidGeneratesInvalid + ( genRelativeValiditySpec + , genRelativeValidSpec + , genRelativeInvalidSpec + , genRelativeValidGeneratesValid + , genRelativeInvalidGeneratesInvalid ) where -import Data.Data -import Data.Proxy +import Data.Data -import Data.GenRelativeValidity -import Data.GenValidity +import Data.GenRelativeValidity +import Data.GenValidity -import Test.Hspec -import Test.QuickCheck +import Test.Hspec +import Test.QuickCheck -import Test.Validity.Utils +import Test.Validity.Utils -- | A @Spec@ that specifies that @genValidFor@ and @genInvalidFor@ work as -- intended. @@ -26,60 +32,90 @@ -- -- Example usage: -- --- > relativeGenValiditySpec (proxy :: MyDataFor) (proxy :: MyOtherData) +-- > relativeGenValiditySpec @MyDataFor @MyOtherData genRelativeValiditySpec - :: (Typeable a, Typeable b, - Show a, Show b, - GenValidity a, GenValidity b, - RelativeValidity a b, - GenRelativeValidity a b) - => Proxy a - -> Proxy b - -> Spec -genRelativeValiditySpec one two = do - let nameOne = nameOf one - let nameTwo = nameOf two - describe ("GenRelativeValidity " ++ nameOne ++ " " ++ nameTwo) $ do - describe ("genValidFor :: " ++ nameTwo ++ " -> Gen " ++ nameOne) $ - it ("only generates valid \'" - ++ nameOne - ++ "\'s for the " - ++ nameTwo) $ - genRelativeValidityValidGeneratesValid one two + :: forall a b. + ( Typeable a + , Typeable b + , Show a + , Show b + , GenValid a + , GenValid b + , RelativeValidity a b + , GenRelativeValid a b + , GenRelativeInvalid a b + ) + => Spec +genRelativeValiditySpec = do + genRelativeValidSpec @a @b + genRelativeValidSpec @a @b - describe ("genInvalidFor :: " ++ nameTwo ++ " -> Gen " ++ nameOne) $ - it ("only generates invalid \'" - ++ nameOne - ++ "\'s for the " - ++ nameTwo) $ - genRelativeValidityInvalidGeneratesInvalid one two +genRelativeValidSpec + :: forall a b. + ( Typeable a + , Typeable b + , Show a + , Show b + , GenValid a + , GenValid b + , RelativeValidity a b + , GenRelativeValid a b + ) + => Spec +genRelativeValidSpec = + parallel $ do + let nameOne = nameOf @a + let nameTwo = nameOf @a + describe ("GenRelativeValidity " ++ nameOne ++ " " ++ nameTwo) $ do + describe ("genValidFor :: " ++ nameTwo ++ " -> Gen " ++ nameOne) $ + it + ("only generates valid \'" ++ + nameOne ++ "\'s for the " ++ nameTwo) $ + genRelativeValidGeneratesValid @a @b +genRelativeInvalidSpec + :: forall a b. + ( Typeable a + , Typeable b + , Show a + , Show b + , GenValid a + , GenValid b + , RelativeValidity a b + , GenRelativeInvalid a b + ) + => Spec +genRelativeInvalidSpec = + parallel $ do + let nameOne = nameOf @a + let nameTwo = nameOf @a + describe ("GenRelativeInvalid " ++ nameOne ++ " " ++ nameTwo) $ do + describe ("genInvalidFor :: " ++ nameTwo ++ " -> Gen " ++ nameOne) $ + it + ("only generates invalid \'" ++ + nameOne ++ "\'s for the " ++ nameTwo) $ + genRelativeInvalidGeneratesInvalid @a @b + -- | @genValidFor b@ only generates values that satisfy @isValidFor b@ -genRelativeValidityValidGeneratesValid - :: (Show a, Show b, - GenValidity a, GenValidity b, - RelativeValidity a b, - GenRelativeValidity a b) - => Proxy a - -> Proxy b - -> Property -genRelativeValidityValidGeneratesValid one two = - forAll genValid $ \b -> - forAll (genValidFor b) $ \a -> - (a `asProxyTypeOf` one) - `shouldSatisfy` (`isValidFor` (b `asProxyTypeOf` two)) +genRelativeValidGeneratesValid + :: forall a b. + (Show a, Show b, GenValid b, RelativeValidity a b, GenRelativeValid a b) + => Property +genRelativeValidGeneratesValid = + forAll genValid $ \(b :: b) -> + forAll (genValidFor b) $ \(a :: a) -> a `shouldSatisfy` (`isValidFor` b) -- | @genInvalidFor b@ only generates values that do not satisfy @isValidFor b@ -genRelativeValidityInvalidGeneratesInvalid - :: (Show a, Show b, - GenValidity a, GenValidity b, - RelativeValidity a b, - GenRelativeValidity a b) - => Proxy a - -> Proxy b - -> Property -genRelativeValidityInvalidGeneratesInvalid one two = - forAll genUnchecked $ \b -> - forAll (genInvalidFor b) $ \a -> - (a `asProxyTypeOf` one) - `shouldNotSatisfy` (`isValidFor` (b `asProxyTypeOf` two)) +genRelativeInvalidGeneratesInvalid + :: forall a b. + ( Show a + , Show b + , GenUnchecked b + , RelativeValidity a b + , GenRelativeInvalid a b + ) + => Property +genRelativeInvalidGeneratesInvalid = + forAll genUnchecked $ \(b :: b) -> + forAll (genInvalidFor b) $ \(a :: a) -> + a `shouldNotSatisfy` (`isValidFor` b) diff --git a/src/Test/Validity/GenValidity.hs b/src/Test/Validity/GenValidity.hs --- a/src/Test/Validity/GenValidity.hs +++ b/src/Test/Validity/GenValidity.hs @@ -1,77 +1,118 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for GenValidity instances module Test.Validity.GenValidity - ( -- * Tests for GenValidity instances - genValiditySpec - , genValidityValidGeneratesValid + ( genValiditySpec + , genValidSpec + , genInvalidSpec + , genValidGeneratesValid , genGeneratesValid - , genValidityInvalidGeneratesInvalid + , genInvalidGeneratesInvalid , genGeneratesInvalid ) where -import Data.Data +import Data.Data -import Data.GenValidity +import Data.GenValidity -import Test.Hspec -import Test.QuickCheck +import Test.Hspec +import Test.QuickCheck -import Test.Validity.Utils +import Test.Validity.Utils --- | A @Spec@ that specifies that @genValid@ only generates valid data and that --- @genInvalid@ only generates invalid data. +-- | A spec for properties of 'GenValid' and 'GenInvalid' instances. -- -- In general it is a good idea to add this spec to your test suite if you -- write a custom implementation of @genValid@ or @genInvalid@. -- -- Example usage: -- --- > genValiditySpec (Proxy :: Proxy MyData) +-- > genValiditySpec @Int genValiditySpec - :: (Typeable a, Show a, GenValidity a) - => Proxy a - -> Spec -genValiditySpec proxy = do - let name = nameOf proxy - describe ("GenValidity " ++ name) $ do - describe ("genValid :: Gen " ++ name) $ - it ("only generates valid \'" ++ name ++ "\'s") $ - genValidityValidGeneratesValid proxy + :: forall a. + (Typeable a, Show a, GenValid a, GenInvalid a) + => Spec +genValiditySpec = do + genValidSpec @a + genInvalidSpec @a - describe ("genInvalid :: Gen " ++ name) $ - it ("only generates invalid \'" ++ name ++ "\'s") $ - genValidityInvalidGeneratesInvalid proxy +-- | A @Spec@ that specifies that @genValid@ only generates valid data. +-- +-- Example usage: +-- +-- > genValidSpec @Int +genValidSpec + :: forall a. + (Typeable a, Show a, GenValid a) + => Spec +genValidSpec = + parallel $ do + let name = nameOf @a + describe ("GenValid " ++ name) $ do + describe ("genValid :: Gen " ++ name) $ + it ("only generates valid \'" ++ name ++ "\'s") $ + genValidGeneratesValid @a +-- | A @Spec@ that specifies that @genInvalid@ only generates invalid data. +-- +-- Example usage: +-- +-- > genInvalidSpec @Double +genInvalidSpec + :: forall a. + (Typeable a, Show a, GenInvalid a) + => Spec +genInvalidSpec = + parallel $ do + let name = nameOf @a + describe ("GenInvalid " ++ name) $ do + describe ("genInvalid :: Gen " ++ name) $ + it ("only generates invalid \'" ++ name ++ "\'s") $ + genInvalidGeneratesInvalid @a + -- | @genValid@ only generates valid data -genValidityValidGeneratesValid - :: forall a. (Show a, GenValidity a) - => Proxy a - -> Property -genValidityValidGeneratesValid _ = - genGeneratesValid (genValid :: Gen a) +-- +-- prop> genValidGeneratesValid @() +-- prop> genValidGeneratesValid @Bool +-- prop> genValidGeneratesValid @Ordering +-- prop> genValidGeneratesValid @Char +-- prop> genValidGeneratesValid @Int +-- prop> genValidGeneratesValid @Float +-- prop> genValidGeneratesValid @Double +-- prop> genValidGeneratesValid @Integer +-- prop> genValidGeneratesValid @(Maybe Int) +-- prop> genValidGeneratesValid @[Int] +genValidGeneratesValid + :: forall a. + (Show a, GenValid a) + => Property +genValidGeneratesValid = genGeneratesValid @a genValid -- | The given generator generates only valid data points genGeneratesValid - :: (Show a, Validity a) - => Gen a - -> Property -genGeneratesValid gen = - forAll gen (`shouldSatisfy` isValid) - + :: forall a. + (Show a, Validity a) + => Gen a -> Property +genGeneratesValid gen = forAll gen (`shouldSatisfy` isValid) -- | @genValid@ only generates invalid data -genValidityInvalidGeneratesInvalid - :: forall a. (Show a, GenValidity a) - => Proxy a - -> Property -genValidityInvalidGeneratesInvalid _ = - genGeneratesInvalid (genInvalid :: Gen a) +-- +-- prop> genInvalidGeneratesInvalid @Float +-- prop> genInvalidGeneratesInvalid @Double +-- prop> genInvalidGeneratesInvalid @(Maybe Double) +-- prop> genInvalidGeneratesInvalid @[Double] +genInvalidGeneratesInvalid + :: forall a. + (Show a, GenInvalid a) + => Property +genInvalidGeneratesInvalid = genGeneratesInvalid @a genInvalid -- | The given generator generates only invalid data points genGeneratesInvalid - :: (Show a, Validity a) - => Gen a - -> Property -genGeneratesInvalid gen = - forAll gen (`shouldNotSatisfy` isValid) - + :: forall a. + (Show a, Validity a) + => Gen a -> Property +genGeneratesInvalid gen = forAll gen (`shouldNotSatisfy` isValid) diff --git a/src/Test/Validity/Monad.hs b/src/Test/Validity/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Monad.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Monad properties +-- +-- You will need @TypeApplications@ to use these. +module Test.Validity.Monad + ( monadSpecOnValid + , monadSpec + , monadSpecOnArbitrary + , monadSpecOnGens + ) where + +import Data.Data + +import Control.Monad (ap) +import Data.GenValidity +import Test.QuickCheck.Gen (unGen) +import Test.QuickCheck.Random (mkQCGen) + +import Test.Hspec +import Test.QuickCheck + +import Test.Validity.Functions +import Test.Validity.Operations +import Test.Validity.Relations +import Test.Validity.Utils + +returnTypeStr + :: forall (m :: * -> *). + (Typeable m) + => String +returnTypeStr = unwords ["return", "::", "a", "->", nameOf @m, "a"] + +bindTypeStr + :: forall (m :: * -> *). + (Typeable m) + => String +bindTypeStr = + unwords + [ "(>>=)" + , "::" + , nameOf @m + , "a" + , "->" + , "(b" + , "->" + , nameOf @m + , "a)" + , "->" + , nameOf @m + , "b" + ] + +-- | Standard test spec for properties of Monad instances for values generated with GenValid instances +-- +-- Example usage: +-- +-- > monadSpecOnArbitrary @[] +monadSpecOnValid + :: forall (f :: * -> *). + (Eq (f Int), Show (f Int), Monad f, Typeable f, GenValid (f Int)) + => Spec +monadSpecOnValid = monadSpecWithInts @f genValid + +-- | Standard test spec for properties of Monad instances for values generated with GenUnchecked instances +-- +-- Example usage: +-- +-- > monadSpecOnArbitrary @[] +monadSpec + :: forall (f :: * -> *). + (Eq (f Int), Show (f Int), Monad f, Typeable f, GenUnchecked (f Int)) + => Spec +monadSpec = monadSpecWithInts @f genUnchecked + +-- | Standard test spec for properties of Monad instances for values generated with Arbitrary instances +-- +-- Example usage: +-- +-- > monadSpecOnArbitrary @[] +monadSpecOnArbitrary + :: forall (f :: * -> *). + (Eq (f Int), Show (f Int), Monad f, Typeable f, Arbitrary (f Int)) + => Spec +monadSpecOnArbitrary = monadSpecWithInts @f arbitrary + +monadSpecWithInts + :: forall (f :: * -> *). + (Eq (f Int), Show (f Int), Monad f, Typeable f) + => Gen (f Int) -> Spec +monadSpecWithInts gen = + monadSpecOnGens + @f + @Int + genUnchecked + "int" + gen + (unwords [nameOf @f, "of ints"]) + gen + (unwords [nameOf @f, "of ints"]) + ((+) <$> genUnchecked) + "increments" + (do a <- genUnchecked + let qcgen = mkQCGen a + let func = unGen gen qcgen + pure $ \b -> func b) + "perturbations using the int" + (do a <- genUnchecked + let qcgen = mkQCGen a + let func = unGen gen qcgen + pure $ \b -> func (2 * b)) + "perturbations using the double the int" + (pure <$> ((+) <$> genUnchecked)) + (unwords [nameOf @f, "of additions"]) + +-- | Standard test spec for properties of Monad instances for values generated by given generators (and names for those generator). +-- +-- Example usage: +-- +-- > monadSpecOnGens +-- > @[] +-- > @Int +-- > (pure 4) +-- > "four" +-- > (genListOf $ pure 5) +-- > "list of fives" +-- > (genListOf $ pure 6) +-- > "list of sixes" +-- > ((*) <$> genValid) +-- > "factorisations" +-- > (pure $ \a -> [a]) +-- > "singletonisation" +-- > (pure $ \a -> [a]) +-- > "singletonisation" +-- > (pure $ pure (+ 1)) +-- > "increment in list" +monadSpecOnGens + :: forall (f :: * -> *) (a :: *) (b :: *) (c :: *). + ( Show a + , Eq a + , Show (f a) + , Show (f b) + , Show (f c) + , Eq (f a) + , Eq (f b) + , Eq (f c) + , Monad f + , Typeable f + , Typeable a + , Typeable b + , Typeable c + ) + => Gen a + -> String + -> Gen (f a) + -> String + -> Gen (f b) + -> String + -> Gen (a -> b) + -> String + -> Gen (a -> f b) + -> String + -> Gen (b -> f c) + -> String + -> Gen (f (a -> b)) + -> String + -> Spec +monadSpecOnGens gena genaname gen genname genb genbname geng gengname genbf genbfname gencf gencfname genfab genfabname = + parallel $ + describe ("Monad " ++ nameOf @f) $ do + describe (unwords [returnTypeStr @f, "and", bindTypeStr @f]) $ do + it + (unwords + ["satisfy the first Monad law: 'return a >>= k = k a' for", genDescr @a genaname, "and", genDescr @(a -> f b) genbfname]) $ + equivalentOnGens2 + (\a (Anon k) -> return a >>= k) + (\a (Anon k) -> k a) + ((,) <$> gena <*> (Anon <$> genbf)) + it + (unwords + [ "satisfy the second Monad law: 'm >>= return = m' for" + , genDescr @(f a) genname + ]) $ + equivalentOnGen (\m -> m >>= return) (\m -> m) gen + describe (bindTypeStr @f) $ + it + (unwords + [ "satisfies the third Monad law: 'm >>= (x -> k x >>= h) = (m >>= k) >>= h' for" + , genDescr @(f a) genname + , genDescr @(a -> f b) genbfname + , "and" + , genDescr @(b -> f c) gencfname + ]) $ + equivalentOnGens3 + (\m (Anon k) (Anon h) -> m >>= (\x -> k x >>= h)) + (\m (Anon k) (Anon h) -> (m >>= k) >>= h) + ((,,) <$> gen <*> (Anon <$> genbf) <*> (Anon <$> gencf)) + describe (unwords ["relation with Applicative", nameOf @f]) $ do + it + (unwords + ["satisfies 'pure = return' for", genDescr @(f a) genname]) $ + equivalentOnGen (pure @f) (return @f) gena + it + (unwords + [ "satisfies '(<*>) = ap' for" + , genDescr @(f (a -> b)) $ genfabname + , "and" + , genDescr @(f a) genname + ]) $ + equivalentOnGens2 + (\(Anon a) b -> a <*> b) + (\(Anon a) b -> ap a b) + ((,) <$> (Anon <$> genfab) <*> gen) + it + (unwords + [ "satisfies '(>>) = (*>)' for" + , genDescr @(f a) genname + , "and" + , genDescr @(f b) genbname + ]) $ + equivalentOnGens2 (>>) (*>) ((,) <$> gen <*> genb) + describe (unwords ["relation with Functor", nameOf @f]) $ do + it + (unwords + [ "satisfies 'fmap f xs = xs >>= return . f' for" + , genDescr @(a -> b) gengname + , "and" + , genDescr @(f a) genname + ]) $ + equivalentOnGens2 + (\(Anon f) xs -> fmap f xs) + (\(Anon f) xs -> xs >>= (return . f)) + ((,) <$> (Anon <$> geng) <*> gen) diff --git a/src/Test/Validity/Monoid.hs b/src/Test/Validity/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Monoid.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Monoid properties +-- +-- You will need @TypeApplications@ to use these. +module Test.Validity.Monoid + ( monoidSpecOnValid + , monoidSpec + , monoidSpecOnArbitrary + , monoidSpecOnGen + ) where + +import Data.Data + +import Data.GenValidity + +import Test.Hspec +import Test.QuickCheck + +import Test.Validity.Functions +import Test.Validity.Operations +import Test.Validity.Relations +import Test.Validity.Utils + +memptyTypeStr + :: forall a. + Typeable a + => String +memptyTypeStr = unwords ["mempty", "::", nameOf @a] + +mappendTypeStr + :: forall a. + Typeable a + => String +mappendTypeStr = unwords ["mappend", "::", an, "->", an, "->", an] + where + an = nameOf @a + +mconcatTypeStr + :: forall a. + Typeable a + => String +mconcatTypeStr = unwords ["mconcat", "::", "[" ++ an ++ "]", "->", an] + where + an = nameOf @a + +-- | Standard test spec for properties of 'Monoid' instances for valid values +-- +-- Example usage: +-- +-- > monoidSpecOnValid @[Double] +monoidSpecOnValid + :: forall a. + (Show a, Eq a, Monoid a, Typeable a, GenValid a) + => Spec +monoidSpecOnValid = monoidSpecOnGen @a genValid "valid" + +-- | Standard test spec for properties of 'Monoid' instances for unchecked values +-- +-- Example usage: +-- +-- > monoidSpec @[Int] +monoidSpec + :: forall a. + (Show a, Eq a, Monoid a, Typeable a, GenUnchecked a) + => Spec +monoidSpec = monoidSpecOnGen @a genUnchecked "unchecked" + +-- | Standard test spec for properties of 'Monoid' instances for arbitrary values +-- +-- Example usage: +-- +-- > monoidSpecOnArbitrary @[Int] +monoidSpecOnArbitrary + :: forall a. + (Show a, Eq a, Monoid a, Typeable a, Arbitrary a) + => Spec +monoidSpecOnArbitrary = monoidSpecOnGen @a arbitrary "arbitrary" + +-- | Standard test spec for properties of Monoid instances for values generated by a given generator (and name for that generator). +-- +-- Example usage: +-- +-- > monoidSpecOnGen (pure "a") "singleton list of 'a'" +monoidSpecOnGen + :: forall a. + (Show a, Eq a, Monoid a, Typeable a) + => Gen a -> String -> Spec +monoidSpecOnGen gen genname = + parallel $ do + let name = nameOf @a + memptystr = memptyTypeStr @a + mappendstr = mappendTypeStr @a + mconcatstr = mconcatTypeStr @a + gen3 = (,,) <$> gen <*> gen <*> gen + genl = genListOf gen + describe ("Monoid " ++ name) $ do + let mem = mempty @a + mapp = mappend @a + mcon = mconcat @a + describe memptystr $ + it (unwords ["is the identity for", mappendstr]) $ + identityOnGen mapp mem gen + describe mappendstr $ + it "is an associative operation" $ associativeOnGens mapp gen3 + describe mconcatstr $ + it "is equivalent to its default implementation" $ + equivalentOnGen mcon (foldr mapp mem) genl diff --git a/src/Test/Validity/Operations.hs b/src/Test/Validity/Operations.hs --- a/src/Test/Validity/Operations.hs +++ b/src/Test/Validity/Operations.hs @@ -11,6 +11,7 @@ , leftIdentityOnGen , leftIdentityOnValid , leftIdentity + , leftIdentityOnArbitrary -- *** Right identity , rightIdentityOnElemWithEquality @@ -18,11 +19,13 @@ , rightIdentityOnGen , rightIdentityOnValid , rightIdentity + , rightIdentityOnArbitrary -- *** Identity , identityOnGen , identityOnValid , identity + , identityOnArbitrary -- ** Associativity , associativeOnGens diff --git a/src/Test/Validity/Operations/Associativity.hs b/src/Test/Validity/Operations/Associativity.hs --- a/src/Test/Validity/Operations/Associativity.hs +++ b/src/Test/Validity/Operations/Associativity.hs @@ -1,44 +1,44 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Test.Validity.Operations.Associativity - ( -- ** Associativity - associativeOnGens + ( associativeOnGens , associativeOnValids , associative , associativeOnArbitrary ) where -import Data.GenValidity +import Data.GenValidity -import Test.Hspec -import Test.QuickCheck +import Test.Hspec +import Test.QuickCheck associativeOnGens :: (Show a, Eq a) - => (a -> a -> a) - -> Gen (a, a, a) - -> Property + => (a -> a -> a) -> Gen (a, a, a) -> Property associativeOnGens op gen = forAll gen $ \(a, b, c) -> ((a `op` b) `op` c) `shouldBe` (a `op` (b `op` c)) associativeOnValids - :: (Show a, Eq a, GenValidity a) - => (a -> a -> a) - -> Property -associativeOnValids op - = associativeOnGens op genValid + :: (Show a, Eq a, GenValid a) + => (a -> a -> a) -> Property +associativeOnValids op = associativeOnGens op genValid +-- | +-- +-- prop> associative ((*) @Int) +-- prop> associative ((+) @Int) associative - :: (Show a, Eq a, GenValidity a) - => (a -> a -> a) - -> Property -associative op - = associativeOnGens op genUnchecked + :: (Show a, Eq a, GenUnchecked a) + => (a -> a -> a) -> Property +associative op = associativeOnGens op genUnchecked +-- | +-- +-- prop> associativeOnArbitrary ((*) @Int) +-- prop> associativeOnArbitrary ((+) @Int) associativeOnArbitrary :: (Show a, Eq a, Arbitrary a) - => (a -> a -> a) - -> Property -associativeOnArbitrary op - = associativeOnGens op arbitrary + => (a -> a -> a) -> Property +associativeOnArbitrary op = associativeOnGens op arbitrary diff --git a/src/Test/Validity/Operations/Commutativity.hs b/src/Test/Validity/Operations/Commutativity.hs --- a/src/Test/Validity/Operations/Commutativity.hs +++ b/src/Test/Validity/Operations/Commutativity.hs @@ -1,44 +1,47 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Test.Validity.Operations.Commutativity - ( -- ** Commutativity - commutativeOnGens + ( commutativeOnGens , commutativeOnValids , commutative , commutativeOnArbitrary ) where -import Data.GenValidity +import Data.GenValidity -import Test.Hspec -import Test.QuickCheck +import Test.Hspec +import Test.QuickCheck commutativeOnGens :: (Show a, Eq a) - => (a -> a -> a) - -> Gen (a, a) - -> Property + => (a -> a -> a) -> Gen (a, a) -> Property commutativeOnGens op gen = - forAll gen $ \(a, b) -> - (a `op` b) `shouldBe` (b `op` a) + forAll gen $ \(a, b) -> (a `op` b) `shouldBe` (b `op` a) +-- | +-- +-- prop> commutative ((+) @Double) +-- prop> commutative ((*) @Double) commutativeOnValids - :: (Show a, Eq a, GenValidity a) - => (a -> a -> a) - -> Property -commutativeOnValids op - = commutativeOnGens op genValid + :: (Show a, Eq a, GenValid a) + => (a -> a -> a) -> Property +commutativeOnValids op = commutativeOnGens op genValid +-- | +-- +-- prop> commutative ((+) @Int) +-- prop> commutative ((*) @Int) commutative - :: (Show a, Eq a, GenValidity a) - => (a -> a -> a) - -> Property -commutative op - = commutativeOnGens op genUnchecked + :: (Show a, Eq a, GenUnchecked a) + => (a -> a -> a) -> Property +commutative op = commutativeOnGens op genUnchecked +-- | +-- +-- prop> commutativeOnArbitrary ((+) @Int) +-- prop> commutativeOnArbitrary ((*) @Int) commutativeOnArbitrary :: (Show a, Eq a, Arbitrary a) - => (a -> a -> a) - -> Property -commutativeOnArbitrary op - = commutativeOnGens op arbitrary + => (a -> a -> a) -> Property +commutativeOnArbitrary op = commutativeOnGens op arbitrary diff --git a/src/Test/Validity/Operations/Identity.hs b/src/Test/Validity/Operations/Identity.hs --- a/src/Test/Validity/Operations/Identity.hs +++ b/src/Test/Validity/Operations/Identity.hs @@ -1,28 +1,28 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Test.Validity.Operations.Identity - ( -- *** Left identity - leftIdentityOnElemWithEquality + ( leftIdentityOnElemWithEquality , leftIdentityOnGenWithEquality , leftIdentityOnGen , leftIdentityOnValid , leftIdentity - - -- *** Right identity + , leftIdentityOnArbitrary , rightIdentityOnElemWithEquality , rightIdentityOnGenWithEquality , rightIdentityOnGen , rightIdentityOnValid , rightIdentity - + , rightIdentityOnArbitrary , identityOnGen , identityOnValid , identity + , identityOnArbitrary ) where -import Data.GenValidity +import Data.GenValidity -import Test.QuickCheck +import Test.QuickCheck -- | -- @@ -32,18 +32,18 @@ -- \forall a: (b \star a) \doteq a -- \] leftIdentityOnElemWithEquality - :: (b -> a -> a) -- ^ A binary operation + :: (b -> a -> a) -- ^ A binary operation -> (a -> a -> Bool) -- ^ An equality - -> b -- ^ A candidate left-identity - -> a -- ^ An element + -> b -- ^ A candidate left-identity + -> a -- ^ An element -> Bool leftIdentityOnElemWithEquality op eq b a = (b `op` a) `eq` a leftIdentityOnGenWithEquality :: Show a - => (b -> a -> a) -- ^ A binary operation + => (b -> a -> a) -- ^ A binary operation -> (a -> a -> Bool) -- ^ An equality - -> b -- ^ A candidate left-identity + -> b -- ^ A candidate left-identity -> Gen a -> Property leftIdentityOnGenWithEquality op eq b gen = @@ -52,47 +52,55 @@ leftIdentityOnGen :: (Show a, Eq a) => (b -> a -> a) -- ^ A binary operation - -> b -- ^ A candidate left-identity + -> b -- ^ A candidate left-identity -> Gen a -> Property leftIdentityOnGen op = leftIdentityOnGenWithEquality op (==) +-- | +-- +-- prop> leftIdentityOnValid (flip ((^) @Double @Int)) 1 leftIdentityOnValid - :: (Show a, Eq a, GenValidity a) - => (b -> a -> a) - -> b - -> Property -leftIdentityOnValid op b - = leftIdentityOnGen op b genValid + :: (Show a, Eq a, GenValid a) + => (b -> a -> a) -> b -> Property +leftIdentityOnValid op b = leftIdentityOnGen op b genValid +-- | +-- +-- prop> leftIdentity (flip ((^) @Int @Int)) 1 leftIdentity - :: (Show a, Eq a, GenValidity a) - => (b -> a -> a) - -> b - -> Property -leftIdentity op b - = leftIdentityOnGen op b genUnchecked + :: (Show a, Eq a, GenUnchecked a) + => (b -> a -> a) -> b -> Property +leftIdentity op b = leftIdentityOnGen op b genUnchecked -- | -- +-- prop> leftIdentityOnArbitrary (flip ((^) @Int @Int)) 1 +leftIdentityOnArbitrary + :: (Show a, Eq a, Arbitrary a) + => (b -> a -> a) -> b -> Property +leftIdentityOnArbitrary op b = leftIdentityOnGen op b arbitrary + +-- | +-- -- \[ -- RightIdentity(\star, \doteq, b) -- \quad\equiv\quad -- \forall a: (a \star b) \doteq a -- \] rightIdentityOnElemWithEquality - :: (a -> b -> a) -- ^ A binary operation + :: (a -> b -> a) -- ^ A binary operation -> (a -> a -> Bool) -- ^ An equality - -> b -- ^ A candidate right-identity - -> a -- ^ An element + -> b -- ^ A candidate right-identity + -> a -- ^ An element -> Bool rightIdentityOnElemWithEquality op eq b a = (a `op` b) `eq` a rightIdentityOnGenWithEquality :: Show a - => (a -> b -> a) -- ^ A binary operation + => (a -> b -> a) -- ^ A binary operation -> (a -> a -> Bool) -- ^ An equality - -> b -- ^ A candidate right-identity + -> b -- ^ A candidate right-identity -> Gen a -> Property rightIdentityOnGenWithEquality op eq b gen = @@ -100,49 +108,65 @@ rightIdentityOnGen :: (Show a, Eq a) - => (a -> b -> a) -- ^ A binary operation - -> b -- ^ A candidate right-identity + => (a -> b -> a) -- ^ A binary operation + -> b -- ^ A candidate right-identity -> Gen a -> Property rightIdentityOnGen op = rightIdentityOnGenWithEquality op (==) +-- | +-- +-- prop> rightIdentityOnValid ((^) @Double) 1 rightIdentityOnValid - :: (Show a, Eq a, GenValidity a) - => (a -> b -> a) - -> b - -> Property -rightIdentityOnValid op b - = rightIdentityOnGen op b genValid + :: (Show a, Eq a, GenValid a) + => (a -> b -> a) -> b -> Property +rightIdentityOnValid op b = rightIdentityOnGen op b genValid +-- | +-- +-- prop> rightIdentity ((^) @Int) 1 rightIdentity - :: (Show a, Eq a, GenValidity a) - => (a -> b -> a) - -> b - -> Property -rightIdentity op b - = rightIdentityOnGen op b genUnchecked + :: (Show a, Eq a, GenUnchecked a) + => (a -> b -> a) -> b -> Property +rightIdentity op b = rightIdentityOnGen op b genUnchecked +-- | +-- +-- prop> rightIdentityOnArbitrary ((^) @Int) 1 +rightIdentityOnArbitrary + :: (Show a, Eq a, Arbitrary a) + => (a -> b -> a) -> b -> Property +rightIdentityOnArbitrary op b = rightIdentityOnGen op b arbitrary + identityOnGen :: (Show a, Eq a) - => (a -> a -> a) - -> a - -> Gen a - -> Property + => (a -> a -> a) -> a -> Gen a -> Property identityOnGen op e gen = leftIdentityOnGen op e gen .&&. rightIdentityOnGen op e gen +-- | +-- +-- prop> identityOnValid ((*) @Double) 1 +-- prop> identityOnValid ((+) @Double) 0 identityOnValid - :: (Show a, Eq a, GenValidity a) - => (a -> a -> a) - -> a - -> Property -identityOnValid op a - = identityOnGen op a genValid + :: (Show a, Eq a, GenValid a) + => (a -> a -> a) -> a -> Property +identityOnValid op a = identityOnGen op a genValid +-- | +-- +-- prop> identity ((*) @Int) 1 +-- prop> identity ((+) @Int) 0 identity - :: (Show a, Eq a, GenValidity a) - => (a -> a -> a) - -> a - -> Property -identity op e - = identityOnGen op e genUnchecked + :: (Show a, Eq a, GenUnchecked a) + => (a -> a -> a) -> a -> Property +identity op e = identityOnGen op e genUnchecked + +-- | +-- +-- prop> identityOnArbitrary ((*) @Int) 1 +-- prop> identityOnArbitrary ((+) @Int) 0 +identityOnArbitrary + :: (Show a, Eq a, Arbitrary a) + => (a -> a -> a) -> a -> Property +identityOnArbitrary op a = identityOnGen op a arbitrary diff --git a/src/Test/Validity/Ord.hs b/src/Test/Validity/Ord.hs --- a/src/Test/Validity/Ord.hs +++ b/src/Test/Validity/Ord.hs @@ -1,46 +1,216 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Ord properties +-- +-- You will need @TypeApplications@ to use these. module Test.Validity.Ord - ( -- * Ord properties - ordSpec + ( ordSpecOnGen + , ordSpecOnValid + , ordSpec + , ordSpecOnArbitrary ) where -import Data.Data -import Data.Proxy +import Data.Data -import Data.GenValidity +import Data.GenValidity -import Test.Hspec +import Test.Hspec +import Test.QuickCheck -import Test.Validity.Relations -import Test.Validity.Utils +import Test.Validity.Functions +import Test.Validity.Relations +import Test.Validity.Utils +{-# ANN module "HLint: ignore Use <=" #-} + +{-# ANN module "HLint: ignore Use >=" #-} + +{-# ANN module "HLint: ignore Use <" #-} + +{-# ANN module "HLint: ignore Use >" #-} + +leTypeStr + :: forall a. + Typeable a + => String +leTypeStr = binRelStr @a "<=" + +geTypeStr + :: forall a. + Typeable a + => String +geTypeStr = binRelStr @a ">=" + +ltTypeStr + :: forall a. + Typeable a + => String +ltTypeStr = binRelStr @a "<" + +gtTypeStr + :: forall a. + Typeable a + => String +gtTypeStr = binRelStr @a ">" + +-- | Standard test spec for properties of Ord instances for valid values +-- +-- Example usage: +-- +-- > ordSpecOnValid @Double +ordSpecOnValid + :: forall a. + (Show a, Ord a, Typeable a, Arbitrary a) + => Spec +ordSpecOnValid = ordSpecOnGen @a arbitrary "unchecked" + +-- | Standard test spec for properties of Ord instances for unchecked values +-- +-- Example usage: +-- +-- > ordSpec @Int ordSpec - :: (Show a, Eq a, Ord a, Typeable a, GenValidity a) - => Proxy a - -> Spec -ordSpec proxy = do - let name = nameOf proxy - funlestr = unwords - [ "(<=) ::" - , name - , "->" - , name - , "-> Ordering" - ] - cmp a b = a `asProxyTypeOf` proxy <= b - describe ("Ord " ++ name) $ do - it ("is instantated such that " - ++ funlestr - ++ " is reflexive") $ - reflexivity cmp + :: forall a. + (Show a, Ord a, Typeable a, GenUnchecked a) + => Spec +ordSpec = ordSpecOnGen @a genUnchecked "unchecked" - it ("is instantated such that " - ++ funlestr - ++ " is antisymmetric") $ - antisymmetry cmp +-- | Standard test spec for properties of Ord instances for arbitrary values +-- +-- Example usage: +-- +-- > ordSpecOnArbitrary @Int +ordSpecOnArbitrary + :: forall a. + (Show a, Ord a, Typeable a, Arbitrary a) + => Spec +ordSpecOnArbitrary = ordSpecOnGen @a arbitrary "unchecked" - it ("is instantated such that " - ++ funlestr - ++ " is transitive") $ - transitivity cmp +-- | Standard test spec for properties of Ord instances for values generated by a given generator (and name for that generator). +-- +-- Example usage: +-- +-- > ordSpecOnGen ((* 2) <$> genValid @Int) "even" +ordSpecOnGen + :: forall a. + (Show a, Eq a, Ord a, Typeable a) + => Gen a -> String -> Spec +ordSpecOnGen gen genname = + parallel $ do + let name = nameOf @a + funlestr = leTypeStr @a + fungestr = geTypeStr @a + funltstr = ltTypeStr @a + fungtstr = gtTypeStr @a + cmple = ((<=) @a) + cmpge = ((>=) @a) + cmplt = ((<) @a) + cmpgt = ((>) @a) + gen2 = (,) <$> gen <*> gen + gen3 = (,,) <$> gen <*> gen <*> gen + describe ("Ord " ++ name) $ do + describe funlestr $ do + it + (unwords + [ "is reflexive for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + reflexivityOnGen cmple gen + it + (unwords + [ "is antisymmetric for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + antisymmetryOnGens cmple gen2 + it + (unwords + [ "is transitive for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + transitivityOnGens cmple gen3 + it + (unwords + [ "is equivalent to (\\a b -> compare a b /= GT) for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + equivalentOnGens2 cmple (\a b -> compare a b /= GT) gen2 + describe fungestr $ do + it + (unwords + [ "is reflexive for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + reflexivityOnGen cmpge gen + it + (unwords + [ "is antisymmetric for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + antisymmetryOnGens cmpge gen2 + it + (unwords + [ "is transitive for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + transitivityOnGens cmpge gen3 + it + (unwords + [ "is equivalent to (\\a b -> compare a b /= LT) for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + equivalentOnGens2 cmpge (\a b -> compare a b /= LT) gen2 + describe funltstr $ do + it + (unwords + [ "is antireflexive for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + antireflexivityOnGen cmplt gen + it + (unwords + [ "is transitive for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + transitivityOnGens cmplt gen3 + it + (unwords + [ "is equivalent to (\\a b -> compare a b == LT) for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + equivalentOnGens2 cmplt (\a b -> compare a b == LT) gen2 + describe fungtstr $ do + it + (unwords + [ "is antireflexive for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + antireflexivityOnGen cmpgt gen + it + (unwords + [ "is transitive for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + transitivityOnGens cmpgt gen3 + it + (unwords + [ "is equivalent to (\\a b -> compare a b == GT) for" + , "\"" ++ genname + , name ++ "\"" ++ "'s" + ]) $ + equivalentOnGens2 cmpgt (\a b -> compare a b == GT) gen2 diff --git a/src/Test/Validity/Relations.hs b/src/Test/Validity/Relations.hs --- a/src/Test/Validity/Relations.hs +++ b/src/Test/Validity/Relations.hs @@ -21,11 +21,18 @@ -- ** Antisymmetry , antisymmetricOnElemsWithEquality , antisymmetryOnGensWithEquality - , antisymmetryOnGensEq + , antisymmetryOnGens , antisymmetryOnValid , antisymmetry , antisymmetryOnArbitrary + -- ** Antireflexivity + , antireflexiveOnElem + , antireflexivityOnGen + , antireflexivityOnValid + , antireflexivity + , antireflexivityOnArbitrary + -- ** Symmetry , symmetricOnElems , symmetryOnGens @@ -34,8 +41,9 @@ , symmetryOnArbitrary ) where -import Test.Validity.Relations.Reflexivity +import Test.Validity.Relations.Antireflexivity import Test.Validity.Relations.Antisymmetry +import Test.Validity.Relations.Reflexivity import Test.Validity.Relations.Symmetry import Test.Validity.Relations.Transitivity diff --git a/src/Test/Validity/Relations/Antireflexivity.hs b/src/Test/Validity/Relations/Antireflexivity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Relations/Antireflexivity.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Validity.Relations.Antireflexivity + ( antireflexiveOnElem + , antireflexivityOnGen + , antireflexivityOnValid + , antireflexivity + , antireflexivityOnArbitrary + ) where + +import Data.GenValidity + +import Test.QuickCheck + +-- | +-- +-- \[ +-- Antireflexive(\prec) +-- \quad\equiv\quad +-- \forall a: \neg (a \prec a) +-- \] +antireflexiveOnElem + :: (a -> a -> Bool) -- ^ A relation + -> a -- ^ An element + -> Bool +antireflexiveOnElem func a = not $ func a a + +antireflexivityOnGen + :: Show a + => (a -> a -> Bool) -> Gen a -> Property +antireflexivityOnGen func gen = forAll gen $ antireflexiveOnElem func + +-- | +-- +-- prop> antireflexivityOnValid ((<) @Double) +-- prop> antireflexivityOnValid ((/=) @Double) +-- prop> antireflexivityOnValid ((>) @Double) +antireflexivityOnValid + :: (Show a, GenValid a) + => (a -> a -> Bool) -> Property +antireflexivityOnValid func = antireflexivityOnGen func genValid + +-- | +-- +-- prop> antireflexivity ((<) @Int) +-- prop> antireflexivity ((/=) @Int) +-- prop> antireflexivity ((>) @Int) +antireflexivity + :: (Show a, GenUnchecked a) + => (a -> a -> Bool) -> Property +antireflexivity func = antireflexivityOnGen func genUnchecked + +-- | +-- +-- prop> antireflexivityOnArbitrary ((<) @Int) +-- prop> antireflexivityOnArbitrary ((/=) @Int) +-- prop> antireflexivityOnArbitrary ((>) @Int) +antireflexivityOnArbitrary + :: (Show a, Arbitrary a) + => (a -> a -> Bool) -> Property +antireflexivityOnArbitrary func = antireflexivityOnGen func arbitrary diff --git a/src/Test/Validity/Relations/Antisymmetry.hs b/src/Test/Validity/Relations/Antisymmetry.hs --- a/src/Test/Validity/Relations/Antisymmetry.hs +++ b/src/Test/Validity/Relations/Antisymmetry.hs @@ -1,19 +1,20 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Test.Validity.Relations.Antisymmetry ( antisymmetricOnElemsWithEquality , antisymmetryOnGensWithEquality - , antisymmetryOnGensEq + , antisymmetryOnGens , antisymmetryOnValid , antisymmetry , antisymmetryOnArbitrary ) where -import Data.GenValidity +import Data.GenValidity -import Test.QuickCheck +import Test.QuickCheck -import Test.Validity.Utils +import Test.Validity.Utils -- | -- @@ -25,48 +26,66 @@ antisymmetricOnElemsWithEquality :: (a -> a -> Bool) -- ^ A relation -> (a -> a -> Bool) -- ^ An equivalence relation - -> a -> a -- ^ Two elements + -> a + -> a -- ^ Two elements -> Bool antisymmetricOnElemsWithEquality func eq a b = (func a b && func b a) ===> (a `eq` b) antisymmetryOnGensWithEquality :: Show a - => (a -> a -> Bool) - -> Gen (a, a) - -> (a -> a -> Bool) - -> Property + => (a -> a -> Bool) -> Gen (a, a) -> (a -> a -> Bool) -> Property antisymmetryOnGensWithEquality func gen eq = forAll gen $ uncurry $ antisymmetricOnElemsWithEquality func eq -antisymmetryOnGensEq +antisymmetryOnGens :: (Show a, Eq a) - => (a -> a -> Bool) - -> Gen (a, a) - -> Property -antisymmetryOnGensEq func gen - = antisymmetryOnGensWithEquality func gen (==) + => (a -> a -> Bool) -> Gen (a, a) -> Property +antisymmetryOnGens func gen = antisymmetryOnGensWithEquality func gen (==) +-- | +-- +-- prop> antisymmetryOnValid ((>) @Double) +-- prop> antisymmetryOnValid ((>=) @Double) +-- prop> antisymmetryOnValid ((<=) @Double) +-- prop> antisymmetryOnValid ((<) @Double) +-- prop> antisymmetryOnValid (Data.List.isPrefixOf @Double) +-- prop> antisymmetryOnValid (Data.List.isSuffixOf @Double) +-- prop> antisymmetryOnValid (Data.List.isInfixOf @Double) +-- prop> antisymmetryOnValid (Data.List.isSubsequenceOf @Double) antisymmetryOnValid - :: (Show a, Eq a, GenValidity a) - => (a -> a -> Bool) - -> Property -antisymmetryOnValid func = - antisymmetryOnGensEq func genValid + :: (Show a, Eq a, GenValid a) + => (a -> a -> Bool) -> Property +antisymmetryOnValid func = antisymmetryOnGens func genValid +-- | +-- +-- prop> antisymmetry ((>) @Int) +-- prop> antisymmetry ((>=) @Int) +-- prop> antisymmetry ((<=) @Int) +-- prop> antisymmetry ((<) @Int) +-- prop> antisymmetry (Data.List.isPrefixOf @Int) +-- prop> antisymmetry (Data.List.isSuffixOf @Int) +-- prop> antisymmetry (Data.List.isInfixOf @Int) +-- prop> antisymmetry (Data.List.isSubsequenceOf @Int) +-- prop> antisymmetry ((\x y -> even x && odd y) :: Int -> Int -> Bool) antisymmetry - :: (Show a, Eq a, GenValidity a) - => (a -> a -> Bool) - -> Property -antisymmetry func = - antisymmetryOnGensEq func genUnchecked + :: (Show a, Eq a, GenUnchecked a) + => (a -> a -> Bool) -> Property +antisymmetry func = antisymmetryOnGens func genUnchecked -- | -- --- prop> antisymmetryOnArbitrary ((<=) :: Int -> Int -> Bool) +-- prop> antisymmetryOnArbitrary ((>) @Int) +-- prop> antisymmetryOnArbitrary ((>=) @Int) +-- prop> antisymmetryOnArbitrary ((<=) @Int) +-- prop> antisymmetryOnArbitrary ((<) @Int) +-- prop> antisymmetryOnArbitrary (Data.List.isPrefixOf @Int) +-- prop> antisymmetryOnArbitrary (Data.List.isSuffixOf @Int) +-- prop> antisymmetryOnArbitrary (Data.List.isInfixOf @Int) +-- prop> antisymmetryOnArbitrary (Data.List.isSubsequenceOf @Int) +-- prop> antisymmetryOnArbitrary ((\x y -> even x && odd y) :: Int -> Int -> Bool) antisymmetryOnArbitrary :: (Show a, Eq a, Arbitrary a) - => (a -> a -> Bool) - -> Property -antisymmetryOnArbitrary func = - antisymmetryOnGensEq func arbitrary + => (a -> a -> Bool) -> Property +antisymmetryOnArbitrary func = antisymmetryOnGens func arbitrary diff --git a/src/Test/Validity/Relations/Reflexivity.hs b/src/Test/Validity/Relations/Reflexivity.hs --- a/src/Test/Validity/Relations/Reflexivity.hs +++ b/src/Test/Validity/Relations/Reflexivity.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Test.Validity.Relations.Reflexivity ( reflexiveOnElem , reflexivityOnGen @@ -8,51 +9,66 @@ , reflexivityOnArbitrary ) where -import Data.GenValidity +import Data.GenValidity -import Test.QuickCheck +import Test.QuickCheck -- | -- -- \[ --- Reflexive(prec) +-- Reflexive(\prec) -- \quad\equiv\quad -- \forall a: (a \prec a) -- \] reflexiveOnElem :: (a -> a -> Bool) -- ^ A relation - -> a -- ^ An element + -> a -- ^ An element -> Bool reflexiveOnElem func a = func a a reflexivityOnGen :: Show a - => (a -> a -> Bool) - -> Gen a - -> Property -reflexivityOnGen func gen = - forAll gen $ reflexiveOnElem func + => (a -> a -> Bool) -> Gen a -> Property +reflexivityOnGen func gen = forAll gen $ reflexiveOnElem func +-- | +-- +-- prop> reflexivityOnValid ((<=) @Double) +-- prop> reflexivityOnValid ((==) @Double) +-- prop> reflexivityOnValid ((>=) @Double) +-- prop> reflexivityOnValid (Data.List.isPrefixOf @Double) +-- prop> reflexivityOnValid (Data.List.isSuffixOf @Double) +-- prop> reflexivityOnValid (Data.List.isInfixOf @Double) +-- prop> reflexivityOnValid (Data.List.isSubsequenceOf @Double) reflexivityOnValid - :: (Show a, GenValidity a) - => (a -> a -> Bool) - -> Property -reflexivityOnValid func - = reflexivityOnGen func genValid + :: (Show a, GenValid a) + => (a -> a -> Bool) -> Property +reflexivityOnValid func = reflexivityOnGen func genValid +-- | +-- +-- prop> reflexivity ((<=) @Int) +-- prop> reflexivity ((==) @Int) +-- prop> reflexivity ((>=) @Int) +-- prop> reflexivity (Data.List.isPrefixOf @Int) +-- prop> reflexivity (Data.List.isSuffixOf @Int) +-- prop> reflexivity (Data.List.isInfixOf @Int) +-- prop> reflexivity (Data.List.isSubsequenceOf @Int) reflexivity - :: (Show a, GenValidity a) - => (a -> a -> Bool) - -> Property -reflexivity func - = reflexivityOnGen func genUnchecked + :: (Show a, GenUnchecked a) + => (a -> a -> Bool) -> Property +reflexivity func = reflexivityOnGen func genUnchecked -- | -- --- prop> reflexivityOnArbitrary ((==) :: Int -> Int -> Bool) +-- prop> reflexivityOnArbitrary ((<=) @Int) +-- prop> reflexivityOnArbitrary ((==) @Int) +-- prop> reflexivityOnArbitrary ((>=) @Int) +-- prop> reflexivityOnArbitrary (Data.List.isPrefixOf @Int) +-- prop> reflexivityOnArbitrary (Data.List.isSuffixOf @Int) +-- prop> reflexivityOnArbitrary (Data.List.isInfixOf @Int) +-- prop> reflexivityOnArbitrary (Data.List.isSubsequenceOf @Int) reflexivityOnArbitrary :: (Show a, Arbitrary a) - => (a -> a -> Bool) - -> Property -reflexivityOnArbitrary func - = reflexivityOnGen func arbitrary + => (a -> a -> Bool) -> Property +reflexivityOnArbitrary func = reflexivityOnGen func arbitrary diff --git a/src/Test/Validity/Relations/Symmetry.hs b/src/Test/Validity/Relations/Symmetry.hs --- a/src/Test/Validity/Relations/Symmetry.hs +++ b/src/Test/Validity/Relations/Symmetry.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Test.Validity.Relations.Symmetry ( symmetricOnElems , symmetryOnGens @@ -8,11 +9,11 @@ , symmetryOnArbitrary ) where -import Data.GenValidity +import Data.GenValidity -import Test.QuickCheck +import Test.QuickCheck -import Test.Validity.Utils +import Test.Validity.Utils -- | -- @@ -23,39 +24,39 @@ -- \] symmetricOnElems :: (a -> a -> Bool) -- ^ A relation - -> a -> a -- ^ Two elements + -> a + -> a -- ^ Two elements -> Bool symmetricOnElems func a b = func a b <==> func b a symmetryOnGens :: Show a - => (a -> a -> Bool) - -> Gen (a, a) - -> Property -symmetryOnGens func gen = - forAll gen $ uncurry $ symmetricOnElems func + => (a -> a -> Bool) -> Gen (a, a) -> Property +symmetryOnGens func gen = forAll gen $ uncurry $ symmetricOnElems func +-- | +-- +-- prop> symmetryOnValid ((==) @Double) +-- prop> symmetryOnValid ((/=) @Double) symmetryOnValid - :: (Show a, GenValidity a) - => (a -> a -> Bool) - -> Property -symmetryOnValid func = - symmetryOnGens func genValid + :: (Show a, GenValid a) + => (a -> a -> Bool) -> Property +symmetryOnValid func = symmetryOnGens func genValid +-- | +-- +-- prop> symmetry ((==) @Int) +-- prop> symmetry ((/=) @Int) symmetry - :: (Show a, GenValidity a) - => (a -> a -> Bool) - -> Property -symmetry func = - symmetryOnGens func genUnchecked - + :: (Show a, GenUnchecked a) + => (a -> a -> Bool) -> Property +symmetry func = symmetryOnGens func genUnchecked -- | -- --- prop> symmetryOnArbitrary ((==) :: Int -> Int -> Bool) +-- prop> symmetryOnArbitrary ((==) @Int) +-- prop> symmetryOnArbitrary ((/=) @Int) symmetryOnArbitrary :: (Show a, Arbitrary a) - => (a -> a -> Bool) - -> Property -symmetryOnArbitrary func = - symmetryOnGens func arbitrary + => (a -> a -> Bool) -> Property +symmetryOnArbitrary func = symmetryOnGens func arbitrary diff --git a/src/Test/Validity/Relations/Transitivity.hs b/src/Test/Validity/Relations/Transitivity.hs --- a/src/Test/Validity/Relations/Transitivity.hs +++ b/src/Test/Validity/Relations/Transitivity.hs @@ -1,5 +1,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} + module Test.Validity.Relations.Transitivity ( transitiveOnElems , transitivityOnGens @@ -8,11 +9,11 @@ , transitivityOnArbitrary ) where -import Data.GenValidity +import Data.GenValidity -import Test.QuickCheck +import Test.QuickCheck -import Test.Validity.Utils +import Test.Validity.Utils -- | -- @@ -23,40 +24,62 @@ -- \] transitiveOnElems :: (a -> a -> Bool) -- ^ A relation - -> a -> a -> a -- ^ Three elements + -> a + -> a + -> a -- ^ Three elements -> Bool transitiveOnElems func a b c = (func a b && func b c) ===> func a c transitivityOnGens :: Show a - => (a -> a -> Bool) - -> Gen (a, a, a) - -> Property + => (a -> a -> Bool) -> Gen (a, a, a) -> Property transitivityOnGens func gen = forAll gen $ \(a, b, c) -> transitiveOnElems func a b c +-- | +-- +-- prop> transitivityOnValid ((>) @Double) +-- prop> transitivityOnValid ((>=) @Double) +-- prop> transitivityOnValid ((==) @Double) +-- prop> transitivityOnValid ((<=) @Double) +-- prop> transitivityOnValid ((<) @Double) +-- prop> transitivityOnValid (Data.List.isPrefixOf @Double) +-- prop> transitivityOnValid (Data.List.isSuffixOf @Double) +-- prop> transitivityOnValid (Data.List.isInfixOf @Double) +-- prop> transitivityOnValid (Data.List.isSubsequenceOf @Double) transitivityOnValid - :: (Show a, GenValidity a) - => (a -> a -> Bool) - -> Property -transitivityOnValid func - = transitivityOnGens func genValid - + :: (Show a, GenValid a) + => (a -> a -> Bool) -> Property +transitivityOnValid func = transitivityOnGens func genValid +-- | +-- +-- prop> transitivity ((>) @Int) +-- prop> transitivity ((>=) @Int) +-- prop> transitivity ((==) @Int) +-- prop> transitivity ((<=) @Int) +-- prop> transitivity ((<) @Int) +-- prop> transitivity (Data.List.isPrefixOf @Int) +-- prop> transitivity (Data.List.isSuffixOf @Int) +-- prop> transitivity (Data.List.isInfixOf @Int) +-- prop> transitivity (Data.List.isSubsequenceOf @Int) transitivity - :: (Show a, GenValidity a) - => (a -> a -> Bool) - -> Property -transitivity func - = transitivityOnGens func genUnchecked + :: (Show a, GenUnchecked a) + => (a -> a -> Bool) -> Property +transitivity func = transitivityOnGens func genUnchecked -- | -- --- prop> transitivityOnArbitrary ((==) :: Int -> Int -> Bool) +-- prop> transitivityOnArbitrary ((>) @Int) +-- prop> transitivityOnArbitrary ((>=) @Int) +-- prop> transitivityOnArbitrary ((==) @Int) +-- prop> transitivityOnArbitrary ((<=) @Int) +-- prop> transitivityOnArbitrary ((<) @Int) +-- prop> transitivityOnArbitrary (Data.List.isPrefixOf @Int) +-- prop> transitivityOnArbitrary (Data.List.isSuffixOf @Int) +-- prop> transitivityOnArbitrary (Data.List.isInfixOf @Int) +-- prop> transitivityOnArbitrary (Data.List.isSubsequenceOf @Int) transitivityOnArbitrary :: (Show a, Arbitrary a) - => (a -> a -> Bool) - -> Property -transitivityOnArbitrary func - = transitivityOnGens func arbitrary - + => (a -> a -> Bool) -> Property +transitivityOnArbitrary func = transitivityOnGens func arbitrary diff --git a/src/Test/Validity/RelativeValidity.hs b/src/Test/Validity/RelativeValidity.hs --- a/src/Test/Validity/RelativeValidity.hs +++ b/src/Test/Validity/RelativeValidity.hs @@ -1,22 +1,26 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for RelativeValidity instances +-- +-- You will need @TypeApplications@ to use these. module Test.Validity.RelativeValidity - ( -- * Tests for RelativeValidity instances - relativeValiditySpec + ( relativeValiditySpec , relativeValidityImpliesValidA , relativeValidityImpliesValidB ) where -import Data.Data -import Data.Proxy +import Data.Data -import Data.GenRelativeValidity -import Data.GenValidity +import Data.GenRelativeValidity +import Data.GenValidity -import Test.Hspec -import Test.QuickCheck +import Test.Hspec +import Test.QuickCheck -import Test.Validity.Utils +import Test.Validity.Utils -- | A @Spec@ that specifies that @isValidFor@ implies @isValid@ -- @@ -25,53 +29,46 @@ -- -- Example usage: -- --- > relativeValiditySpec --- > (Proxy :: Proxy MyDataFor) --- > (Proxy :: Proxy MyOtherData) +-- > relativeValiditySpec @MyDataFor @MyOtherData relativeValiditySpec - :: (Typeable a, Typeable b, - Show a, Show b, - GenValidity a, GenValidity b, GenRelativeValidity a b) - => Proxy a - -> Proxy b - -> Spec -relativeValiditySpec one two = do - let nameOne = nameOf one - nameTwo = nameOf two - describe ("RelativeValidity " ++ nameOne ++ " " ++ nameTwo) $ - describe ("isValidFor :: " - ++ nameOne - ++ " -> " - ++ nameTwo - ++ " -> Bool") $ do - it ("implies isValid " ++ nameOne ++ " for any " ++ nameTwo) $ - relativeValidityImpliesValidA one two - it ("implies isValid " ++ nameTwo ++ " for any " ++ nameOne) $ - relativeValidityImpliesValidB one two + :: forall a b. + ( Typeable a + , Typeable b + , Show a + , Show b + , Validity a + , Validity b + , GenUnchecked a + , GenUnchecked b + , RelativeValidity a b + ) + => Spec +relativeValiditySpec = + parallel $ do + let nameOne = nameOf @a + nameTwo = nameOf @b + describe ("RelativeValidity " ++ nameOne ++ " " ++ nameTwo) $ + describe + ("isValidFor :: " ++ nameOne ++ " -> " ++ nameTwo ++ " -> Bool") $ do + it ("implies isValid " ++ nameOne ++ " for any " ++ nameTwo) $ + relativeValidityImpliesValidA @a @b + it ("implies isValid " ++ nameTwo ++ " for any " ++ nameOne) $ + relativeValidityImpliesValidB @a @b -- | @isValidFor a b@ implies @isValid a@ for all @b@ relativeValidityImpliesValidA - :: (Show a, Show b, - GenValidity a, GenValidity b, RelativeValidity a b) - => Proxy a - -> Proxy b - -> Property -relativeValidityImpliesValidA one two = - forAll genUnchecked $ \a -> - forAll genUnchecked $ \b -> - not ((a `asProxyTypeOf` one) `isValidFor` (b `asProxyTypeOf` two)) - || isValid a + :: forall a b. + (Show a, Show b, Validity a, GenUnchecked a, GenUnchecked b, RelativeValidity a b) + => Property +relativeValidityImpliesValidA = + forAll genUnchecked $ \(a :: a) -> + forAll genUnchecked $ \(b :: b) -> (a `isValidFor` b) ===> isValid a -- | @isValidFor a b@ implies @isValid b@ for all @a@ relativeValidityImpliesValidB - :: (Show a, Show b, - GenValidity a, GenValidity b, RelativeValidity a b) - => Proxy a - -> Proxy b - -> Property -relativeValidityImpliesValidB one two = - forAll genUnchecked $ \a -> - forAll genUnchecked $ \b -> - not ((a `asProxyTypeOf` one) `isValidFor` (b `asProxyTypeOf` two)) - || isValid b - + :: forall a b. + (Show a, Show b, Validity b, GenUnchecked a, GenUnchecked b, RelativeValidity a b) + => Property +relativeValidityImpliesValidB = + forAll genUnchecked $ \(a :: a) -> + forAll genUnchecked $ \(b :: b) -> (a `isValidFor` b) ===> isValid b diff --git a/src/Test/Validity/Utils.hs b/src/Test/Validity/Utils.hs --- a/src/Test/Validity/Utils.hs +++ b/src/Test/Validity/Utils.hs @@ -1,12 +1,19 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + module Test.Validity.Utils ( (<==>) , (===>) , nameOf + , genDescr + , binRelStr + , Anon(..) ) where -import Data.Data +import Data.Data (===>) :: Bool -> Bool -> Bool (===>) a b = not a || b @@ -14,7 +21,31 @@ (<==>) :: Bool -> Bool -> Bool (<==>) a b = a ===> b && b ===> a -nameOf :: Typeable a => Proxy a -> String -nameOf proxy = - let (_, [ty]) = splitTyConApp $ typeOf proxy - in show ty +nameOf + :: forall a. + Typeable a + => String +nameOf = show $ typeRep (Proxy @a) + +genDescr + :: forall a. + Typeable a + => String -> String +genDescr genname = unwords ["\"" ++ genname, "::", nameOf @a ++ "\""] + +binRelStr + :: forall a. + Typeable a + => String -> String +binRelStr op = unwords ["(" ++ op ++ ")", "::", name, "->", name, "->", "Bool"] + where + name = nameOf @a + +data Anon a = + Anon a + +instance Show (Anon a) where + show _ = "Anonymous" + +instance Functor Anon where + fmap f (Anon a) = Anon (f a) diff --git a/test/DocTest.hs b/test/DocTest.hs --- a/test/DocTest.hs +++ b/test/DocTest.hs @@ -1,4 +1,4 @@ import Test.DocTest main :: IO () -main = doctest ["-isrc", "src"] +main = doctest ["-isrc", "src", "-XTypeApplications"] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Test/Validity/ApplicativeSpec.hs b/test/Test/Validity/ApplicativeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/ApplicativeSpec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.ApplicativeSpec where + +import Test.Hspec + +import Data.GenValidity +import Test.Validity.Applicative + +spec :: Spec +spec = do + applicativeSpecOnValid @[] + applicativeSpecOnValid @Maybe + applicativeSpec @(Either Int) + applicativeSpec @[] + applicativeSpec @Maybe + applicativeSpecOnArbitrary @[] + applicativeSpecOnArbitrary @Maybe + applicativeSpecOnGens + @[] + @Int + (pure 4) + "four" + (genListOf $ pure 5) + "list of fives" + (pure []) + "purely empty list" + ((+) <$> genValid) + "increments" + (pure <$> ((+) <$> genValid)) + "increments in a list" + (pure <$> ((*) <$> genValid)) + "scalings in a list" + applicativeSpecOnGens + @Maybe + @String + (pure "ABC") + "ABC" + (Just <$> pure "ABC") + "Just an ABC" + (pure Nothing) + "purely Nothing" + ((++) <$> genValid) + "prepends" + (pure <$> ((++) <$> genValid)) + "prepends in a Just" + (pure <$> (flip (++) <$> genValid)) + "appends in a Just" diff --git a/test/Test/Validity/ArbitrarySpec.hs b/test/Test/Validity/ArbitrarySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/ArbitrarySpec.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.ArbitrarySpec where + +import Test.Hspec + +import Test.Validity.Arbitrary + +spec :: Spec +spec = arbitrarySpec @Int diff --git a/test/Test/Validity/EqSpec.hs b/test/Test/Validity/EqSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/EqSpec.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.EqSpec where + +import Test.Hspec + +import Data.GenValidity +import Test.Validity.Eq + +spec :: Spec +spec = do + eqSpecOnValid @Double + eqSpec @Int + eqSpecOnArbitrary @Int + eqSpecOnGen ((* 2) <$> genValid @Int) "even" diff --git a/test/Test/Validity/FunctorSpec.hs b/test/Test/Validity/FunctorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/FunctorSpec.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.FunctorSpec where + +import Test.Hspec + +import Data.GenValidity +import Test.Validity.Functor + +spec :: Spec +spec = do + functorSpec @[] + functorSpec @Maybe + functorSpec @(Either Int) + functorSpec @((,) Int) + functorSpecOnValid @[] + functorSpecOnValid @Maybe + functorSpecOnArbitrary @[] + functorSpecOnArbitrary @Maybe + functorSpecOnGens + @[] + @Int + (pure 4) + "four" + (genListOf $ pure 5) + "list of fives" + ((+) <$> genValid) + "increments" + ((*) <$> genValid) + "scalings" + functorSpecOnGens + @Maybe + @String + (pure "ABC") + "ABC" + (Just <$> pure "ABC") + "Just an ABC" + ((++) <$> genValid) + "prepends" + ((flip (++)) <$> genValid) + "appends" diff --git a/test/Test/Validity/GenRelativeValiditySpec.hs b/test/Test/Validity/GenRelativeValiditySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/GenRelativeValiditySpec.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.GenRelativeValiditySpec where + +import Test.Hspec + +-- import Test.Validity.GenRelativeValidity + +spec :: Spec +spec = pure () -- TODO add examples once we have some instances diff --git a/test/Test/Validity/GenValiditySpec.hs b/test/Test/Validity/GenValiditySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/GenValiditySpec.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.GenValiditySpec where + +import Test.Hspec + +import Test.Validity.GenValidity + +spec :: Spec +spec = do + genValiditySpec @Double + genValidSpec @Double + genInvalidSpec @Double diff --git a/test/Test/Validity/MonadSpec.hs b/test/Test/Validity/MonadSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/MonadSpec.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.MonadSpec where + +import Test.Hspec + +import Data.GenValidity +import Test.Validity.Monad + +spec :: Spec +spec + = do + monadSpec @[] + monadSpec @Maybe + monadSpec @(Either Int) + monadSpecOnValid @[] + monadSpecOnValid @Maybe + monadSpecOnArbitrary @[] + monadSpecOnArbitrary @Maybe + monadSpecOnGens + @[] + @Int + (pure 4) + "four" + (genListOf $ pure 5) + "list of fives" + (genListOf $ pure 6) + "list of sixes" + ((*) <$> genValid) + "factorisations" + (pure $ \a -> [a]) + "singletonisation" + (pure $ \a -> [a]) + "singletonisation" + (pure $ pure (+ 1)) + "increment in list" + monadSpecOnGens + @Maybe + @String + (pure "ABC") + "ABC" + (Just <$> pure "ABC") + "Just an ABC" + (Just <$> pure "CDE") + "Just an ABC" + ((flip (++)) <$> genValid) + "appends" + (pure $ \a -> Just a) + "justisation" + (pure $ \a -> Just a) + "justisation" + (pure $ pure (++ "a")) + "append 'a' in Just" diff --git a/test/Test/Validity/MonoidSpec.hs b/test/Test/Validity/MonoidSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/MonoidSpec.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.MonoidSpec where + +import Test.Hspec + +import Test.Validity.Monoid + +spec :: Spec +spec = do + monoidSpecOnValid @[Double] + monoidSpec @[Int] + monoidSpecOnArbitrary @[Int] + monoidSpecOnGen (pure "a") "singleton list of 'a'" diff --git a/test/Test/Validity/OrdSpec.hs b/test/Test/Validity/OrdSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/OrdSpec.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.OrdSpec where + +import Test.Hspec + +import Data.GenValidity +import Test.Validity.Ord + +spec :: Spec +spec = do + ordSpecOnValid @Double + ordSpec @Int + ordSpecOnArbitrary @Int + ordSpecOnGen ((* 2) <$> genValid @Int) "even" diff --git a/test/Test/Validity/RelativeValiditySpec.hs b/test/Test/Validity/RelativeValiditySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/RelativeValiditySpec.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.RelativeValiditySpec where + +import Test.Hspec + +-- import Test.Validity.RelativeValidity +spec :: Spec +spec = pure ()