diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2016-2020 Tom Sydney Kerckhove + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/genvalidity-sydtest.cabal b/genvalidity-sydtest.cabal new file mode 100644 --- /dev/null +++ b/genvalidity-sydtest.cabal @@ -0,0 +1,104 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: genvalidity-sydtest +version: 0.0.0.0 +synopsis: Standard properties for functions on `Validity` types for the sydtest framework +category: Testing +homepage: https://github.com/NorfairKing/validity#readme +bug-reports: https://github.com/NorfairKing/validity/issues +author: Tom Sydney Kerckhove +maintainer: syd@cs-syd.eu +copyright: Copyright: (c) 2020 Tom Sydney Kerckhove +license: MIT +license-file: LICENSE +build-type: Simple + +source-repository head + type: git + location: https://github.com/NorfairKing/validity + +library + exposed-modules: + Test.Syd.Validity + Test.Syd.Validity.Applicative + Test.Syd.Validity.Arbitrary + Test.Syd.Validity.Eq + Test.Syd.Validity.Functions + Test.Syd.Validity.Functions.CanFail + Test.Syd.Validity.Functions.Equivalence + Test.Syd.Validity.Functions.Idempotence + Test.Syd.Validity.Functions.Inverse + Test.Syd.Validity.Functions.Validity + Test.Syd.Validity.Functor + Test.Syd.Validity.GenRelativeValidity + Test.Syd.Validity.GenValidity + Test.Syd.Validity.GenValidity.Property + Test.Syd.Validity.Monad + Test.Syd.Validity.Monoid + Test.Syd.Validity.Operations + Test.Syd.Validity.Operations.Associativity + Test.Syd.Validity.Operations.Commutativity + Test.Syd.Validity.Operations.Identity + Test.Syd.Validity.Ord + Test.Syd.Validity.Property + Test.Syd.Validity.Property.Utils + Test.Syd.Validity.Relations + Test.Syd.Validity.Relations.Antireflexivity + Test.Syd.Validity.Relations.Antisymmetry + Test.Syd.Validity.Relations.Reflexivity + Test.Syd.Validity.Relations.Symmetry + Test.Syd.Validity.Relations.Transitivity + Test.Syd.Validity.RelativeValidity + Test.Syd.Validity.Show + Test.Syd.Validity.Shrinking + Test.Syd.Validity.Shrinking.Property + Test.Syd.Validity.Types + Test.Syd.Validity.Utils + other-modules: + Paths_genvalidity_sydtest + hs-source-dirs: + src + ghc-options: -Wall -fwarn-redundant-constraints + build-depends: + QuickCheck + , base >=4.7 && <5 + , genvalidity >=0.7 + , pretty-show + , sydtest + , validity >=0.9 + default-language: Haskell2010 + +test-suite genvalidity-sydtest-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Syd.Validity.ApplicativeSpec + Test.Syd.Validity.ArbitrarySpec + Test.Syd.Validity.EqSpec + Test.Syd.Validity.FunctorSpec + Test.Syd.Validity.GenRelativeValiditySpec + Test.Syd.Validity.GenValiditySpec + Test.Syd.Validity.MonadSpec + Test.Syd.Validity.MonoidSpec + Test.Syd.Validity.Operations.CommutativitySpec + Test.Syd.Validity.OrdSpec + Test.Syd.Validity.RelativeValiditySpec + Test.Syd.Validity.ShowSpec + Test.Syd.Validity.ShrinkingSpec + Paths_genvalidity_sydtest + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-tool-depends: + sydtest-discover:sydtest-discover + build-depends: + QuickCheck + , base >=4.7 && <5 + , genvalidity + , genvalidity-sydtest + , sydtest + default-language: Haskell2010 diff --git a/src/Test/Syd/Validity.hs b/src/Test/Syd/Validity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | To use the 'Spec' functions in this module, you will need @TypeApplications@. +-- +-- +-- The most interesting functions in this module for most uses are: +-- +-- * 'genValidSpec' +-- * 'eqSpecOnValid' +-- * 'ordSpecOnValid' +-- * 'producesValidsOnValids' +-- * 'forAllValid' +-- * 'shouldBeValid' +module Test.Syd.Validity + ( -- * Writing properties + -- ** Cheap generation with shrinking + forAllUnchecked + , forAllValid + , forAllInvalid + -- ** Cheap assertions + , shouldBeValid + , shouldBeInvalid + -- * Tests for GenValidity instances + , genValiditySpec + , genValidSpec + , genInvalidSpec + , genValidGeneratesValid + , genGeneratesValid + , genInvalidGeneratesInvalid + , genGeneratesInvalid + , shrinkValiditySpec + , shrinkValidSpec + , shrinkValidSpecWithLimit + , shrinkInvalidSpec + , shrinkValidPreservesValidOnGenValid + , shrinkInvalidPreservesInvalidOnGenInvalid + , shrinkPreservesValidOnGenValid + , shrinkPreservesInvalidOnGenInvalid + , shrinkValidPreservesValid + , shrinkInvalidPreservesInvalid + , shrinkingStaysValid + , shrinkingStaysInvalid + , shrinkingPreserves + -- * Tests for Arbitrary instances involving Validity + , arbitrarySpec + , arbitraryGeneratesOnlyValid + -- * Tests for RelativeValidity instances + , relativeValiditySpec + , relativeValidityImpliesValidA + , relativeValidityImpliesValidB + -- * Tests for GenRelativeValidity instances + , genRelativeValiditySpec + , genRelativeValidGeneratesValid + , genRelativeInvalidGeneratesInvalid + -- * Standard tests involving functions + -- ** Standard tests involving validity + , producesValidsOnGen + , producesValidsOnValids + , producesValid + , producesValidsOnArbitrary + , producesValidsOnGens2 + , producesValidsOnValids2 + , producesValid2 + , producesValidsOnArbitrary2 + , producesValidsOnGens3 + , 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 + , validIfSucceedsOnGens3 + , validIfSucceedsOnValids3 + , validIfSucceeds3 + , validIfSucceedsOnArbitrary3 + -- ** 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 + , inverseFunctions + , inverseFunctionsOnArbitrary + , inverseFunctionsIfFirstSucceedsOnGen + , inverseFunctionsIfFirstSucceedsOnValid + , inverseFunctionsIfFirstSucceeds + , inverseFunctionsIfFirstSucceedsOnArbitrary + , inverseFunctionsIfSecondSucceedsOnGen + , inverseFunctionsIfSecondSucceedsOnValid + , inverseFunctionsIfSecondSucceeds + , inverseFunctionsIfSecondSucceedsOnArbitrary + , inverseFunctionsIfSucceedOnGen + , 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 + , 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 + -- * Show and Read properties + , showReadSpecOnValid + , showReadSpec + , showReadSpecOnArbitrary + , showReadSpecOnGen + -- * Eq properties + , eqSpecOnValid + , eqSpecOnInvalid + , eqSpec + , eqSpecOnArbitrary + , eqSpecOnGen + -- * Ord properties + , ordSpecOnGen + , ordSpecOnValid + , ordSpecOnInvalid + , 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 + -- * Re-exports + , module Data.GenValidity + ) where + +import Data.GenValidity + +import Test.Syd.Validity.Applicative +import Test.Syd.Validity.Arbitrary +import Test.Syd.Validity.Eq +import Test.Syd.Validity.Functions +import Test.Syd.Validity.Functor +import Test.Syd.Validity.GenRelativeValidity +import Test.Syd.Validity.GenValidity +import Test.Syd.Validity.Monad +import Test.Syd.Validity.Monoid +import Test.Syd.Validity.Operations +import Test.Syd.Validity.Ord +import Test.Syd.Validity.Property +import Test.Syd.Validity.RelativeValidity +import Test.Syd.Validity.Show +import Test.Syd.Validity.Shrinking +import Test.Syd.Validity.Utils diff --git a/src/Test/Syd/Validity/Applicative.hs b/src/Test/Syd/Validity/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Applicative.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Applicative properties +-- +-- You will need @TypeApplications@ to use these. +module Test.Syd.Validity.Applicative + ( applicativeSpecOnValid + , applicativeSpec + , applicativeSpecOnArbitrary + , applicativeSpecOnGens + ) where + +import Data.Data + +import Data.GenValidity +import Data.Kind + +import Test.Syd +import Test.QuickCheck + +import Test.Syd.Validity.Functions +import Test.Syd.Validity.Utils + +{-# ANN module "HLint: ignore Avoid lambda" #-} + +pureTypeStr :: + forall (f :: Type -> Type). (Typeable f) + => String +pureTypeStr = unwords ["pure", "::", "a", "->", nameOf @f, "a"] + +seqTypeStr :: + forall (f :: Type -> Type). (Typeable f) + => String +seqTypeStr = + unwords + [ "(<*>)" + , "::" + , nameOf @f + , "(a" + , "->" + , "b)" + , "->" + , nameOf @f + , "a" + , "->" + , nameOf @f + , "b" + ] + +seqrTypeStr :: + forall (f :: Type -> Type). (Typeable f) + => String +seqrTypeStr = + unwords + [ "(*>)" + , "::" + , nameOf @f + , "a" + , "->" + , nameOf @f + , "b" + , "->" + , nameOf @f + , "b" + ] + +seqlTypeStr :: + forall (f :: Type -> Type). (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 :: Type -> Type). + (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 :: Type -> Type). + ( 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 :: Type -> Type). + (Eq (f Int), Show (f Int), Applicative f, Typeable f, Arbitrary (f Int)) + => Spec +applicativeSpecOnArbitrary = applicativeSpecWithInts @f arbitrary + +applicativeSpecWithInts :: + forall (f :: Type -> Type). + (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 :: Type -> Type) (a :: Type) (b :: Type) (c :: Type). + ( Show 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 shrinkNothing + 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) + shrinkNothing + 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) + shrinkNothing + 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) + shrinkNothing + 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) + shrinkNothing + describe (seqrTypeStr @f) $ + it + (unwords + [ "is equivalent to its default implementation 'u Type> 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) + shrinkNothing + describe (seqlTypeStr @f) $ + 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) + shrinkNothing diff --git a/src/Test/Syd/Validity/Arbitrary.hs b/src/Test/Syd/Validity/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Arbitrary.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} + +-- | Tests for Arbitrary instances involving Validity +-- +-- You will need @TypeApplications@ to use these. +module Test.Syd.Validity.Arbitrary + ( arbitrarySpec + , arbitraryGeneratesOnlyValid + ) where + +import Data.Data + +import Data.GenValidity + +import Test.Syd +import Test.QuickCheck + +import Test.Syd.Validity.GenValidity +import Test.Syd.Validity.Utils + +-- | A @Spec@ that specifies that @arbitrary@ only generates data that +-- satisfy @isValid@ +-- +-- Example usage: +-- +-- > arbitrarySpec @Int +arbitrarySpec :: + 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) + => Property +arbitraryGeneratesOnlyValid = genGeneratesValid @a arbitrary diff --git a/src/Test/Syd/Validity/Eq.hs b/src/Test/Syd/Validity/Eq.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Eq.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Eq properties +-- +-- You will need @TypeApplications@ to use these. +module Test.Syd.Validity.Eq + ( eqSpecOnValid + , eqSpecOnInvalid + , eqSpec + , eqSpecOnArbitrary + , eqSpecOnGen + ) where + +import Data.Data + +import Data.GenValidity + +import Test.Syd +import Test.QuickCheck + +import Test.Syd.Validity.Functions +import Test.Syd.Validity.Relations +import Test.Syd.Validity.Utils + +eqTypeStr :: + forall a. Typeable a + => String +eqTypeStr = binRelStr @a "==" + +neqTypeStr :: + forall a. Typeable a + => String +neqTypeStr = binRelStr @a "/=" + +-- | 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" shrinkValid + +-- | Standard test spec for properties of Eq instances for invalid values +-- +-- Example usage: +-- +-- > eqSpecOnInvalid @Double +eqSpecOnInvalid :: + forall a. (Show a, Eq a, Typeable a, GenInvalid a) + => Spec +eqSpecOnInvalid = eqSpecOnGen @a genInvalid "invalid" shrinkInvalid + +-- | 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" shrinkUnchecked + +-- | 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" shrink + +-- | 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 + -> (a -> [a]) + -> Spec +eqSpecOnGen gen genname s = + parallel $ do + let name = nameOf @a + funeqstr = eqTypeStr @a + funneqstr = neqTypeStr @a + gen2 = (,) <$> gen <*> gen + gen3 = (,,) <$> gen <*> gen <*> gen + s2 = shrinkT2 s + describe ("Eq " ++ name) $ do + let eq = (==) @a + neq = (/=) @a + describe funeqstr $ do + it + (unwords + [ "is reflexive for" + , "\"" ++ genname + , name ++ "\"" ++ "s" + ]) $ + reflexivityOnGen eq gen s + it + (unwords + [ "is symmetric for" + , "\"" ++ genname + , name ++ "\"" ++ "s" + ]) $ + symmetryOnGens eq gen2 s + it + (unwords + [ "is transitive for" + , "\"" ++ genname + , name ++ "\"" ++ "s" + ]) $ + transitivityOnGens eq gen3 s + it + (unwords + [ "is equivalent to (\\a b -> not $ a /= b) for" + , "\"" ++ genname + , name ++ "\"" ++ "s" + ]) $ + equivalentOnGens2 eq (\a b -> not $ a `neq` b) gen2 s2 + describe funneqstr $ do + it + (unwords + [ "is antireflexive for" + , "\"" ++ genname + , name ++ "\"" ++ "s" + ]) $ + antireflexivityOnGen neq gen s + it + (unwords + [ "is equivalent to (\\a b -> not $ a == b) for" + , "\"" ++ genname + , name ++ "\"" ++ "s" + ]) $ + equivalentOnGens2 neq (\a b -> not $ a `eq` b) gen2 s2 diff --git a/src/Test/Syd/Validity/Functions.hs b/src/Test/Syd/Validity/Functions.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Functions.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Validity tests involving functions +module Test.Syd.Validity.Functions + ( producesValidsOnGen + , producesValidsOnValids + , producesValid + , producesValidsOnArbitrary + , producesValidsOnGens2 + , producesValidsOnValids2 + , producesValid2 + , producesValidsOnArbitrary2 + , producesValidsOnGens3 + , producesValidsOnValids3 + , producesValid3 + , producesValidsOnArbitrary3 + , succeedsOnGen + , succeedsOnValid + , succeeds + , succeedsOnArbitrary + , succeedsOnGens2 + , succeedsOnValids2 + , succeeds2 + , succeedsOnArbitrary2 + , failsOnGen + , failsOnInvalid + , failsOnGens2 + , failsOnInvalid2 + , validIfSucceedsOnGen + , validIfSucceedsOnValid + , validIfSucceedsOnArbitrary + , validIfSucceeds + , validIfSucceedsOnGens2 + , validIfSucceedsOnValids2 + , validIfSucceeds2 + , validIfSucceedsOnArbitrary2 + , validIfSucceedsOnGens3 + , validIfSucceedsOnValids3 + , validIfSucceeds3 + , validIfSucceedsOnArbitrary3 + , 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 + , inverseFunctionsOnGen + , inverseFunctionsOnValid + , inverseFunctions + , inverseFunctionsOnArbitrary + , inverseFunctionsIfFirstSucceedsOnGen + , inverseFunctionsIfFirstSucceedsOnValid + , inverseFunctionsIfFirstSucceeds + , inverseFunctionsIfFirstSucceedsOnArbitrary + , inverseFunctionsIfSecondSucceedsOnGen + , inverseFunctionsIfSecondSucceedsOnValid + , inverseFunctionsIfSecondSucceeds + , inverseFunctionsIfSecondSucceedsOnArbitrary + , inverseFunctionsIfSucceedOnGen + , inverseFunctionsIfSucceedOnValid + , inverseFunctionsIfSucceed + , inverseFunctionsIfSucceedOnArbitrary + , idempotentOnGen + , idempotentOnValid + , idempotent + , idempotentOnArbitrary + ) where + +import Test.Syd.Validity.Functions.CanFail +import Test.Syd.Validity.Functions.Equivalence +import Test.Syd.Validity.Functions.Idempotence +import Test.Syd.Validity.Functions.Inverse +import Test.Syd.Validity.Functions.Validity diff --git a/src/Test/Syd/Validity/Functions/CanFail.hs b/src/Test/Syd/Validity/Functions/CanFail.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Functions/CanFail.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Syd.Validity.Functions.CanFail + ( succeedsOnGen, + succeedsOnValid, + succeeds, + succeedsOnArbitrary, + succeedsOnGens2, + succeedsOnValids2, + succeeds2, + succeedsOnArbitrary2, + failsOnGen, + failsOnInvalid, + failsOnGens2, + failsOnInvalid2, + validIfSucceedsOnGen, + validIfSucceedsOnValid, + validIfSucceedsOnArbitrary, + validIfSucceeds, + validIfSucceedsOnGens2, + validIfSucceedsOnValids2, + validIfSucceeds2, + validIfSucceedsOnArbitrary2, + validIfSucceedsOnGens3, + validIfSucceedsOnValids3, + validIfSucceeds3, + validIfSucceedsOnArbitrary3, + ) +where + +import Data.GenValidity +import Test.Syd +import Test.QuickCheck +import Test.Syd.Validity.Property.Utils +import Test.Syd.Validity.Types + +-- | The function succeeds if the input is generated by the given generator +succeedsOnGen :: + (Show a, Show (f b), CanFail f) => (a -> f b) -> Gen a -> (a -> [a]) -> Property +succeedsOnGen func gen s = forAllShrink gen s $ \a -> func a `shouldSatisfy` (not . hasFailed) + +-- | The function succeeds if the input is generated by @genValid@ +succeedsOnValid :: (Show a, Show (f b), GenValid a, CanFail f) => (a -> f b) -> Property +succeedsOnValid f = succeedsOnGen f genValid shrinkValid + +-- | The function succeeds if the input is generated by @genUnchecked@ +succeeds :: (Show a, Show (f b), GenUnchecked a, CanFail f) => (a -> f b) -> Property +succeeds f = succeedsOnGen f genUnchecked shrinkUnchecked + +-- | The function succeeds if the input is generated by @arbitrary@ +succeedsOnArbitrary :: + (Show a, Show (f b), Arbitrary a, CanFail f) => (a -> f b) -> Property +succeedsOnArbitrary f = succeedsOnGen f arbitrary shrink + +-- | The function fails if the input is generated by the given generator +failsOnGen :: + (Show a, Show (f b), CanFail f) => (a -> f b) -> Gen a -> (a -> [a]) -> Property +failsOnGen func gen s = forAllShrink gen s $ \a -> func a `shouldSatisfy` hasFailed + +-- | The function fails if the input is generated by @genInvalid@ +failsOnInvalid :: (Show a, Show (f b), GenInvalid a, CanFail f) => (a -> f b) -> Property +failsOnInvalid f = failsOnGen f genInvalid shrinkInvalid + +-- | The function produces output that satisfies @isValid@ if it is given input +-- that is generated by the given generator. +validIfSucceedsOnGen :: + (Show a, Show b, Validity b, CanFail f) => (a -> f b) -> Gen a -> (a -> [a]) -> Property +validIfSucceedsOnGen func gen s = + forAllShrink gen s $ \a -> + case resultIfSucceeded (func a) of + Nothing -> return () -- Can happen + Just res -> shouldBeValid res + +-- | The function produces output that satisfies @isValid@ if it is given input +-- that is generated by @arbitrary@. +validIfSucceedsOnValid :: + (Show a, Show b, GenValid a, Validity b, CanFail f) => (a -> f b) -> Property +validIfSucceedsOnValid f = validIfSucceedsOnGen f genValid shrinkValid + +-- | The function produces output that satisfies @isValid@ if it is given input +-- that is generated by @arbitrary@. +validIfSucceedsOnArbitrary :: + (Show a, Show b, Arbitrary a, Validity b, CanFail f) => (a -> f b) -> Property +validIfSucceedsOnArbitrary f = validIfSucceedsOnGen f arbitrary shrink + +-- | The function produces output that satisfies @isValid@ if it is given input +-- that is generated by @genUnchecked@. +validIfSucceeds :: (Show a, Show b, GenUnchecked a, Validity b, CanFail f) => (a -> f b) -> Property +validIfSucceeds f = validIfSucceedsOnGen f genUnchecked shrinkUnchecked + +succeedsOnGens2 :: + (Show a, Show b, Show (f c), CanFail f) => + (a -> b -> f c) -> + Gen (a, b) -> + ((a, b) -> [(a, b)]) -> + Property +succeedsOnGens2 func gen s = + forAllShrink gen s $ \(a, b) -> func a b `shouldSatisfy` (not . hasFailed) + +succeedsOnValids2 :: + (Show a, Show b, Show (f c), GenValid a, GenValid b, CanFail f) => + (a -> b -> f c) -> + Property +succeedsOnValids2 func = succeedsOnGens2 func genValid shrinkValid + +succeeds2 :: + (Show a, Show b, Show (f c), GenUnchecked a, GenUnchecked b, CanFail f) => + (a -> b -> f c) -> + Property +succeeds2 func = succeedsOnGens2 func genUnchecked shrinkUnchecked + +succeedsOnArbitrary2 :: + (Show a, Show b, Show (f c), Arbitrary a, Arbitrary b, CanFail f) => + (a -> b -> f c) -> + Property +succeedsOnArbitrary2 func = succeedsOnGens2 func arbitrary shrink + +failsOnGens2 :: + (Show a, Show b, Show (f c), CanFail f) => + (a -> b -> f c) -> + Gen a -> + (a -> [a]) -> + Gen b -> + (b -> [b]) -> + Property +failsOnGens2 func genA sA genB sB = + forAllShrink genA sA $ \a -> forAllShrink genB sB $ \b -> func a b `shouldSatisfy` hasFailed + +failsOnInvalid2 :: + ( Show a, + Show b, + Show (f c), + GenUnchecked a, + GenUnchecked b, + GenInvalid a, + GenInvalid b, + CanFail f + ) => + (a -> b -> f c) -> + Property +failsOnInvalid2 func = + failsOnGens2 func genInvalid shrinkInvalid genUnchecked shrinkUnchecked + .&&. failsOnGens2 func genUnchecked shrinkUnchecked genInvalid shrinkInvalid + +validIfSucceedsOnGens2 :: + (Show a, Show b, Show c, Validity c, CanFail f) => + (a -> b -> f c) -> + Gen (a, b) -> + ((a, b) -> [(a, b)]) -> + Property +validIfSucceedsOnGens2 func gen s = + forAllShrink gen s $ \(a, b) -> + case resultIfSucceeded (func a b) of + Nothing -> return () -- Can happen + Just res -> shouldBeValid res + +validIfSucceedsOnValids2 :: + (Show a, Show b, Show c, GenValid a, GenValid b, Validity c, CanFail f) => + (a -> b -> f c) -> + Property +validIfSucceedsOnValids2 func = validIfSucceedsOnGens2 func genValid shrinkValid + +validIfSucceeds2 :: + (Show a, Show b, Show c, GenUnchecked a, GenUnchecked b, Validity c, CanFail f) => + (a -> b -> f c) -> + Property +validIfSucceeds2 func = validIfSucceedsOnGens2 func genUnchecked shrinkUnchecked + +validIfSucceedsOnArbitrary2 :: + (Show a, Show b, Show c, Arbitrary a, Arbitrary b, Validity c, CanFail f) => + (a -> b -> f c) -> + Property +validIfSucceedsOnArbitrary2 func = validIfSucceedsOnGens2 func arbitrary shrink + +validIfSucceedsOnGens3 :: + (Show a, Show b, Show c, Show d, Validity d, CanFail f) => + (a -> b -> c -> f d) -> + Gen (a, b, c) -> + ((a, b, c) -> [(a, b, c)]) -> + Property +validIfSucceedsOnGens3 func gen s = + forAllShrink gen s $ \(a, b, c) -> + case resultIfSucceeded (func a b c) of + Nothing -> return () -- Can happen + Just res -> shouldBeValid res + +validIfSucceedsOnValids3 :: + (Show a, Show b, Show c, Show d, GenValid a, GenValid b, GenValid c, Validity d, CanFail f) => + (a -> b -> c -> f d) -> + Property +validIfSucceedsOnValids3 func = validIfSucceedsOnGens3 func genValid shrinkValid + +validIfSucceeds3 :: + ( Show a, + Show b, + Show c, + Show d, + GenUnchecked a, + GenUnchecked b, + GenUnchecked c, + Validity d, + CanFail f + ) => + (a -> b -> c -> f d) -> + Property +validIfSucceeds3 func = validIfSucceedsOnGens3 func genUnchecked shrinkUnchecked + +validIfSucceedsOnArbitrary3 :: + (Show a, Show b, Show c, Show d, Arbitrary a, Arbitrary b, Arbitrary c, Validity d, CanFail f) => + (a -> b -> c -> f d) -> + Property +validIfSucceedsOnArbitrary3 func = validIfSucceedsOnGens3 func arbitrary shrink diff --git a/src/Test/Syd/Validity/Functions/Equivalence.hs b/src/Test/Syd/Validity/Functions/Equivalence.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Functions/Equivalence.hs @@ -0,0 +1,459 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Syd.Validity.Functions.Equivalence + ( 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 Test.Syd +import Test.QuickCheck + +import Test.Syd.Validity.Types + +equivalentOnGen :: + (Show a, Show b, Eq b) + => (a -> b) + -> (a -> b) + -> Gen a + -> (a -> [a]) + -> Property +equivalentOnGen f g gen s = forAllShrink gen s $ \a -> f a `shouldBe` g a + +equivalentOnValid :: + (Show a, GenValid a, Show b, Eq b) + => (a -> b) + -> (a -> b) + -> Property +equivalentOnValid f g = equivalentOnGen f g genValid shrinkValid + +equivalent :: + (Show a, GenUnchecked a, Show b, Eq b) + => (a -> b) + -> (a -> b) + -> Property +equivalent f g = equivalentOnGen f g genUnchecked shrinkUnchecked + +-- | +-- +-- prop> equivalentOnArbitrary ((* 2) . (+ 1)) ((+ 2) . (* 2) :: Int -> Int) +equivalentOnArbitrary :: + (Show a, Arbitrary a, Show b, Eq b) + => (a -> b) + -> (a -> b) + -> Property +equivalentOnArbitrary f g = equivalentOnGen f g arbitrary shrink + +equivalentOnGens2 :: + (Show a, Show b, Show c, Eq c) + => (a -> b -> c) + -> (a -> b -> c) + -> Gen (a, b) + -> ((a, b) -> [(a, b)]) + -> Property +equivalentOnGens2 f g gen s = + forAllShrink gen s $ \(a, b) -> f a b `shouldBe` g a b + +equivalentOnValids2 :: + (Show a, GenValid a, Show b, GenValid b, Show c, Eq c) + => (a -> b -> c) + -> (a -> b -> c) + -> Property +equivalentOnValids2 f g = equivalentOnGens2 f g genValid shrinkValid + +equivalent2 :: + (Show a, GenUnchecked a, Show b, GenUnchecked b, Show c, Eq c) + => (a -> b -> c) + -> (a -> b -> c) + -> Property +equivalent2 f g = equivalentOnGens2 f g genUnchecked shrinkUnchecked + +-- | +-- +-- prop> equivalentOnArbitrary2 (+) ((+) :: Int -> Int -> Int) +equivalentOnArbitrary2 :: + (Show a, Arbitrary a, Show b, Arbitrary b, Show c, Eq c) + => (a -> b -> c) + -> (a -> b -> c) + -> Property +equivalentOnArbitrary2 f g = equivalentOnGens2 f g arbitrary shrink + +equivalentWhenFirstSucceedsOnGen :: + (Show a, Show b, Eq b, CanFail f) + => (a -> f b) + -> (a -> b) + -> Gen a + -> (a -> [a]) + -> Property +equivalentWhenFirstSucceedsOnGen f g gen s = + forAllShrink gen s $ \a -> + case resultIfSucceeded (f a) of + Nothing -> return () -- fine + Just r -> r `shouldBe` g a + +equivalentWhenFirstSucceedsOnValid :: + (Show a, GenValid a, Show b, Eq b, CanFail f) + => (a -> f b) + -> (a -> b) + -> Property +equivalentWhenFirstSucceedsOnValid f g = + equivalentWhenFirstSucceedsOnGen f g genValid shrinkValid + +equivalentWhenFirstSucceedsOnArbitrary :: + (Show a, Arbitrary a, Show b, Eq b, CanFail f) + => (a -> f b) + -> (a -> b) + -> Property +equivalentWhenFirstSucceedsOnArbitrary f g = + equivalentWhenFirstSucceedsOnGen f g arbitrary shrink + +equivalentWhenFirstSucceeds :: + (Show a, GenUnchecked a, Show b, Eq b, CanFail f) + => (a -> f b) + -> (a -> b) + -> Property +equivalentWhenFirstSucceeds f g = + equivalentWhenFirstSucceedsOnGen f g genUnchecked shrinkUnchecked + +equivalentWhenFirstSucceedsOnGens2 :: + (Show a, Show b, Show c, Eq c, CanFail f) + => (a -> b -> f c) + -> (a -> b -> c) + -> Gen (a, b) + -> ((a, b) -> [(a, b)]) + -> Property +equivalentWhenFirstSucceedsOnGens2 f g gen s = + forAllShrink gen s $ \(a, b) -> + case resultIfSucceeded (f a b) of + Nothing -> return () -- fine + Just rs -> rs `shouldBe` g a b + +equivalentWhenFirstSucceedsOnValids2 :: + ( Show a + , GenValid a + , Show b + , GenValid b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> f c) + -> (a -> b -> c) + -> Property +equivalentWhenFirstSucceedsOnValids2 f g = + equivalentWhenFirstSucceedsOnGens2 f g genValid shrinkValid + +equivalentWhenFirstSucceedsOnArbitrary2 :: + ( Show a + , Arbitrary a + , Show b + , Arbitrary b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> f c) + -> (a -> b -> c) + -> Property +equivalentWhenFirstSucceedsOnArbitrary2 f g = + equivalentWhenFirstSucceedsOnGens2 f g arbitrary shrink + +equivalentWhenFirstSucceeds2 :: + ( Show a + , GenUnchecked a + , Show b + , GenUnchecked b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> f c) + -> (a -> b -> c) + -> Property +equivalentWhenFirstSucceeds2 f g = + equivalentWhenFirstSucceedsOnGens2 f g genUnchecked shrinkUnchecked + +equivalentWhenSecondSucceedsOnGen :: + (Show a, Show b, Eq b, CanFail f) + => (a -> b) + -> (a -> f b) + -> Gen a + -> (a -> [a]) + -> Property +equivalentWhenSecondSucceedsOnGen f g gen s = + forAllShrink gen s $ \a -> + case resultIfSucceeded (g a) of + Nothing -> return () -- fine + Just r -> r `shouldBe` f a + +equivalentWhenSecondSucceedsOnValid :: + (Show a, GenValid a, Show b, Eq b, CanFail f) + => (a -> b) + -> (a -> f b) + -> Property +equivalentWhenSecondSucceedsOnValid f g = + equivalentWhenSecondSucceedsOnGen f g genValid shrinkValid + +equivalentWhenSecondSucceedsOnArbitrary :: + (Show a, Arbitrary a, Show b, Eq b, CanFail f) + => (a -> b) + -> (a -> f b) + -> Property +equivalentWhenSecondSucceedsOnArbitrary f g = + equivalentWhenSecondSucceedsOnGen f g arbitrary shrink + +equivalentWhenSecondSucceeds :: + (Show a, GenUnchecked a, Show b, Eq b, CanFail f) + => (a -> b) + -> (a -> f b) + -> Property +equivalentWhenSecondSucceeds f g = + equivalentWhenSecondSucceedsOnGen f g genUnchecked shrinkUnchecked + +equivalentWhenSecondSucceedsOnGens2 :: + (Show a, Show b, Show c, Eq c, CanFail f) + => (a -> b -> c) + -> (a -> b -> f c) + -> Gen (a, b) + -> ((a, b) -> [(a, b)]) + -> Property +equivalentWhenSecondSucceedsOnGens2 f g gen s = + forAllShrink gen s $ \(a, b) -> + case resultIfSucceeded (g a b) of + Nothing -> return () -- fine + Just rs -> rs `shouldBe` f a b + +equivalentWhenSecondSucceedsOnValids2 :: + ( Show a + , GenValid a + , Show b + , GenValid b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> c) + -> (a -> b -> f c) + -> Property +equivalentWhenSecondSucceedsOnValids2 f g = + equivalentWhenSecondSucceedsOnGens2 f g genValid shrinkValid + +equivalentWhenSecondSucceedsOnArbitrary2 :: + ( Show a + , Arbitrary a + , Show b + , Arbitrary b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> c) + -> (a -> b -> f c) + -> Property +equivalentWhenSecondSucceedsOnArbitrary2 f g = + equivalentWhenSecondSucceedsOnGens2 f g arbitrary shrink + +equivalentWhenSecondSucceeds2 :: + ( Show a + , GenUnchecked a + , Show b + , GenUnchecked b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> c) + -> (a -> b -> f c) + -> Property +equivalentWhenSecondSucceeds2 f g = + equivalentWhenSecondSucceedsOnGens2 f g genUnchecked shrinkUnchecked + +equivalentWhenSucceedOnGen :: + (Show a, Show b, Eq b, CanFail f) + => (a -> f b) + -> (a -> f b) + -> Gen a + -> (a -> [a]) + -> Property +equivalentWhenSucceedOnGen f g gen s = + forAllShrink gen s $ \a -> + case do fa <- resultIfSucceeded $ f a + ga <- resultIfSucceeded $ g a + return (fa, ga) of + Nothing -> return () -- fine + Just (fa, ga) -> fa `shouldBe` ga + +equivalentWhenSucceedOnValid :: + (Show a, GenValid a, Show b, Eq b, CanFail f) + => (a -> f b) + -> (a -> f b) + -> Property +equivalentWhenSucceedOnValid f g = + equivalentWhenSucceedOnGen f g genValid shrinkValid + +equivalentWhenSucceed :: + (Show a, GenUnchecked a, Show b, Eq b, CanFail f) + => (a -> f b) + -> (a -> f b) + -> Property +equivalentWhenSucceed f g = + equivalentWhenSucceedOnGen f g genUnchecked shrinkUnchecked + +equivalentWhenSucceedOnArbitrary :: + (Show a, Arbitrary a, Show b, Eq b, CanFail f) + => (a -> f b) + -> (a -> f b) + -> Property +equivalentWhenSucceedOnArbitrary f g = + equivalentWhenSucceedOnGen f g arbitrary shrink + +equivalentWhenSucceedOnGens2 :: + (Show a, Show b, Show c, Eq c, CanFail f) + => (a -> b -> f c) + -> (a -> b -> f c) + -> Gen (a, b) + -> ((a, b) -> [(a, b)]) + -> Property +equivalentWhenSucceedOnGens2 f g gen s = + forAllShrink gen s $ \(a, b) -> + case do fab <- resultIfSucceeded $ f a b + gab <- resultIfSucceeded $ g a b + return (fab, gab) of + Nothing -> return () -- fine + Just (fab, gab) -> fab `shouldBe` gab + +equivalentWhenSucceedOnValids2 :: + ( Show a + , GenValid a + , Show 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 shrinkValid + +equivalentWhenSucceedOnArbitrary2 :: + ( Show a + , Arbitrary a + , Show 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 shrink + +equivalentWhenSucceed2 :: + ( Show a + , GenUnchecked a + , Show 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 shrinkUnchecked + +equivalentOnGens3 :: + (Show a, Show b, Show c, Show d, Eq d) + => (a -> b -> c -> d) + -> (a -> b -> c -> d) + -> Gen (a, b, c) + -> ((a, b, c) -> [(a, b, c)]) + -> Property +equivalentOnGens3 f g gen s = + forAllShrink gen s $ \(a, b, c) -> f a b c `shouldBe` g a b c + +equivalentOnValids3 :: + ( Show a + , GenValid a + , Show b + , GenValid b + , Show c + , GenValid c + , Show d + , Eq d + ) + => (a -> b -> c -> d) + -> (a -> b -> c -> d) + -> Property +equivalentOnValids3 f g = equivalentOnGens3 f g genValid shrinkValid + +equivalent3 :: + ( Show a + , GenUnchecked a + , Show b + , GenUnchecked b + , Show c + , GenUnchecked c + , Show d + , Eq d + ) + => (a -> b -> c -> d) + -> (a -> b -> c -> d) + -> Property +equivalent3 f g = equivalentOnGens3 f g genUnchecked shrinkUnchecked + +equivalentOnArbitrary3 :: + ( Show a + , Arbitrary a + , Show b + , Arbitrary b + , Show c + , Arbitrary c + , Show d + , Eq d + ) + => (a -> b -> c -> d) + -> (a -> b -> c -> d) + -> Property +equivalentOnArbitrary3 f g = equivalentOnGens3 f g arbitrary shrink diff --git a/src/Test/Syd/Validity/Functions/Idempotence.hs b/src/Test/Syd/Validity/Functions/Idempotence.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Functions/Idempotence.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Standard tests involving validity +module Test.Syd.Validity.Functions.Idempotence + ( idempotentOnGen + , idempotentOnValid + , idempotent + , idempotentOnArbitrary + ) where + +import Data.GenValidity + +import Test.Syd +import Test.QuickCheck + +idempotentOnGen :: (Show a, Eq a) => (a -> a) -> Gen a -> (a -> [a]) -> Property +idempotentOnGen f gen s = forAllShrink gen s $ \a -> f (f a) `shouldBe` f a + +idempotentOnValid :: (Show a, Eq a, GenValid a) => (a -> a) -> Property +idempotentOnValid func = idempotentOnGen func genValid shrinkValid + +idempotent :: (Show a, Eq a, GenUnchecked a) => (a -> a) -> Property +idempotent func = idempotentOnGen func genUnchecked shrinkUnchecked + +-- | +-- +-- 'id' is idempotent for any type: +-- +-- prop> idempotentOnArbitrary (id :: Int -> Int) +-- +-- 'const', given any input, is idempotent for any type as well: +-- +-- prop> \int -> idempotentOnArbitrary (const int :: Int -> Int) +idempotentOnArbitrary :: (Show a, Eq a, Arbitrary a) => (a -> a) -> Property +idempotentOnArbitrary func = idempotentOnGen func arbitrary shrink diff --git a/src/Test/Syd/Validity/Functions/Inverse.hs b/src/Test/Syd/Validity/Functions/Inverse.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Functions/Inverse.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Standard tests involving inverse functions +module Test.Syd.Validity.Functions.Inverse + ( inverseFunctionsOnGen + , inverseFunctionsOnValid + , inverseFunctions + , inverseFunctionsOnArbitrary + , inverseFunctionsIfFirstSucceedsOnGen + , inverseFunctionsIfFirstSucceedsOnValid + , inverseFunctionsIfFirstSucceeds + , inverseFunctionsIfFirstSucceedsOnArbitrary + , inverseFunctionsIfSecondSucceedsOnGen + , inverseFunctionsIfSecondSucceedsOnValid + , inverseFunctionsIfSecondSucceeds + , inverseFunctionsIfSecondSucceedsOnArbitrary + , inverseFunctionsIfSucceedOnGen + , inverseFunctionsIfSucceedOnValid + , inverseFunctionsIfSucceed + , inverseFunctionsIfSucceedOnArbitrary + ) where + +import Data.GenValidity + +import Test.Syd +import Test.QuickCheck + +import Test.Syd.Validity.Types + +inverseFunctionsOnGen :: + (Show a, Eq a) => (a -> b) -> (b -> a) -> Gen a -> (a -> [a]) -> Property +inverseFunctionsOnGen f g gen s = + forAllShrink gen s $ \a -> g (f a) `shouldBe` a + +inverseFunctionsOnValid :: + (Show a, Eq a, GenValid a) => (a -> b) -> (b -> a) -> Property +inverseFunctionsOnValid f g = inverseFunctionsOnGen f g genValid shrinkValid + +inverseFunctions :: + (Show a, Eq a, GenUnchecked a) => (a -> b) -> (b -> a) -> Property +inverseFunctions f g = inverseFunctionsOnGen f g genUnchecked shrinkUnchecked + +-- | +-- '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 shrink + +inverseFunctionsIfFirstSucceedsOnGen :: + (Show a, Eq a, CanFail f) + => (a -> f b) + -> (b -> a) + -> Gen a + -> (a -> [a]) + -> Property +inverseFunctionsIfFirstSucceedsOnGen f g gen s = + forAllShrink gen s $ \a -> + case resultIfSucceeded (f a) of + Nothing -> return () -- fine + Just b -> g b `shouldBe` a + +inverseFunctionsIfFirstSucceedsOnValid :: + (Show a, Eq a, GenValid a, CanFail f) + => (a -> f b) + -> (b -> a) + -> Property +inverseFunctionsIfFirstSucceedsOnValid f g = + inverseFunctionsIfFirstSucceedsOnGen f g genValid shrinkValid + +inverseFunctionsIfFirstSucceeds :: + (Show a, Eq a, GenUnchecked a, CanFail f) + => (a -> f b) + -> (b -> a) + -> Property +inverseFunctionsIfFirstSucceeds f g = + inverseFunctionsIfFirstSucceedsOnGen f g genUnchecked shrinkUnchecked + +inverseFunctionsIfFirstSucceedsOnArbitrary :: + (Show a, Eq a, Arbitrary a, CanFail f) + => (a -> f b) + -> (b -> a) + -> Property +inverseFunctionsIfFirstSucceedsOnArbitrary f g = + inverseFunctionsIfFirstSucceedsOnGen f g arbitrary shrink + +inverseFunctionsIfSecondSucceedsOnGen :: + (Show a, Eq a, CanFail f) + => (a -> b) + -> (b -> f a) + -> Gen a + -> (a -> [a]) + -> Property +inverseFunctionsIfSecondSucceedsOnGen f g gen s = + forAllShrink gen s $ \a -> + case resultIfSucceeded (g (f a)) of + Nothing -> return () -- fine + Just r -> r `shouldBe` a + +inverseFunctionsIfSecondSucceedsOnValid :: + (Show a, Eq a, GenValid a, CanFail f) + => (a -> b) + -> (b -> f a) + -> Property +inverseFunctionsIfSecondSucceedsOnValid f g = + inverseFunctionsIfSecondSucceedsOnGen f g genValid shrinkValid + +inverseFunctionsIfSecondSucceeds :: + (Show a, Eq a, GenUnchecked a, CanFail f) + => (a -> b) + -> (b -> f a) + -> Property +inverseFunctionsIfSecondSucceeds f g = + inverseFunctionsIfSecondSucceedsOnGen f g genUnchecked shrinkUnchecked + +inverseFunctionsIfSecondSucceedsOnArbitrary :: + (Show a, Eq a, Arbitrary a, CanFail f) + => (a -> b) + -> (b -> f a) + -> Property +inverseFunctionsIfSecondSucceedsOnArbitrary f g = + inverseFunctionsIfSecondSucceedsOnGen f g arbitrary shrink + +inverseFunctionsIfSucceedOnGen :: + (Show a, Eq a, CanFail f, CanFail g) + => (a -> f b) + -> (b -> g a) + -> Gen a + -> (a -> [a]) + -> Property +inverseFunctionsIfSucceedOnGen f g gen s = + forAllShrink gen s $ \a -> + case do fa <- resultIfSucceeded $ f a + resultIfSucceeded $ g fa of + Nothing -> return () -- fine + Just r -> r `shouldBe` a + +inverseFunctionsIfSucceedOnValid :: + (Show a, Eq a, GenValid a, CanFail f, CanFail g) + => (a -> f b) + -> (b -> g a) + -> Property +inverseFunctionsIfSucceedOnValid f g = + inverseFunctionsIfSucceedOnGen f g genValid shrinkValid + +inverseFunctionsIfSucceed :: + (Show a, Eq a, GenUnchecked a, CanFail f, CanFail g) + => (a -> f b) + -> (b -> g a) + -> Property +inverseFunctionsIfSucceed f g = + inverseFunctionsIfSucceedOnGen f g genUnchecked shrinkUnchecked + +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 shrink diff --git a/src/Test/Syd/Validity/Functions/Validity.hs b/src/Test/Syd/Validity/Functions/Validity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Functions/Validity.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Standard tests involving validity +module Test.Syd.Validity.Functions.Validity + ( producesValidsOnGen + , producesValidsOnValids + , producesValid + , producesValidsOnArbitrary + , producesValidsOnGens2 + , producesValidsOnValids2 + , producesValid2 + , producesValidsOnArbitrary2 + , producesValidsOnGens3 + , producesValidsOnValids3 + , producesValid3 + , producesValidsOnArbitrary3 + ) where + +import Data.GenValidity + +import Test.QuickCheck + +import Test.Syd.Validity.Property.Utils + +-- | The function produces valid output when the input is generated as +-- specified by the given generator. +producesValidsOnGen :: + forall a b. (Show a, Show b, Validity b) + => (a -> b) + -> Gen a + -> (a -> [a]) + -> Property +producesValidsOnGen func gen s = forAllShrink gen s $ shouldBeValid . func + +-- | The function produces valid output when the input is generated by +-- @genValid@ +producesValidsOnValids :: + (Show a, Show b, GenValid a, Validity b) => (a -> b) -> Property +producesValidsOnValids f = producesValidsOnGen f genValid shrinkValid + +-- | The function produces valid output when the input is generated by +-- @genUnchecked@ +producesValid :: + (Show a, Show b, GenUnchecked a, Validity b) => (a -> b) -> Property +producesValid f = producesValidsOnGen f genUnchecked shrinkUnchecked + +-- | 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 f = producesValidsOnGen f arbitrary shrink + +producesValidsOnGens2 :: + (Show a, Show b, Show c, Validity c) + => (a -> b -> c) + -> Gen (a, b) + -> ((a, b) -> [(a, b)]) + -> Property +producesValidsOnGens2 func gen s = + forAllShrink gen s $ \(a, b) -> shouldBeValid $ func a b + +producesValidsOnValids2 :: + (Show a, Show b, Show c, GenValid a, GenValid b, Validity c) + => (a -> b -> c) + -> Property +producesValidsOnValids2 func = producesValidsOnGens2 func genValid shrinkValid + +producesValid2 :: + (Show a, Show b, Show c, GenUnchecked a, GenUnchecked b, Validity c) + => (a -> b -> c) + -> Property +producesValid2 func = producesValidsOnGens2 func genUnchecked shrinkUnchecked + +producesValidsOnArbitrary2 :: + (Show a, Show b, Show c, Arbitrary a, Arbitrary b, Validity c) + => (a -> b -> c) + -> Property +producesValidsOnArbitrary2 func = producesValidsOnGens2 func arbitrary shrink + +producesValidsOnGens3 :: + (Show a, Show b, Show c, Show d, Validity d) + => (a -> b -> c -> d) + -> Gen (a, b, c) + -> ((a, b, c) -> [(a, b, c)]) + -> Property +producesValidsOnGens3 func gen s = + forAllShrink gen s $ \(a, b, c) -> shouldBeValid $ func a b c + +producesValidsOnValids3 :: + ( 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 shrinkValid + +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 shrinkUnchecked + +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 shrink diff --git a/src/Test/Syd/Validity/Functor.hs b/src/Test/Syd/Validity/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Functor.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Functor properties +-- +-- You will need @TypeApplications@ to use these. +module Test.Syd.Validity.Functor + ( functorSpecOnValid + , functorSpec + , functorSpecOnArbitrary + , functorSpecOnGens + ) where + +import Data.Data + +import Data.GenValidity +import Data.Kind + +import Test.Syd +import Test.QuickCheck + +import Test.Syd.Validity.Functions +import Test.Syd.Validity.Utils + +{-# ANN module "HLint: ignore Functor law" #-} + +fmapTypeStr :: + forall (f :: Type -> Type). (Typeable f) + => String +fmapTypeStr = + unwords + [ "fmap" + , "::" + , "(a" + , "->" + , "b)" + , "->" + , nameOf @f + , "a" + , "->" + , nameOf @f + , "b" + ] + +flTypeStr :: + forall (f :: Type -> Type). (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 :: Type -> Type). + (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 :: Type -> Type). + (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 :: Type -> Type). + (Eq (f Int), Show (f Int), Functor f, Typeable f, Arbitrary (f Int)) + => Spec +functorSpecOnArbitrary = functorSpecWithInts @f arbitrary + +functorSpecWithInts :: + forall (f :: Type -> Type). (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 :: Type -> Type) (a :: Type) (b :: Type) (c :: Type). + ( 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 shrinkNothing + 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 + shrinkNothing + 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 shrinkNothing diff --git a/src/Test/Syd/Validity/GenRelativeValidity.hs b/src/Test/Syd/Validity/GenRelativeValidity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/GenRelativeValidity.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for GenRelativeValidity instances +-- +-- You will need @TypeApplications@ to use these. +module Test.Syd.Validity.GenRelativeValidity + ( genRelativeValiditySpec + , genRelativeValidSpec + , genRelativeInvalidSpec + , genRelativeValidGeneratesValid + , genRelativeInvalidGeneratesInvalid + ) where + +import Data.Data + +import Data.GenRelativeValidity +import Data.GenValidity + +import Test.Syd +import Test.QuickCheck + +import Test.Syd.Validity.Property.Utils +import Test.Syd.Validity.Utils + +-- | A @Spec@ that specifies that @genValidFor@ and @genInvalidFor@ work as +-- intended. +-- +-- In general it is a good idea to add this spec to your test suite if you +-- write a custom implementation of @genValidFor@ or @genInvalidFor@. +-- +-- Example usage: +-- +-- > relativeGenValiditySpec @MyDataFor @MyOtherData +genRelativeValiditySpec :: + forall a b. + ( Typeable a + , Show a + , Show b + , GenUnchecked b + , GenValid b + , GenRelativeValid a b + , GenRelativeInvalid a b + ) + => Spec +genRelativeValiditySpec = do + genRelativeValidSpec @a @b + genRelativeInvalidSpec @a @b + +genRelativeValidSpec :: + forall a b. + ( Typeable a + , Show a + , Show b + , GenValid b + , GenRelativeValid a b + ) + => Spec +genRelativeValidSpec = + parallel $ do + let nameOne = nameOf @a + let nameTwo = nameOf @a + describe ("GenRelativeValidity " ++ nameOne ++ " " ++ nameTwo) $ + describe ("genValidFor :: " ++ nameTwo ++ " -> Gen " ++ nameOne) $ + it + ("only generates valid \'" ++ + nameOne ++ "\'s for the " ++ nameTwo) $ + genRelativeValidGeneratesValid @a @b + +genRelativeInvalidSpec :: + forall a b. + ( Typeable a + , Show a + , Show b + , GenUnchecked b + , GenRelativeInvalid a b + ) + => Spec +genRelativeInvalidSpec = + parallel $ do + let nameOne = nameOf @a + let nameTwo = nameOf @a + describe ("GenRelativeInvalid " ++ nameOne ++ " " ++ nameTwo) $ + 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@ +genRelativeValidGeneratesValid :: + forall a b. + (Show a, Show b, GenValid b, GenRelativeValid a b) + => Property +genRelativeValidGeneratesValid = + forAllValid $ \(b :: b) -> + forAll (genValidFor b) $ \(a :: a) -> a `shouldSatisfy` (`isValidFor` b) + +-- | @genInvalidFor b@ only generates values that do not satisfy @isValidFor b@ +genRelativeInvalidGeneratesInvalid :: + forall a b. + ( Show a + , Show b + , GenUnchecked b + , GenRelativeInvalid a b + ) + => Property +genRelativeInvalidGeneratesInvalid = + forAllUnchecked $ \(b :: b) -> + forAll (genInvalidFor b) $ \(a :: a) -> + a `shouldNotSatisfy` (`isValidFor` b) diff --git a/src/Test/Syd/Validity/GenValidity.hs b/src/Test/Syd/Validity/GenValidity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/GenValidity.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for GenValidity instances +-- +-- You will need @TypeApplications@ to use these. +module Test.Syd.Validity.GenValidity + ( genValiditySpec + , genValidSpec + , genInvalidSpec + , genValidGeneratesValid + , genGeneratesValid + , genInvalidGeneratesInvalid + , genGeneratesInvalid + ) where + +import Data.Data + +import Data.GenValidity + +import Test.Syd +import Test.QuickCheck + +import Test.Syd.Validity.GenValidity.Property +import Test.Syd.Validity.Utils + +-- | 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@. +-- +-- __It is not a good idea to use this function if invalid values are broken in such a way that 'Show' or even 'isValid' is broken.__ +-- In that case you probably want 'genValidSpec'. +-- +-- Example usage: +-- +-- > genValiditySpec @Int +genValiditySpec :: + forall a. (Typeable a, Show a, GenValid a, GenInvalid a) + => Spec +genValiditySpec = do + genValidSpec @a + genInvalidSpec @a + +-- | A @Spec@ that specifies that @genValid@ only generates valid data. +-- +-- In general it is a good idea to add this spec to your test suite if you +-- write a custom implementation of @genValid@. +-- +-- Example usage: +-- +-- > genValidSpec @Int +genValidSpec :: + forall a. (Typeable a, Show a, GenValid a) + => Spec +genValidSpec = + parallel $ do + let name = nameOf @a + describe ("GenValid " ++ name) $ + describe ("genValid :: Gen " ++ name) $ + it ("only generates valid \'" ++ name ++ "\'s") $ + genValidGeneratesValid @a + +-- | A @Spec@ that specifies that @genInvalid@ only generates invalid data. +-- +-- Note that it is not a good idea to use this function if invalid values are broken in such a way that 'Show' or even 'isValid' is broken. +-- +-- Example usage: +-- +-- > genInvalidSpec @Rational +genInvalidSpec :: + forall a. (Typeable a, Show a, GenInvalid a) + => Spec +genInvalidSpec = + parallel $ do + let name = nameOf @a + describe ("GenInvalid " ++ name) $ + describe ("genInvalid :: Gen " ++ name) $ + it ("only generates invalid \'" ++ name ++ "\'s") $ + genInvalidGeneratesInvalid @a + +-- | @genValid@ only generates valid data +-- +-- 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 + +-- | @genValid@ only generates invalid data +-- +-- prop> genInvalidGeneratesInvalid @Rational +-- prop> genInvalidGeneratesInvalid @Rational +-- prop> genInvalidGeneratesInvalid @(Maybe Rational) +-- prop> genInvalidGeneratesInvalid @[Rational] +genInvalidGeneratesInvalid :: + forall a. (Show a, GenInvalid a) + => Property +genInvalidGeneratesInvalid = genGeneratesInvalid @a genInvalid diff --git a/src/Test/Syd/Validity/GenValidity/Property.hs b/src/Test/Syd/Validity/GenValidity/Property.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/GenValidity/Property.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for GenValidity instances +module Test.Syd.Validity.GenValidity.Property + ( genGeneratesValid + , genGeneratesInvalid + ) where + +import Data.GenValidity + +import Test.QuickCheck + +import Test.Syd.Validity.Property.Utils + +-- | The given generator generates only valid data points +genGeneratesValid :: + forall a. (Show a, Validity a) + => Gen a + -> Property +genGeneratesValid gen = forAll gen shouldBeValid + +-- | The given generator generates only invalid data points +genGeneratesInvalid :: + forall a. (Show a, Validity a) + => Gen a + -> Property +genGeneratesInvalid gen = forAll gen shouldBeInvalid diff --git a/src/Test/Syd/Validity/Monad.hs b/src/Test/Syd/Validity/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Monad.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Monad properties +-- +-- You will need @TypeApplications@ to use these. +module Test.Syd.Validity.Monad + ( monadSpecOnValid + , monadSpec + , monadSpecOnArbitrary + , monadSpecOnGens + ) where + +import Data.Data + +import Control.Monad (ap) +import Data.Kind (Type) +import Data.GenValidity +import Test.QuickCheck.Gen (unGen) +import Test.QuickCheck.Random (mkQCGen) + +import Test.Syd +import Test.QuickCheck + +import Test.Syd.Validity.Functions +import Test.Syd.Validity.Utils + +{-# ANN module "HLint: ignore Use fmap" #-} + +{-# ANN module "HLint: ignore Use <$>" #-} + +{-# ANN module "HLint: ignore Use >=>" #-} + +{-# ANN module "HLint: ignore Use id" #-} + +{-# ANN module "HLint: ignore Monad law, left identity" #-} + +{-# ANN module "HLint: ignore Monad law, right identity" #-} + +{-# ANN module "HLint: ignore Avoid lambda" #-} + +{-# ANN module "HLint: ignore Reduce duplication" #-} + +returnTypeStr :: + forall (m :: Type -> Type). (Typeable m) + => String +returnTypeStr = unwords ["return", "::", "a", "->", nameOf @m, "a"] + +bindTypeStr :: + forall (m :: Type -> Type). (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: +-- +-- > monadSpecOnValid @[] +monadSpecOnValid :: + forall (f :: Type -> Type). + (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: +-- +-- > monadSpec @[] +monadSpec :: + forall (f :: Type -> Type). + (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 :: Type -> Type). + (Eq (f Int), Show (f Int), Monad f, Typeable f, Arbitrary (f Int)) + => Spec +monadSpecOnArbitrary = monadSpecWithInts @f arbitrary + +monadSpecWithInts :: + forall (f :: Type -> Type). (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 s <- genListLength + pure $ \b -> unGen gen (mkQCGen b) s) + "perturbations using the int" + (do s <- genListLength + pure $ \b -> unGen gen (mkQCGen $ 2 * b) s) + "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 :: Type -> Type) (a :: Type) (b :: Type) (c :: Type). + ( Show 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)) + shrinkNothing + it + (unwords + [ "satisfy the second Monad law: 'm >>= return = m' for" + , genDescr @(f a) genname + ]) $ + equivalentOnGen (\m -> m >>= return) (\m -> m) gen shrinkNothing + 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)) + shrinkNothing + describe (unwords ["relation with Applicative", nameOf @f]) $ do + it + (unwords + ["satisfies 'pure = return' for", genDescr @(f a) genname]) $ + equivalentOnGen (pure @f) (return @f) gena shrinkNothing + 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) + shrinkNothing + it + (unwords + [ "satisfies '(>>) = (*>)' for" + , genDescr @(f a) genname + , "and" + , genDescr @(f b) genbname + ]) $ + equivalentOnGens2 (>>) (*>) ((,) <$> gen <*> genb) shrinkNothing + describe (unwords ["relation with Functor", nameOf @f]) $ + 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) + shrinkNothing diff --git a/src/Test/Syd/Validity/Monoid.hs b/src/Test/Syd/Validity/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Monoid.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Monoid properties +-- +-- You will need @TypeApplications@ to use these. +module Test.Syd.Validity.Monoid + ( monoidSpecOnValid + , monoidSpec + , monoidSpecOnArbitrary + , monoidSpecOnGen + ) where + +import Data.Data + +import Data.GenValidity + +import Test.Syd +import Test.QuickCheck + +import Test.Syd.Validity.Functions +import Test.Syd.Validity.Operations +import Test.Syd.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" shrinkValid + +-- | 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" shrinkUnchecked + +-- | 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" shrink + +-- | 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 + -> (a -> [a]) + -> Spec +monoidSpecOnGen gen genname s = + parallel $ do + let name = nameOf @a + memptystr = memptyTypeStr @a + mappendstr = mappendTypeStr @a + mconcatstr = mconcatTypeStr @a + gen3 = (,,) <$> gen <*> gen <*> gen + s3 (a, b, c) = (,,) <$> s a <*> s b <*> s c + genl = genListOf gen + sl = shrinkList s + describe ("Monoid " ++ name) $ do + let mem = mempty @a + mapp = mappend @a + mcon = mconcat @a + describe memptystr $ + it + (unwords + [ "is the identity for" + , mappendstr + , "for" + , genDescr @a genname + ]) $ + identityOnGen mapp mem gen s + describe mappendstr $ + it + (unwords + [ "is an associative operation for" + , genDescr @(a, a, a) genname + ]) $ + associativeOnGens mapp gen3 s3 + describe mconcatstr $ + it + (unwords + [ "is equivalent to its default implementation for" + , genDescr @[a] genname + ]) $ + equivalentOnGen mcon (foldr mapp mem) genl sl diff --git a/src/Test/Syd/Validity/Operations.hs b/src/Test/Syd/Validity/Operations.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Operations.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Properties of operations +module Test.Syd.Validity.Operations + ( leftIdentityOnElemWithEquality + , leftIdentityOnGenWithEquality + , leftIdentityOnGen + , leftIdentityOnValid + , leftIdentity + , leftIdentityOnArbitrary + , rightIdentityOnElemWithEquality + , rightIdentityOnGenWithEquality + , rightIdentityOnGen + , rightIdentityOnValid + , rightIdentity + , rightIdentityOnArbitrary + , identityOnGen + , identityOnValid + , identity + , identityOnArbitrary + , associativeOnGens + , associativeOnValids + , associative + , associativeOnArbitrary + , commutativeOnGens + , commutativeOnValids + , commutative + , commutativeOnArbitrary + ) where + +import Test.Syd.Validity.Operations.Associativity +import Test.Syd.Validity.Operations.Commutativity +import Test.Syd.Validity.Operations.Identity diff --git a/src/Test/Syd/Validity/Operations/Associativity.hs b/src/Test/Syd/Validity/Operations/Associativity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Operations/Associativity.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Syd.Validity.Operations.Associativity + ( associativeOnGens + , associativeOnValids + , associative + , associativeOnArbitrary + ) where + +import Data.GenValidity + +import Test.Syd +import Test.QuickCheck + +-- | +-- +-- \[ +-- Associative(\star) +-- \quad\equiv\quad +-- \forall a, b, c: +-- (a \star b) \star c = a \star (b \star c) +-- \] +associativeOnGens :: + (Show a, Eq a) + => (a -> a -> a) + -> Gen (a, a, a) + -> ((a, a, a) -> [(a, a, a)]) + -> Property +associativeOnGens op gen s = + forAllShrink gen s $ \(a, b, c) -> + ((a `op` b) `op` c) `shouldBe` (a `op` (b `op` c)) + +associativeOnValids :: (Show a, Eq a, GenValid a) => (a -> a -> a) -> Property +associativeOnValids op = associativeOnGens op genValid shrinkValid + +-- | +-- +-- prop> associative ((*) :: Int -> Int -> Int) +-- prop> associative ((+) :: Int -> Int -> Int) +associative :: (Show a, Eq a, GenUnchecked a) => (a -> a -> a) -> Property +associative op = associativeOnGens op genUnchecked shrinkUnchecked + +-- | +-- +-- prop> associativeOnArbitrary ((*) :: Int -> Int -> Int) +-- prop> associativeOnArbitrary ((+) :: Int -> Int -> Int) +associativeOnArbitrary :: + (Show a, Eq a, Arbitrary a) => (a -> a -> a) -> Property +associativeOnArbitrary op = associativeOnGens op arbitrary shrink diff --git a/src/Test/Syd/Validity/Operations/Commutativity.hs b/src/Test/Syd/Validity/Operations/Commutativity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Operations/Commutativity.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Syd.Validity.Operations.Commutativity + ( commutativeOnGens + , commutativeOnValids + , commutative + , commutativeOnArbitrary + ) where + +import Data.GenValidity + +import Test.Syd +import Test.QuickCheck + +-- | +-- +-- \[ +-- Commutative(\star) +-- \quad\equiv\quad +-- \forall a, b: +-- a \star b = b \star a +-- \] +commutativeOnGens :: + (Show a, Show b, Eq b) + => (a -> a -> b) + -> Gen (a, a) + -> ((a, a) -> [(a, a)]) + -> Property +commutativeOnGens op gen s = + forAllShrink gen s $ \(a, b) -> (a `op` b) `shouldBe` (b `op` a) + +-- | +-- +-- prop> commutativeOnValids ((+) :: Rational -> Rational -> Rational) +-- prop> commutativeOnValids ((*) :: Rational -> Rational -> Rational) +commutativeOnValids :: + (Show a, Show b, Eq b, GenValid a) + => (a -> a -> b) -> Property +commutativeOnValids op = commutativeOnGens op genValid shrinkValid + +-- | +-- +-- prop> commutative ((+) :: Int -> Int -> Int) +-- prop> commutative ((*) :: Int -> Int -> Int) +commutative :: + (Show a, Show b, Eq b, GenUnchecked a) + => (a -> a -> b) -> Property +commutative op = commutativeOnGens op genUnchecked shrinkUnchecked + +-- | +-- +-- prop> commutativeOnArbitrary ((+) :: Int -> Int -> Int) +-- prop> commutativeOnArbitrary ((*) :: Int -> Int -> Int) +-- commutativeOnArbitrary :: +-- (Show a, Eq a, Arbitrary a) => (a -> a -> a) -> Property +commutativeOnArbitrary :: + (Show a, Show b, Eq b, Arbitrary a) + => (a -> a -> b) -> Property +commutativeOnArbitrary op = commutativeOnGens op arbitrary shrink diff --git a/src/Test/Syd/Validity/Operations/Identity.hs b/src/Test/Syd/Validity/Operations/Identity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Operations/Identity.hs @@ -0,0 +1,170 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Syd.Validity.Operations.Identity + ( leftIdentityOnElemWithEquality + , leftIdentityOnGenWithEquality + , leftIdentityOnGen + , leftIdentityOnValid + , leftIdentity + , leftIdentityOnArbitrary + , rightIdentityOnElemWithEquality + , rightIdentityOnGenWithEquality + , rightIdentityOnGen + , rightIdentityOnValid + , rightIdentity + , rightIdentityOnArbitrary + , identityOnGen + , identityOnValid + , identity + , identityOnArbitrary + ) where + +import Data.GenValidity + +import Test.QuickCheck + +-- | +-- +-- \[ +-- LeftIdentity(\star, \doteq, b) +-- \quad\equiv\quad +-- \forall a: (b \star a) \doteq a +-- \] +leftIdentityOnElemWithEquality :: + (b -> a -> a) -- ^ A binary operation + -> (a -> a -> Bool) -- ^ An equality + -> 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 + -> (a -> a -> Bool) -- ^ An equality + -> b -- ^ A candidate left-identity + -> Gen a + -> (a -> [a]) + -> Property +leftIdentityOnGenWithEquality op eq b gen s = + forAllShrink gen s $ leftIdentityOnElemWithEquality op eq b + +leftIdentityOnGen :: + (Show a, Eq a) + => (b -> a -> a) -- ^ A binary operation + -> b -- ^ A candidate left-identity + -> Gen a + -> (a -> [a]) + -> Property +leftIdentityOnGen op = leftIdentityOnGenWithEquality op (==) + +-- | +-- +-- prop> leftIdentityOnValid (flip ((^) :: Rational -> Int -> Rational)) 1 +leftIdentityOnValid :: + (Show a, Eq a, GenValid a) => (b -> a -> a) -> b -> Property +leftIdentityOnValid op b = leftIdentityOnGen op b genValid shrinkValid + +-- | +-- +-- prop> leftIdentity (flip ((^) :: Int -> Int -> Int)) 1 +leftIdentity :: (Show a, Eq a, GenUnchecked a) => (b -> a -> a) -> b -> Property +leftIdentity op b = leftIdentityOnGen op b genUnchecked shrinkUnchecked + +-- | +-- +-- prop> leftIdentityOnArbitrary (flip ((^) :: Int -> Int -> Int)) 1 +leftIdentityOnArbitrary :: + (Show a, Eq a, Arbitrary a) => (b -> a -> a) -> b -> Property +leftIdentityOnArbitrary op b = leftIdentityOnGen op b arbitrary shrink + +-- | +-- +-- \[ +-- RightIdentity(\star, \doteq, b) +-- \quad\equiv\quad +-- \forall a: (a \star b) \doteq a +-- \] +rightIdentityOnElemWithEquality :: + (a -> b -> a) -- ^ A binary operation + -> (a -> a -> Bool) -- ^ An equality + -> 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 -> a -> Bool) -- ^ An equality + -> b -- ^ A candidate right-identity + -> Gen a + -> (a -> [a]) + -> Property +rightIdentityOnGenWithEquality op eq b gen s = + forAllShrink gen s $ rightIdentityOnElemWithEquality op eq b + +rightIdentityOnGen :: + (Show a, Eq a) + => (a -> b -> a) -- ^ A binary operation + -> b -- ^ A candidate right-identity + -> Gen a + -> (a -> [a]) + -> Property +rightIdentityOnGen op = rightIdentityOnGenWithEquality op (==) + +-- | +-- +-- prop> rightIdentityOnValid ((^) :: Rational -> Int -> Rational) 1 +rightIdentityOnValid :: + (Show a, Eq a, GenValid a) => (a -> b -> a) -> b -> Property +rightIdentityOnValid op b = rightIdentityOnGen op b genValid shrinkValid + +-- | +-- +-- prop> rightIdentity ((^) :: Int -> Int -> Int) 1 +rightIdentity :: + (Show a, Eq a, GenUnchecked a) => (a -> b -> a) -> b -> Property +rightIdentity op b = rightIdentityOnGen op b genUnchecked shrinkUnchecked + +-- | +-- +-- prop> rightIdentityOnArbitrary ((^) :: Int -> Int -> Int) 1 +rightIdentityOnArbitrary :: + (Show a, Eq a, Arbitrary a) => (a -> b -> a) -> b -> Property +rightIdentityOnArbitrary op b = rightIdentityOnGen op b arbitrary shrink + +-- | +-- +-- \[ +-- Identity(\star, \doteq, b) +-- \quad\equiv\quad +-- LeftIdentity(\star, \doteq, b) \wedge RightIdentity(\star, \doteq, b) +-- \] +identityOnGen :: + (Show a, Eq a) => (a -> a -> a) -> a -> Gen a -> (a -> [a]) -> Property +identityOnGen op e gen s = + leftIdentityOnGen op e gen s .&&. rightIdentityOnGen op e gen s + +-- | +-- +-- prop> identityOnValid ((*) :: Rational -> Rational -> Rational) 1 +-- prop> identityOnValid ((+) :: Rational -> Rational -> Rational) 0 +identityOnValid :: (Show a, Eq a, GenValid a) => (a -> a -> a) -> a -> Property +identityOnValid op a = identityOnGen op a genValid shrinkValid + +-- | +-- +-- prop> identity ((*) :: Int -> Int -> Int) 1 +-- prop> identity ((+) :: Int -> Int -> Int) 0 +identity :: (Show a, Eq a, GenUnchecked a) => (a -> a -> a) -> a -> Property +identity op e = identityOnGen op e genUnchecked shrinkUnchecked + +-- | +-- +-- prop> identityOnArbitrary ((*) :: Int -> Int -> Int) 1 +-- prop> identityOnArbitrary ((+) :: Int -> Int -> Int) 0 +identityOnArbitrary :: + (Show a, Eq a, Arbitrary a) => (a -> a -> a) -> a -> Property +identityOnArbitrary op a = identityOnGen op a arbitrary shrink diff --git a/src/Test/Syd/Validity/Ord.hs b/src/Test/Syd/Validity/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Ord.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Ord properties +-- +-- You will need @TypeApplications@ to use these. +module Test.Syd.Validity.Ord + ( ordSpecOnGen, + ordSpecOnValid, + ordSpecOnInvalid, + ordSpec, + ordSpecOnArbitrary, + ) +where + +import Data.Data +import Data.GenValidity +import Test.QuickCheck +import Test.Syd +import Test.Syd.Validity.Functions +import Test.Syd.Validity.Relations +import Test.Syd.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, GenValid a) => + Spec +ordSpecOnValid = ordSpecOnGen @a genValid "valid" shrinkValid + +-- | Standard test spec for properties of Ord instances for invalid values +-- +-- Example usage: +-- +-- > ordSpecOnInvalid @Double +ordSpecOnInvalid :: + forall a. + (Show a, Ord a, Typeable a, GenInvalid a) => + Spec +ordSpecOnInvalid = ordSpecOnGen @a genInvalid "invalid" shrinkInvalid + +-- | Standard test spec for properties of Ord instances for unchecked values +-- +-- Example usage: +-- +-- > ordSpec @Int +ordSpec :: + forall a. + (Show a, Ord a, Typeable a, GenUnchecked a) => + Spec +ordSpec = ordSpecOnGen @a genUnchecked "unchecked" shrinkUnchecked + +-- | 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 "arbitrary" shrink + +-- | 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, Ord a, Typeable a) => + Gen a -> + String -> + (a -> [a]) -> + Spec +ordSpecOnGen gen genname s = + parallel $ do + let name = nameOf @a + funlestr = leTypeStr @a + fungestr = geTypeStr @a + funltstr = ltTypeStr @a + fungtstr = gtTypeStr @a + minmaxtstr = genDescr @(a -> a -> a) + itProp s_ = + it $ + unwords + [ s_, + "\"" ++ genname, + name ++ "\"" ++ "'s" + ] + cmple = (<=) @a + cmpge = (>=) @a + cmplt = (<) @a + cmpgt = (>) @a + gen2 = (,) <$> gen <*> gen + gen3 = (,,) <$> gen <*> gen <*> gen + s2 = shrinkT2 s + describe ("Ord " ++ name) $ do + describe funlestr $ do + itProp "is reflexive for" $ + reflexivityOnGen cmple gen s + itProp "is antisymmetric for" $ + antisymmetryOnGens cmple gen2 s + itProp "is transitive for" $ + transitivityOnGens cmple gen3 s + itProp "is equivalent to (\\a b -> compare a b /= GT) for" $ + equivalentOnGens2 cmple (\a b -> compare a b /= GT) gen2 s2 + describe fungestr $ do + itProp "is reflexive for" $ + reflexivityOnGen cmpge gen s + itProp "is antisymmetric for" $ + antisymmetryOnGens cmpge gen2 s + itProp "is transitive for" $ + transitivityOnGens cmpge gen3 s + itProp "is equivalent to (\\a b -> compare a b /= LT) for" $ + equivalentOnGens2 cmpge (\a b -> compare a b /= LT) gen2 s2 + describe funltstr $ do + itProp "is antireflexive for" $ + antireflexivityOnGen cmplt gen s + itProp "is transitive for" $ + transitivityOnGens cmplt gen3 s + itProp "is equivalent to (\\a b -> compare a b == LT) for" $ + equivalentOnGens2 cmplt (\a b -> compare a b == LT) gen2 s2 + describe fungtstr $ do + itProp "is antireflexive for" $ + antireflexivityOnGen cmpgt gen s + itProp "is transitive for" $ + transitivityOnGens cmpgt gen3 s + itProp "is equivalent to (\\a b -> compare a b == GT) for" $ + equivalentOnGens2 cmpgt (\a b -> compare a b == GT) gen2 s2 + describe (minmaxtstr "min") $ do + itProp "is equivalent to (\\a b -> if a <= b then a else b) for" $ + equivalentOnGens2 min (\a b -> if a <= b then a else b) gen2 s2 + describe (minmaxtstr "max") $ do + itProp "is equivalent to (\\a b -> if a >= b then a else b) for" $ + equivalentOnGens2 max (\a b -> if a >= b then a else b) gen2 s2 diff --git a/src/Test/Syd/Validity/Property.hs b/src/Test/Syd/Validity/Property.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Property.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Syd.Validity.Property + ( module Data.GenValidity + , forAllUnchecked + , forAllValid + , forAllInvalid + -- * Tests for GenValidity instances + , genGeneratesValid + , genGeneratesInvalid + -- * Standard tests involving functions + -- ** Standard tests involving validity + , producesValidsOnGen + , producesValidsOnValids + , producesValid + , producesValidsOnArbitrary + , producesValidsOnGens2 + , producesValidsOnValids2 + , producesValid2 + , producesValidsOnArbitrary2 + , producesValidsOnGens3 + , 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 + , validIfSucceedsOnGens3 + , validIfSucceedsOnValids3 + , validIfSucceeds3 + , validIfSucceedsOnArbitrary3 + -- ** 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 + , inverseFunctions + , inverseFunctionsOnArbitrary + , inverseFunctionsIfFirstSucceedsOnGen + , inverseFunctionsIfFirstSucceedsOnValid + , inverseFunctionsIfFirstSucceeds + , inverseFunctionsIfFirstSucceedsOnArbitrary + , inverseFunctionsIfSecondSucceedsOnGen + , inverseFunctionsIfSecondSucceedsOnValid + , inverseFunctionsIfSecondSucceeds + , inverseFunctionsIfSecondSucceedsOnArbitrary + , inverseFunctionsIfSucceedOnGen + , 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 + , 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 + ) where + +import Data.GenValidity + +import Test.Syd.Validity.Functions +import Test.Syd.Validity.GenValidity.Property +import Test.Syd.Validity.Operations +import Test.Syd.Validity.Property.Utils +import Test.Syd.Validity.Relations +import Test.Syd.Validity.Types diff --git a/src/Test/Syd/Validity/Property/Utils.hs b/src/Test/Syd/Validity/Property/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Property/Utils.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE CPP #-} + +module Test.Syd.Validity.Property.Utils + ( forAllUnchecked, + forAllValid, + forAllInvalid, + shouldBeValid, + shouldBeInvalid, + (<==>), + (===>), + ) +where + +import Data.GenValidity +import Test.QuickCheck +import Test.Syd + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (pure) +#endif + +forAllUnchecked :: + (Show a, GenUnchecked a, Testable prop) => (a -> prop) -> Property +forAllUnchecked = forAllShrink genUnchecked shrinkUnchecked + +forAllValid :: (Show a, GenValid a, Testable prop) => (a -> prop) -> Property +forAllValid = forAllShrink genValid shrinkValid + +forAllInvalid :: + (Show a, GenInvalid a, Testable prop) => (a -> prop) -> Property +forAllInvalid = forAllShrink genInvalid shrinkInvalid + +(===>) :: Bool -> Bool -> Bool +(===>) a b = not a || b + +(<==>) :: Bool -> Bool -> Bool +(<==>) a b = a ===> b && b ===> a + +shouldBeValid :: (Show a, Validity a) => a -> Expectation +shouldBeValid a = + case prettyValidate a of + Right _ -> pure () + Left err -> + expectationFailure $ + unlines + [ "'validate' reported this value to be invalid: ", + show a, + "pretty version:", + ppShow a, + "with explanation:", + err, + "" + ] + +shouldBeInvalid :: (Show a, Validity a) => a -> Expectation +shouldBeInvalid a = + case prettyValidate a of + Right _ -> + expectationFailure $ + unlines + [ "'validate' reported this value to be valid: ", + show a, + "pretty version:", + ppShow a, + "where we expected it to be invalid" + ] + Left _ -> pure () diff --git a/src/Test/Syd/Validity/Relations.hs b/src/Test/Syd/Validity/Relations.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Relations.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Properties of relations +module Test.Syd.Validity.Relations + ( reflexiveOnElem + , reflexivityOnGen + , reflexivityOnValid + , reflexivity + , reflexivityOnArbitrary + , transitiveOnElems + , transitivityOnGens + , transitivityOnValid + , transitivity + , transitivityOnArbitrary + , antisymmetricOnElemsWithEquality + , antisymmetryOnGensWithEquality + , antisymmetryOnGens + , antisymmetryOnValid + , antisymmetry + , antisymmetryOnArbitrary + , antireflexiveOnElem + , antireflexivityOnGen + , antireflexivityOnValid + , antireflexivity + , antireflexivityOnArbitrary + , symmetricOnElems + , symmetryOnGens + , symmetryOnValid + , symmetry + , symmetryOnArbitrary + ) where + +import Test.Syd.Validity.Relations.Antireflexivity +import Test.Syd.Validity.Relations.Antisymmetry +import Test.Syd.Validity.Relations.Reflexivity +import Test.Syd.Validity.Relations.Symmetry +import Test.Syd.Validity.Relations.Transitivity diff --git a/src/Test/Syd/Validity/Relations/Antireflexivity.hs b/src/Test/Syd/Validity/Relations/Antireflexivity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Relations/Antireflexivity.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Syd.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 -> (a -> [a]) -> Property +antireflexivityOnGen func gen s = forAllShrink gen s $ antireflexiveOnElem func + +-- | +-- +-- prop> antireflexivityOnValid ((<) :: Rational -> Rational -> Bool) +-- prop> antireflexivityOnValid ((/=) :: Rational -> Rational -> Bool) +-- prop> antireflexivityOnValid ((>) :: Rational -> Rational -> Bool) +antireflexivityOnValid :: (Show a, GenValid a) => (a -> a -> Bool) -> Property +antireflexivityOnValid func = antireflexivityOnGen func genValid shrinkValid + +-- | +-- +-- prop> antireflexivity ((<) :: Int -> Int -> Bool) +-- prop> antireflexivity ((/=) :: Int -> Int -> Bool) +-- prop> antireflexivity ((>) :: Int -> Int -> Bool) +antireflexivity :: (Show a, GenUnchecked a) => (a -> a -> Bool) -> Property +antireflexivity func = antireflexivityOnGen func genUnchecked shrinkUnchecked + +-- | +-- +-- prop> antireflexivityOnArbitrary ((<) :: Int -> Int -> Bool) +-- prop> antireflexivityOnArbitrary ((/=) :: Int -> Int -> Bool) +-- prop> antireflexivityOnArbitrary ((>) :: Int -> Int -> Bool) +antireflexivityOnArbitrary :: + (Show a, Arbitrary a) => (a -> a -> Bool) -> Property +antireflexivityOnArbitrary func = antireflexivityOnGen func arbitrary shrink diff --git a/src/Test/Syd/Validity/Relations/Antisymmetry.hs b/src/Test/Syd/Validity/Relations/Antisymmetry.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Relations/Antisymmetry.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Syd.Validity.Relations.Antisymmetry + ( antisymmetricOnElemsWithEquality + , antisymmetryOnGensWithEquality + , antisymmetryOnGens + , antisymmetryOnValid + , antisymmetry + , antisymmetryOnArbitrary + ) where + +import Data.GenValidity + +import Test.QuickCheck + +import Test.Syd.Validity.Property.Utils + +-- | +-- +-- \[ +-- Antisymmetric(\prec, \doteq) +-- \quad\equiv\quad +-- \forall a, b: ((a \prec b) \wedge (b \prec a)) \Rightarrow (a \doteq b) +-- \] +antisymmetricOnElemsWithEquality :: + (a -> a -> Bool) -- ^ A relation + -> (a -> a -> Bool) -- ^ An equivalence relation + -> 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) + -> (a -> [a]) + -> Property +antisymmetryOnGensWithEquality func gen eq s = + forAllShrink gen (shrinkT2 s) $ + uncurry $ antisymmetricOnElemsWithEquality func eq + +antisymmetryOnGens :: + (Show a, Eq a) + => (a -> a -> Bool) + -> Gen (a, a) + -> (a -> [a]) + -> Property +antisymmetryOnGens func gen = antisymmetryOnGensWithEquality func gen (==) + +-- | +-- +-- prop> antisymmetryOnValid ((>) :: Double -> Double -> Bool) +-- prop> antisymmetryOnValid ((>=) :: Double -> Double -> Bool) +-- prop> antisymmetryOnValid ((<=) :: Double -> Double -> Bool) +-- prop> antisymmetryOnValid ((<) :: Double -> Double -> Bool) +-- prop> antisymmetryOnValid (Data.List.isPrefixOf :: [Double] -> [Double] -> Bool) +-- prop> antisymmetryOnValid (Data.List.isSuffixOf :: [Double] -> [Double] -> Bool) +-- prop> antisymmetryOnValid (Data.List.isInfixOf :: [Double] -> [Double] -> Bool) +antisymmetryOnValid :: + (Show a, Eq a, GenValid a) => (a -> a -> Bool) -> Property +antisymmetryOnValid func = antisymmetryOnGens func genValid shrinkValid + +-- | +-- +-- prop> antisymmetry ((>) :: Int -> Int -> Bool) +-- prop> antisymmetry ((>=) :: Int -> Int -> Bool) +-- prop> antisymmetry ((<=) :: Int -> Int -> Bool) +-- prop> antisymmetry ((<) :: Int -> Int -> Bool) +-- prop> antisymmetry (Data.List.isPrefixOf :: [Int] -> [Int] -> Bool) +-- prop> antisymmetry (Data.List.isSuffixOf :: [Int] -> [Int] -> Bool) +-- prop> antisymmetry (Data.List.isInfixOf :: [Int] -> [Int] -> Bool) +-- prop> antisymmetry ((\x y -> even x && odd y) :: Int -> Int -> Bool) +antisymmetry :: (Show a, Eq a, GenUnchecked a) => (a -> a -> Bool) -> Property +antisymmetry func = antisymmetryOnGens func genUnchecked shrinkUnchecked + +-- | +-- +-- prop> antisymmetryOnArbitrary ((>) :: Int -> Int -> Bool) +-- prop> antisymmetryOnArbitrary ((>=) :: Int -> Int -> Bool) +-- prop> antisymmetryOnArbitrary ((<=) :: Int -> Int -> Bool) +-- prop> antisymmetryOnArbitrary ((<) :: Int -> Int -> Bool) +-- prop> antisymmetryOnArbitrary (Data.List.isPrefixOf :: [Int] -> [Int] -> Bool) +-- prop> antisymmetryOnArbitrary (Data.List.isSuffixOf :: [Int] -> [Int] -> Bool) +-- prop> antisymmetryOnArbitrary (Data.List.isInfixOf :: [Int] -> [Int] -> Bool) +-- prop> antisymmetryOnArbitrary ((\x y -> even x && odd y) :: Int -> Int -> Bool) +antisymmetryOnArbitrary :: + (Show a, Eq a, Arbitrary a) => (a -> a -> Bool) -> Property +antisymmetryOnArbitrary func = antisymmetryOnGens func arbitrary shrink diff --git a/src/Test/Syd/Validity/Relations/Reflexivity.hs b/src/Test/Syd/Validity/Relations/Reflexivity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Relations/Reflexivity.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Syd.Validity.Relations.Reflexivity + ( reflexiveOnElem + , reflexivityOnGen + , reflexivityOnValid + , reflexivity + , reflexivityOnArbitrary + ) where + +import Data.GenValidity + +import Test.QuickCheck + +-- | +-- +-- \[ +-- Reflexive(\prec) +-- \quad\equiv\quad +-- \forall a: (a \prec a) +-- \] +reflexiveOnElem :: + (a -> a -> Bool) -- ^ A relation + -> a -- ^ An element + -> Bool +reflexiveOnElem func a = func a a + +reflexivityOnGen :: + Show a => (a -> a -> Bool) -> Gen a -> (a -> [a]) -> Property +reflexivityOnGen func gen s = forAllShrink gen s $ reflexiveOnElem func + +-- | +-- +-- prop> reflexivityOnValid ((<=) :: Rational -> Rational -> Bool) +-- prop> reflexivityOnValid ((==) :: Rational -> Rational -> Bool) +-- prop> reflexivityOnValid ((>=) :: Rational -> Rational -> Bool) +-- prop> reflexivityOnValid (Data.List.isPrefixOf :: [Rational] -> [Rational] -> Bool) +-- prop> reflexivityOnValid (Data.List.isSuffixOf :: [Rational] -> [Rational] -> Bool) +-- prop> reflexivityOnValid (Data.List.isInfixOf :: [Rational] -> [Rational] -> Bool) +reflexivityOnValid :: (Show a, GenValid a) => (a -> a -> Bool) -> Property +reflexivityOnValid func = reflexivityOnGen func genValid shrinkValid + +-- | +-- +-- prop> reflexivity ((<=) :: Int -> Int -> Bool) +-- prop> reflexivity ((==) :: Int -> Int -> Bool) +-- prop> reflexivity ((>=) :: Int -> Int -> Bool) +-- prop> reflexivity (Data.List.isPrefixOf :: [Int] -> [Int] -> Bool) +-- prop> reflexivity (Data.List.isSuffixOf :: [Int] -> [Int] -> Bool) +-- prop> reflexivity (Data.List.isInfixOf :: [Int] -> [Int] -> Bool) +reflexivity :: (Show a, GenUnchecked a) => (a -> a -> Bool) -> Property +reflexivity func = reflexivityOnGen func genUnchecked shrinkUnchecked + +-- | +-- +-- prop> reflexivityOnArbitrary ((<=) :: Int -> Int -> Bool) +-- prop> reflexivityOnArbitrary ((==) :: Int -> Int -> Bool) +-- prop> reflexivityOnArbitrary ((>=) :: Int -> Int -> Bool) +-- prop> reflexivityOnArbitrary (Data.List.isPrefixOf :: [Int] -> [Int] -> Bool) +-- prop> reflexivityOnArbitrary (Data.List.isSuffixOf :: [Int] -> [Int] -> Bool) +-- prop> reflexivityOnArbitrary (Data.List.isInfixOf :: [Int] -> [Int] -> Bool) +reflexivityOnArbitrary :: (Show a, Arbitrary a) => (a -> a -> Bool) -> Property +reflexivityOnArbitrary func = reflexivityOnGen func arbitrary shrink diff --git a/src/Test/Syd/Validity/Relations/Symmetry.hs b/src/Test/Syd/Validity/Relations/Symmetry.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Relations/Symmetry.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Syd.Validity.Relations.Symmetry + ( symmetricOnElems + , symmetryOnGens + , symmetryOnValid + , symmetry + , symmetryOnArbitrary + ) where + +import Data.GenValidity + +import Test.QuickCheck + +import Test.Syd.Validity.Property.Utils + +-- | +-- +-- \[ +-- Symmetric(\prec) +-- \quad\equiv\quad +-- \forall a, b: (a \prec b) \Leftrightarrow (b \prec a) +-- \] +symmetricOnElems :: + (a -> a -> Bool) -- ^ A relation + -> a + -> a -- ^ Two elements + -> Bool +symmetricOnElems func a b = func a b <==> func b a + +symmetryOnGens :: + Show a => (a -> a -> Bool) -> Gen (a, a) -> (a -> [a]) -> Property +symmetryOnGens func gen s = + forAllShrink gen (shrinkT2 s) $ uncurry $ symmetricOnElems func + +-- | +-- +-- prop> symmetryOnValid ((==) :: Double -> Double -> Bool) +-- prop> symmetryOnValid ((/=) :: Double -> Double -> Bool) +symmetryOnValid :: (Show a, GenValid a) => (a -> a -> Bool) -> Property +symmetryOnValid func = symmetryOnGens func genValid shrinkValid + +-- | +-- +-- prop> symmetry ((==) :: Int -> Int -> Bool) +-- prop> symmetry ((/=) :: Int -> Int -> Bool) +symmetry :: (Show a, GenUnchecked a) => (a -> a -> Bool) -> Property +symmetry func = symmetryOnGens func genUnchecked shrinkUnchecked + +-- | +-- +-- prop> symmetryOnArbitrary ((==) :: Int -> Int -> Bool) +-- prop> symmetryOnArbitrary ((/=) :: Int -> Int -> Bool) +symmetryOnArbitrary :: (Show a, Arbitrary a) => (a -> a -> Bool) -> Property +symmetryOnArbitrary func = symmetryOnGens func arbitrary shrink diff --git a/src/Test/Syd/Validity/Relations/Transitivity.hs b/src/Test/Syd/Validity/Relations/Transitivity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Relations/Transitivity.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Syd.Validity.Relations.Transitivity + ( transitiveOnElems + , transitivityOnGens + , transitivityOnValid + , transitivity + , transitivityOnArbitrary + ) where + +import Data.GenValidity + +import Test.QuickCheck + +import Test.Syd.Validity.Property.Utils + +-- | +-- +-- \[ +-- Transitive(\prec) +-- \quad\equiv\quad +-- \forall a, b, c: ((a \prec b) \wedge (b \prec c)) \Rightarrow (a \prec c) +-- \] +transitiveOnElems :: + (a -> a -> Bool) -- ^ A relation + -> 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) -> (a -> [a]) -> Property +transitivityOnGens func gen s = + forAllShrink gen (shrinkT3 s) $ \(a, b, c) -> transitiveOnElems func a b c + +-- | +-- +-- prop> transitivityOnValid ((>) :: Double -> Double -> Bool) +-- prop> transitivityOnValid ((>=) :: Double -> Double -> Bool) +-- prop> transitivityOnValid ((==) :: Double -> Double -> Bool) +-- prop> transitivityOnValid ((<=) :: Double -> Double -> Bool) +-- prop> transitivityOnValid ((<) :: Double -> Double -> Bool) +-- prop> transitivityOnValid (Data.List.isPrefixOf :: [Double] -> [Double] -> Bool) +-- prop> transitivityOnValid (Data.List.isSuffixOf :: [Double] -> [Double] -> Bool) +-- prop> transitivityOnValid (Data.List.isInfixOf :: [Double] -> [Double] -> Bool) +transitivityOnValid :: (Show a, GenValid a) => (a -> a -> Bool) -> Property +transitivityOnValid func = transitivityOnGens func genValid shrinkValid + +-- | +-- +-- prop> transitivity ((>) :: Int -> Int -> Bool) +-- prop> transitivity ((>=) :: Int -> Int -> Bool) +-- prop> transitivity ((==) :: Int -> Int -> Bool) +-- prop> transitivity ((<=) :: Int -> Int -> Bool) +-- prop> transitivity ((<) :: Int -> Int -> Bool) +-- prop> transitivity (Data.List.isPrefixOf :: [Int] -> [Int] -> Bool) +-- prop> transitivity (Data.List.isSuffixOf :: [Int] -> [Int] -> Bool) +-- prop> transitivity (Data.List.isInfixOf :: [Int] -> [Int] -> Bool) +transitivity :: (Show a, GenUnchecked a) => (a -> a -> Bool) -> Property +transitivity func = transitivityOnGens func genUnchecked shrinkUnchecked + +-- | +-- +-- prop> transitivityOnArbitrary ((>) :: Int -> Int -> Bool) +-- prop> transitivityOnArbitrary ((>=) :: Int -> Int -> Bool) +-- prop> transitivityOnArbitrary ((==) :: Int -> Int -> Bool) +-- prop> transitivityOnArbitrary ((<=) :: Int -> Int -> Bool) +-- prop> transitivityOnArbitrary ((<) :: Int -> Int -> Bool) +-- prop> transitivityOnArbitrary (Data.List.isPrefixOf :: [Int] -> [Int] -> Bool) +-- prop> transitivityOnArbitrary (Data.List.isSuffixOf :: [Int] -> [Int] -> Bool) +-- prop> transitivityOnArbitrary (Data.List.isInfixOf :: [Int] -> [Int] -> Bool) +transitivityOnArbitrary :: (Show a, Arbitrary a) => (a -> a -> Bool) -> Property +transitivityOnArbitrary func = transitivityOnGens func arbitrary shrink diff --git a/src/Test/Syd/Validity/RelativeValidity.hs b/src/Test/Syd/Validity/RelativeValidity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/RelativeValidity.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for RelativeValidity instances +-- +-- You will need @TypeApplications@ to use these. +module Test.Syd.Validity.RelativeValidity + ( relativeValiditySpec + , relativeValidityImpliesValidA + , relativeValidityImpliesValidB + ) where + +import Data.Data + +import Data.GenRelativeValidity +import Data.GenValidity + +import Test.Syd +import Test.QuickCheck + +import Test.Syd.Validity.Property.Utils +import Test.Syd.Validity.Utils + +-- | A @Spec@ that specifies that @isValidFor@ implies @isValid@ +-- +-- In general it is a good idea to add this spec to your test suite if +-- the @a@ and @b@ in @RelativeValidity a b@ also have a @Validity@ instance. +-- +-- Example usage: +-- +-- > relativeValiditySpec @MyDataFor @MyOtherData +relativeValiditySpec :: + 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 :: + forall a b. + ( Show a + , Show b + , Validity a + , GenUnchecked a + , GenUnchecked b + , RelativeValidity a b + ) + => Property +relativeValidityImpliesValidA = + forAllUnchecked $ \(a :: a) -> + forAllUnchecked $ \(b :: b) -> (a `isValidFor` b) ===> isValid a + +-- | @isValidFor a b@ implies @isValid b@ for all @a@ +relativeValidityImpliesValidB :: + forall a b. + ( Show a + , Show b + , Validity b + , GenUnchecked a + , GenUnchecked b + , RelativeValidity a b + ) + => Property +relativeValidityImpliesValidB = + forAllUnchecked $ \(a :: a) -> + forAllUnchecked $ \(b :: b) -> (a `isValidFor` b) ===> isValid b diff --git a/src/Test/Syd/Validity/Show.hs b/src/Test/Syd/Validity/Show.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Show.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | 'Show' and 'Read' properties +module Test.Syd.Validity.Show + ( showReadSpecOnValid + , showReadSpec + , showReadSpecOnArbitrary + , showReadSpecOnGen + , showReadRoundTripOnValid + , showReadRoundTrip + , showReadRoundTripOnArbitrary + , showReadRoundTripOnGen + ) where + +import Data.GenValidity + +import Data.Data + +import Text.Read + +import Test.Syd +import Test.QuickCheck + +import Test.Syd.Validity.Utils + +-- | Standard test spec for properties of Show and Read instances for valid values +-- +-- Example usage: +-- +-- > showReadSpecOnValid @Double +showReadSpecOnValid :: + forall a. (Show a, Eq a, Read a, Typeable a, GenValid a) + => Spec +showReadSpecOnValid = showReadSpecOnGen @a genValid "valid" shrinkValid + +-- | Standard test spec for properties of Show and Read instances for unchecked values +-- +-- Example usage: +-- +-- > showReadSpec @Int +showReadSpec :: + forall a. (Show a, Eq a, Read a, Typeable a, GenUnchecked a) + => Spec +showReadSpec = showReadSpecOnGen @a genUnchecked "unchecked" shrinkUnchecked + + +-- | Standard test spec for properties of Show and Read instances for arbitrary values +-- +-- Example usage: +-- +-- > showReadSpecOnArbitrary @Double +showReadSpecOnArbitrary :: + forall a. (Show a, Eq a, Read a, Typeable a, Arbitrary a) + => Spec +showReadSpecOnArbitrary = showReadSpecOnGen @a arbitrary "arbitrary" shrink + +-- | Standard test spec for properties of Show and Read instances for values generated by a custom generator +-- +-- Example usage: +-- +-- > showReadSpecOnGen ((* 2) <$> genValid @Int) "even" (const []) +showReadSpecOnGen :: + forall a. (Show a, Eq a, Read a, Typeable a) + => Gen a + -> String + -> (a -> [a]) + -> Spec +showReadSpecOnGen gen n s = + describe (unwords ["Show", nameOf @a, "and Read", nameOf @a]) $ + it (unwords ["are implemented such that read . show == id for", n, "values"]) $ + showReadRoundTripOnGen gen s + +-- | +-- +-- prop> showReadRoundTripOnValid @Rational +showReadRoundTripOnValid :: + forall a. (Show a, Eq a, Read a, GenValid a) + => Property +showReadRoundTripOnValid = + showReadRoundTripOnGen (genValid :: Gen a) shrinkValid + +-- | +-- +-- prop> showReadRoundTrip @Int +showReadRoundTrip :: + forall a. (Show a, Eq a, Read a, GenUnchecked a) + => Property +showReadRoundTrip = + showReadRoundTripOnGen (genUnchecked :: Gen a) shrinkUnchecked + +-- | +-- +-- prop> showReadRoundTripOnArbitrary @Double +showReadRoundTripOnArbitrary :: + forall a. (Show a, Eq a, Read a, Arbitrary a) + => Property +showReadRoundTripOnArbitrary = + showReadRoundTripOnGen (arbitrary :: Gen a) shrink + +-- | +-- +-- prop> showReadRoundTripOnGen (abs <$> genUnchecked :: Gen Int) (const []) +showReadRoundTripOnGen :: + (Show a, Eq a, Read a) => Gen a -> (a -> [a]) -> Property +showReadRoundTripOnGen gen s = + forAllShrink gen s $ \v -> readMaybe (show v) `shouldBe` Just v diff --git a/src/Test/Syd/Validity/Shrinking.hs b/src/Test/Syd/Validity/Shrinking.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Shrinking.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for Shrinking functions +-- +-- You will need @TypeApplications@ to use these. +module Test.Syd.Validity.Shrinking + ( shrinkValiditySpec + , shrinkValidSpec + , shrinkValidSpecWithLimit + , shrinkInvalidSpec + , shrinkValidPreservesValidOnGenValid + , shrinkValidPreservesValidOnGenValidWithLimit + , shrinkInvalidPreservesInvalidOnGenInvalid + , shrinkPreservesValidOnGenValid + , shrinkPreservesInvalidOnGenInvalid + , shrinkValidPreservesValid + , shrinkInvalidPreservesInvalid + , shrinkingStaysValid + , shrinkingStaysInvalid + , shrinkingPreserves + , shrinkUncheckedDoesNotShrinkToItself + , shrinkUncheckedDoesNotShrinkToItselfWithLimit + , shrinkValidDoesNotShrinkToItself + , shrinkValidDoesNotShrinkToItselfWithLimit + , shrinkInvalidDoesNotShrinkToItself + , shrinkInvalidDoesNotShrinkToItselfWithLimit + ) where + +import Data.Data + +import Data.GenValidity + +import Control.Monad + +import Test.Syd +import Test.QuickCheck + +import Test.Syd.Validity.Shrinking.Property +import Test.Syd.Validity.Utils + +shrinkValiditySpec :: + forall a. (Show a, Eq a, Typeable a, GenValid a, GenInvalid a) + => Spec +shrinkValiditySpec = do + shrinkValidSpec @a + shrinkInvalidSpec @a + +shrinkValidSpec :: + forall a. (Show a, Eq a, Typeable a, GenValid a) + => Spec +shrinkValidSpec = + describe ("shrinkValid :: " ++ nameOf @(a -> [a])) $ do + it "preserves validity" $ + forAll (genValid @a) $ \a -> forM_ (shrinkValid a) shouldBeValid + it "never shrinks to itself for valid values" $ + shrinkValidDoesNotShrinkToItself @a + +shrinkValidSpecWithLimit :: + forall a. (Show a, Eq a, Typeable a, GenValid a) + => Int + -> Spec +shrinkValidSpecWithLimit l = + describe ("shrinkValid :: " ++ nameOf @(a -> [a])) $ do + it (unwords ["preserves validity for the first", show l, "elements"]) $ + forAll (genValid @a) $ \a -> + forM_ (take l $ shrinkValid a) shouldBeValid + it + (unwords + [ "never shrinks to itself for valid values for the first" + , show l + , "elements" + ]) $ + shrinkValidDoesNotShrinkToItselfWithLimit @a l + +shrinkInvalidSpec :: + forall a. (Show a, Typeable a, GenInvalid a) + => Spec +shrinkInvalidSpec = + describe ("shrinkInvalid :: " ++ nameOf @(a -> [a])) $ do + it "preserves invalidity" $ + forAll (genInvalid @a) $ \a -> + forM_ (shrinkInvalid a) shouldBeInvalid + +shrinkValidPreservesValidOnGenValid :: + forall a. (Show a, GenValid a) + => Property +shrinkValidPreservesValidOnGenValid = + shrinkingStaysValid @a genValid shrinkValid + +shrinkValidPreservesValidOnGenValidWithLimit :: + forall a. (Show a, GenValid a) + => Int + -> Property +shrinkValidPreservesValidOnGenValidWithLimit = + shrinkingStaysValidWithLimit @a genValid shrinkValid + +shrinkInvalidPreservesInvalidOnGenInvalid :: + forall a. (Show a, GenInvalid a) + => Property +shrinkInvalidPreservesInvalidOnGenInvalid = + shrinkingStaysInvalid @a genInvalid shrinkInvalid + +shrinkUncheckedDoesNotShrinkToItself :: + forall a. (Show a, Eq a, GenUnchecked a) + => Property +shrinkUncheckedDoesNotShrinkToItself = + shrinkDoesNotShrinkToItself @a shrinkUnchecked + +shrinkValidDoesNotShrinkToItself :: + forall a. (Show a, Eq a, GenValid a) + => Property +shrinkValidDoesNotShrinkToItself = + shrinkDoesNotShrinkToItselfOnValid @a shrinkValid + +shrinkInvalidDoesNotShrinkToItself :: + forall a. (Show a, Eq a, GenInvalid a) + => Property +shrinkInvalidDoesNotShrinkToItself = + shrinkDoesNotShrinkToItselfOnInvalid @a shrinkInvalid + +shrinkInvalidDoesNotShrinkToItselfWithLimit :: + forall a. (Show a, Eq a, GenInvalid a) + => Int + -> Property +shrinkInvalidDoesNotShrinkToItselfWithLimit = + shrinkDoesNotShrinkToItselfOnInvalidWithLimit @a shrinkInvalid + +shrinkValidDoesNotShrinkToItselfWithLimit :: + forall a. (Show a, Eq a, GenValid a) + => Int + -> Property +shrinkValidDoesNotShrinkToItselfWithLimit = + shrinkDoesNotShrinkToItselfOnValidWithLimit @a shrinkValid + +shrinkUncheckedDoesNotShrinkToItselfWithLimit :: + forall a. (Show a, Eq a, GenUnchecked a) + => Int + -> Property +shrinkUncheckedDoesNotShrinkToItselfWithLimit = + shrinkDoesNotShrinkToItselfWithLimit @a shrinkUnchecked diff --git a/src/Test/Syd/Validity/Shrinking/Property.hs b/src/Test/Syd/Validity/Shrinking/Property.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Shrinking/Property.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for shrinking functions +module Test.Syd.Validity.Shrinking.Property + ( shrinkPreservesValidOnGenValid + , shrinkPreservesInvalidOnGenInvalid + , shrinkValidPreservesValid + , shrinkInvalidPreservesInvalid + , shrinkingStaysValid + , shrinkingStaysValidWithLimit + , shrinkingStaysInvalid + , shrinkingPreserves + , shrinkingPreservesWithLimit + , shrinkDoesNotShrinkToItself + , shrinkDoesNotShrinkToItselfWithLimit + , shrinkDoesNotShrinkToItselfOnValid + , shrinkDoesNotShrinkToItselfOnValidWithLimit + , shrinkDoesNotShrinkToItselfOnInvalid + , shrinkDoesNotShrinkToItselfOnInvalidWithLimit + , doesNotShrinkToItself + , doesNotShrinkToItselfWithLimit + ) where + +import Data.GenValidity + +import Test.QuickCheck + +-- | +-- +-- prop> shrinkPreservesValidOnGenValid ((:[]) :: Int -> [Int]) +shrinkPreservesValidOnGenValid :: + forall a. (Show a, GenValid a) + => (a -> [a]) + -> Property +shrinkPreservesValidOnGenValid = shrinkingStaysValid genValid + +-- | +-- +-- prop> shrinkPreservesInvalidOnGenInvalid ((:[]) :: Rational -> [Rational]) +shrinkPreservesInvalidOnGenInvalid :: + forall a. (Show a, GenInvalid a) + => (a -> [a]) + -> Property +shrinkPreservesInvalidOnGenInvalid = shrinkingStaysValid genInvalid + +-- | +-- +-- prop> shrinkValidPreservesValid (pure 5 :: Gen Rational) +shrinkValidPreservesValid :: + forall a. (Show a, GenValid a) + => Gen a + -> Property +shrinkValidPreservesValid gen = shrinkingStaysValid gen shrinkValid + +-- | +-- +shrinkInvalidPreservesInvalid :: + forall a. (Show a, GenInvalid a) + => Gen a + -> Property +shrinkInvalidPreservesInvalid gen = shrinkingStaysValid gen shrinkInvalid + +-- | +-- +-- prop> shrinkingStaysValid (pure 5 :: Gen Double) (\d -> [d - 1, d - 2]) +shrinkingStaysValid :: + forall a. (Show a, Validity a) + => Gen a + -> (a -> [a]) + -> Property +shrinkingStaysValid gen s = shrinkingPreserves gen s isValid + +-- | +-- +-- prop> shrinkingStaysValidWithLimit (pure 5 :: Gen Double) (\d -> [d - 1, read "NaN"]) 1 +shrinkingStaysValidWithLimit :: + forall a. (Show a, Validity a) + => Gen a + -> (a -> [a]) + -> Int + -> Property +shrinkingStaysValidWithLimit gen s l = + shrinkingPreservesWithLimit gen s l isValid + +-- | +-- +-- prop> shrinkingStaysInvalid (pure (1/0) :: Gen Double) (:[]) +shrinkingStaysInvalid :: + forall a. (Show a, Validity a) + => Gen a + -> (a -> [a]) + -> Property +shrinkingStaysInvalid gen s = shrinkingPreserves gen s isInvalid + +-- | +-- +-- prop> shrinkingPreserves (pure 5 :: Gen Int) (:[]) (== 5) +shrinkingPreserves :: + forall a. Show a + => Gen a + -> (a -> [a]) + -> (a -> Bool) + -> Property +shrinkingPreserves gen s p = forAll gen $ \d -> not (p d) || all p (s d) + +-- | +-- +-- prop> shrinkingPreservesWithLimit (pure 4) (:[]) 100 (== 4) +shrinkingPreservesWithLimit :: + forall a. Show a + => Gen a + -> (a -> [a]) + -> Int + -> (a -> Bool) + -> Property +shrinkingPreservesWithLimit gen s l p = + forAll gen $ \d -> not (p d) || all p (take l $ s d) + +-- | +-- +-- prop> shrinkDoesNotShrinkToItself (shrinkUnchecked :: Double -> [Double]) +shrinkDoesNotShrinkToItself :: + forall a. (Show a, Eq a, GenUnchecked a) + => (a -> [a]) + -> Property +shrinkDoesNotShrinkToItself = doesNotShrinkToItself genUnchecked + +-- | +-- +-- prop> shrinkDoesNotShrinkToItselfWithLimit (shrinkUnchecked :: Double -> [Double]) 100 +shrinkDoesNotShrinkToItselfWithLimit :: + forall a. (Show a, Eq a, GenUnchecked a) + => (a -> [a]) + -> Int + -> Property +shrinkDoesNotShrinkToItselfWithLimit = + doesNotShrinkToItselfWithLimit genUnchecked + +-- | +-- +-- prop> shrinkDoesNotShrinkToItselfOnValid (shrinkValid :: Rational -> [Rational]) +shrinkDoesNotShrinkToItselfOnValid :: + forall a. (Show a, Eq a, GenValid a) + => (a -> [a]) + -> Property +shrinkDoesNotShrinkToItselfOnValid = doesNotShrinkToItself genValid + +-- | +-- +-- prop> shrinkDoesNotShrinkToItselfOnValidWithLimit (shrinkValid :: Rational -> [Rational]) 100 +shrinkDoesNotShrinkToItselfOnValidWithLimit :: + forall a. (Show a, Eq a, GenValid a) + => (a -> [a]) + -> Int + -> Property +shrinkDoesNotShrinkToItselfOnValidWithLimit = + doesNotShrinkToItselfWithLimit genValid + +-- | +-- +-- prop> shrinkDoesNotShrinkToItselfOnInvalid (shrinkInvalid :: Rational -> [Rational]) +shrinkDoesNotShrinkToItselfOnInvalid :: + forall a. (Show a, Eq a, GenInvalid a) + => (a -> [a]) + -> Property +shrinkDoesNotShrinkToItselfOnInvalid = doesNotShrinkToItself genInvalid + +-- | +-- +-- prop> shrinkDoesNotShrinkToItselfOnInvalidWithLimit (shrinkInvalid :: Rational -> [Rational]) 100 +shrinkDoesNotShrinkToItselfOnInvalidWithLimit :: + forall a. (Show a, Eq a, GenInvalid a) + => (a -> [a]) + -> Int + -> Property +shrinkDoesNotShrinkToItselfOnInvalidWithLimit = + doesNotShrinkToItselfWithLimit genInvalid + +-- | +-- +-- prop> doesNotShrinkToItself (pure 5 :: Gen Double) shrinkUnchecked +doesNotShrinkToItself :: + forall a. (Show a, Eq a) + => Gen a + -> (a -> [a]) + -> Property +doesNotShrinkToItself gen s = forAll gen $ \a -> all (/= a) $ s a + +-- | +-- +-- prop> doesNotShrinkToItselfWithLimit (pure 5 :: Gen Double) shrinkUnchecked 100 +doesNotShrinkToItselfWithLimit :: + forall a. (Show a, Eq a) + => Gen a + -> (a -> [a]) + -> Int + -> Property +doesNotShrinkToItselfWithLimit gen s l = + forAll gen $ \a -> all (/= a) $ take l $ s a diff --git a/src/Test/Syd/Validity/Types.hs b/src/Test/Syd/Validity/Types.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Types.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Syd.Validity.Types + ( CanFail(..) + ) where + +-- | A class of types that are the result of functions that can fail +class CanFail f where + hasFailed :: f a -> Bool + resultIfSucceeded :: f a -> Maybe a + +instance CanFail Maybe where + hasFailed Nothing = True + hasFailed _ = False + resultIfSucceeded Nothing = Nothing + resultIfSucceeded (Just r) = Just r + +instance CanFail (Either e) where + hasFailed (Left _) = True + hasFailed _ = False + resultIfSucceeded (Left _) = Nothing + resultIfSucceeded (Right r) = Just r diff --git a/src/Test/Syd/Validity/Utils.hs b/src/Test/Syd/Validity/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Test/Syd/Validity/Utils.hs @@ -0,0 +1,57 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Utilities for defining your own validity 'Spec's +-- +-- You will need @TypeApplications@ to use these. +module Test.Syd.Validity.Utils + ( nameOf, + genDescr, + binRelStr, + shouldBeValid, + shouldBeInvalid, + Anon (..), + ) +where + +import Data.Data +import Test.Syd.Validity.Property.Utils + +nameOf :: + forall a. + Typeable a => + String +nameOf = + let s = show $ typeRep (Proxy @a) + in if ' ' `elem` s + then "(" ++ s ++ ")" + else s + +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 + +newtype 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/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF sydtest-discover #-} diff --git a/test/Test/Syd/Validity/ApplicativeSpec.hs b/test/Test/Syd/Validity/ApplicativeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Validity/ApplicativeSpec.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Syd.Validity.ApplicativeSpec where + +import Test.Syd + +import Data.GenValidity +import Test.Syd.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/Syd/Validity/ArbitrarySpec.hs b/test/Test/Syd/Validity/ArbitrarySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Validity/ArbitrarySpec.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Syd.Validity.ArbitrarySpec where + +import Test.Syd + +import Test.Syd.Validity.Arbitrary + +spec :: Spec +spec = arbitrarySpec @Int diff --git a/test/Test/Syd/Validity/EqSpec.hs b/test/Test/Syd/Validity/EqSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Validity/EqSpec.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TypeApplications #-} + +-- | Standard 'Spec's for 'Eq' instances. +-- +-- You will need @TypeApplications@ to use these. +module Test.Syd.Validity.EqSpec where + +import Data.GenValidity +import Test.Syd +import Test.Syd.Validity.Eq + +spec :: Spec +spec = do + eqSpecOnValid @Rational + eqSpec @Int + -- eqSpec @Double DOES NOT HOLD because of NaN + eqSpecOnArbitrary @Int + eqSpecOnGen ((* 2) <$> genValid @Int) "even" (const []) diff --git a/test/Test/Syd/Validity/FunctorSpec.hs b/test/Test/Syd/Validity/FunctorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Validity/FunctorSpec.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Syd.Validity.FunctorSpec where + +import Data.GenValidity +import Test.Syd +import Test.Syd.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/Syd/Validity/GenRelativeValiditySpec.hs b/test/Test/Syd/Validity/GenRelativeValiditySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Validity/GenRelativeValiditySpec.hs @@ -0,0 +1,7 @@ +module Test.Syd.Validity.GenRelativeValiditySpec where + +import Test.Syd + +-- import Test.Syd.Validity.GenRelativeValidity +spec :: Spec +spec = pure () -- TODO add examples once we have some instances diff --git a/test/Test/Syd/Validity/GenValiditySpec.hs b/test/Test/Syd/Validity/GenValiditySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Validity/GenValiditySpec.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Syd.Validity.GenValiditySpec where + +import Test.Syd + +import Test.Syd.Validity.GenValidity + +spec :: Spec +spec = do + genValiditySpec @Rational + genValidSpec @Rational + genInvalidSpec @Rational diff --git a/test/Test/Syd/Validity/MonadSpec.hs b/test/Test/Syd/Validity/MonadSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Validity/MonadSpec.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Syd.Validity.MonadSpec where + +import Test.Syd + +import Data.GenValidity +import Test.Syd.Validity.Monad + +{-# ANN module "HLint: ignore Use :" #-} + +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/Syd/Validity/MonoidSpec.hs b/test/Test/Syd/Validity/MonoidSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Validity/MonoidSpec.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Syd.Validity.MonoidSpec where + +import Test.Syd + +import Test.Syd.Validity.Monoid + +spec :: Spec +spec = do + monoidSpecOnValid @[Rational] + monoidSpec @[Int] + monoidSpecOnArbitrary @[Int] + monoidSpecOnGen (pure "a") "singleton list of 'a'" (const []) diff --git a/test/Test/Syd/Validity/Operations/CommutativitySpec.hs b/test/Test/Syd/Validity/Operations/CommutativitySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Validity/Operations/CommutativitySpec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Syd.Validity.Operations.CommutativitySpec + ( spec + ) where + +import Test.Syd +import Test.QuickCheck +import Data.GenValidity (GenUnchecked) + +import Test.Syd.Validity.Operations.Commutativity (commutative) + +spec :: Spec +spec = do + describe "commutative" $ do + specify "+ is commutative" $ commutative @Int (+) + specify "* is commutative" $ commutative @Int (*) + specify "dot product is commutative" $ commutative dotProduct + + specify "- is not commutative" $ notCommmutative @Int (-) + specify "cross product is not commutative" $ notCommmutative crossProduct + +notCommmutative :: (Show a, Show b, Eq b, GenUnchecked a) => (a -> a -> b) -> Property +notCommmutative op = expectFailure (commutative op) + +type Point = (Int, Int) + +dotProduct :: Point -> Point -> Int +dotProduct (x1, y1) (x2, y2) = x1 * x2 + y1 * y2 + +crossProduct :: Point -> Point -> Int +crossProduct (x1, y1) (x2, y2) = x1 * y2 - x2 * y1 diff --git a/test/Test/Syd/Validity/OrdSpec.hs b/test/Test/Syd/Validity/OrdSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Validity/OrdSpec.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Syd.Validity.OrdSpec where + +import Data.GenValidity +import Test.Syd +import Test.Syd.Validity.Ord + +spec :: Spec +spec = do + ordSpecOnValid @Rational + ordSpec @Int + ordSpecOnArbitrary @Int + ordSpecOnGen ((* 2) <$> genValid @Int) "even" (const []) diff --git a/test/Test/Syd/Validity/RelativeValiditySpec.hs b/test/Test/Syd/Validity/RelativeValiditySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Validity/RelativeValiditySpec.hs @@ -0,0 +1,7 @@ +module Test.Syd.Validity.RelativeValiditySpec where + +import Test.Syd + +-- import Test.Syd.Validity.RelativeValidity +spec :: Spec +spec = pure () diff --git a/test/Test/Syd/Validity/ShowSpec.hs b/test/Test/Syd/Validity/ShowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Validity/ShowSpec.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeApplications #-} + +-- | Standard 'Spec's for 'Show' and 'Read' instances. +-- +-- You will need @TypeApplications@ to use these. +module Test.Syd.Validity.ShowSpec where + +import Data.GenValidity +import Test.Syd +import Test.Syd.Validity.Show + +spec :: Spec +spec = do + showReadSpecOnValid @Rational + showReadSpec @Int + showReadSpecOnArbitrary @Rational + showReadSpecOnGen ((* 2) <$> genValid @Int) "even" (const []) diff --git a/test/Test/Syd/Validity/ShrinkingSpec.hs b/test/Test/Syd/Validity/ShrinkingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Syd/Validity/ShrinkingSpec.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Syd.Validity.ShrinkingSpec where + +import Data.Int +import Data.Ratio +import Test.Syd +import Test.Syd.Validity.Shrinking + +spec :: Spec +spec = do + shrinkValiditySpec @(Ratio Int8) + shrinkValidSpec @Int + shrinkInvalidSpec @(Ratio Int8) + describe "shrinkUncheckedPreservesValidOnGenValid" $ do + it "Ordering" $ shrinkValidPreservesValidOnGenValid @Ordering + it "[Ordering]" $ shrinkValidPreservesValidOnGenValid @[Ordering] + describe "shrinkValidPreservesValidOnGenValid" $ do + it "Ordering" $ shrinkValidPreservesValidOnGenValid @Ordering + it "[Ordering]" $ shrinkValidPreservesValidOnGenValid @[Ordering] + describe "shrinkInvalidPreservesInvalidOnGenInvalid" $ do + it "Ratio Int8" $ shrinkInvalidPreservesInvalidOnGenInvalid @(Ratio Int8) + describe "shrinkUncheckedDoesNotShrinkToItself" $ do + it "Int" $ shrinkUncheckedDoesNotShrinkToItself @Int + it "[Int]" $ shrinkUncheckedDoesNotShrinkToItself @[Int] + describe "shrinkValidDoesNotShrinkToItself" $ do + it "Ordering" $ shrinkValidDoesNotShrinkToItself @Ordering + it "[Ordering]" $ shrinkValidDoesNotShrinkToItself @[Ordering]