diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# Changelog + +## [1.0.0.0] - 2021-11-20 + +* Compatibility with `genvalidity >= 1.0.0.0` +* Renamed every combinator that ends in `OnValid` (or similar) to not have that suffix anymore. + +### Removed + +* Every combinator that relates to unchecked or invalid values. + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ The MIT License (MIT) -Copyright (c) 2016-2020 Tom Sydney Kerckhove +Copyright (c) 2016-2021 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 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple - -main = defaultMain diff --git a/genvalidity-sydtest.cabal b/genvalidity-sydtest.cabal --- a/genvalidity-sydtest.cabal +++ b/genvalidity-sydtest.cabal @@ -5,17 +5,20 @@ -- see: https://github.com/sol/hpack name: genvalidity-sydtest -version: 0.0.0.0 +version: 1.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 +copyright: Copyright: (c) 2016-2021 Tom Sydney Kerckhove license: MIT license-file: LICENSE build-type: Simple +extra-source-files: + LICENSE + CHANGELOG.md source-repository head type: git @@ -34,7 +37,6 @@ 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 @@ -52,7 +54,6 @@ 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 @@ -66,7 +67,7 @@ build-depends: QuickCheck , base >=4.7 && <5 - , genvalidity >=0.7 + , genvalidity >=1.0 , pretty-show , sydtest , validity >=0.9 diff --git a/src/Test/Syd/Validity.hs b/src/Test/Syd/Validity.hs --- a/src/Test/Syd/Validity.hs +++ b/src/Test/Syd/Validity.hs @@ -7,283 +7,262 @@ -- The most interesting functions in this module for most uses are: -- -- * 'genValidSpec' --- * 'eqSpecOnValid' --- * 'ordSpecOnValid' --- * 'producesValidsOnValids' +-- * 'eqSpec' +-- * 'ordSpec' +-- * 'producesValid' -- * '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 + ( -- * Writing properties -import Data.GenValidity + -- ** Cheap generation with shrinking + forAllValid, + -- ** Cheap assertions + shouldBeValid, + shouldBeInvalid, + + -- * Tests for GenValidity instances + genValidSpec, + genValidGeneratesValid, + genGeneratesValid, + shrinkValidSpec, + shrinkValidSpecWithLimit, + shrinkValidPreservesValidOnGenValid, + shrinkPreservesValidOnGenValid, + shrinkValidPreservesValid, + shrinkingStaysValid, + shrinkingPreserves, + + -- * Tests for Arbitrary instances involving Validity + arbitrarySpec, + arbitraryGeneratesOnlyValid, + + -- * Standard tests involving functions + + -- ** Standard tests involving validity + producesValidsOnGen, + producesValid, + producesValidsOnArbitrary, + producesValidsOnGens2, + producesValid2, + producesValidsOnArbitrary2, + producesValidsOnGens3, + producesValid3, + producesValidsOnArbitrary3, + + -- ** Standard tests involving functions that can fail + CanFail (..), + succeedsOnGen, + succeeds, + succeedsOnArbitrary, + succeedsOnGens2, + succeeds2, + succeedsOnArbitrary2, + failsOnGen, + failsOnGens2, + validIfSucceedsOnGen, + validIfSucceedsOnArbitrary, + validIfSucceeds, + validIfSucceedsOnGens2, + validIfSucceeds2, + validIfSucceedsOnArbitrary2, + validIfSucceedsOnGens3, + validIfSucceeds3, + validIfSucceedsOnArbitrary3, + + -- ** Standard tests involving equivalence of functions + + -- *** Simple functions + + -- **** One argument + equivalentOnGen, + equivalent, + equivalentOnArbitrary, + + -- **** Two arguments + equivalentOnGens2, + equivalent2, + equivalentOnArbitrary2, + + -- **** Three arguments + equivalentOnGens3, + equivalent3, + equivalentOnArbitrary3, + + -- *** First function can fail + + -- **** One argument + equivalentWhenFirstSucceedsOnGen, + equivalentWhenFirstSucceeds, + equivalentWhenFirstSucceedsOnArbitrary, + + -- **** Two arguments + equivalentWhenFirstSucceedsOnGens2, + equivalentWhenFirstSucceeds2, + equivalentWhenFirstSucceedsOnArbitrary2, + + -- *** Second function can fail + + -- **** One argument + equivalentWhenSecondSucceedsOnGen, + equivalentWhenSecondSucceeds, + equivalentWhenSecondSucceedsOnArbitrary, + + -- **** Two arguments + equivalentWhenSecondSucceedsOnGens2, + equivalentWhenSecondSucceeds2, + equivalentWhenSecondSucceedsOnArbitrary2, + + -- *** Both functions can fail + + -- **** One argument + equivalentWhenSucceedOnGen, + equivalentWhenSucceed, + equivalentWhenSucceedOnArbitrary, + + -- **** Two arguments + equivalentWhenSucceedOnGens2, + equivalentWhenSucceed2, + equivalentWhenSucceedOnArbitrary2, + + -- ** Standard tests involving inverse functions + inverseFunctionsOnGen, + inverseFunctions, + inverseFunctionsOnArbitrary, + inverseFunctionsIfFirstSucceedsOnGen, + inverseFunctionsIfFirstSucceeds, + inverseFunctionsIfFirstSucceedsOnArbitrary, + inverseFunctionsIfSecondSucceedsOnGen, + inverseFunctionsIfSecondSucceeds, + inverseFunctionsIfSecondSucceedsOnArbitrary, + inverseFunctionsIfSucceedOnGen, + inverseFunctionsIfSucceed, + inverseFunctionsIfSucceedOnArbitrary, + + -- ** Properties involving idempotence + idempotentOnGen, + idempotent, + idempotentOnArbitrary, + + -- * Properties of relations + + -- ** Reflexivity + reflexiveOnElem, + reflexivityOnGen, + reflexivity, + reflexivityOnArbitrary, + + -- ** Transitivity + transitiveOnElems, + transitivityOnGens, + transitivity, + transitivityOnArbitrary, + + -- ** Antisymmetry + antisymmetricOnElemsWithEquality, + antisymmetryOnGensWithEquality, + antisymmetryOnGens, + antisymmetry, + antisymmetryOnArbitrary, + + -- ** Antireflexivity + antireflexiveOnElem, + antireflexivityOnGen, + antireflexivity, + antireflexivityOnArbitrary, + + -- ** Symmetry + symmetricOnElems, + symmetryOnGens, + symmetry, + symmetryOnArbitrary, + + -- * Properties of operations + + -- ** Identity element + + -- *** Left Identity + leftIdentityOnElemWithEquality, + leftIdentityOnGenWithEquality, + leftIdentityOnGen, + leftIdentity, + leftIdentityOnArbitrary, + + -- *** Right Identity + rightIdentityOnElemWithEquality, + rightIdentityOnGenWithEquality, + rightIdentityOnGen, + rightIdentity, + rightIdentityOnArbitrary, + + -- *** Identity + identityOnGen, + identity, + identityOnArbitrary, + + -- ** Associativity + associativeOnGens, + associative, + associativeOnArbitrary, + + -- ** Commutativity + commutativeOnGens, + commutative, + commutativeOnArbitrary, + + -- * Show and Read properties + showReadSpec, + showReadSpecOnArbitrary, + showReadSpecOnGen, + + -- * Eq properties + eqSpec, + eqSpecOnArbitrary, + eqSpecOnGen, + + -- * Ord properties + ordSpecOnGen, + ordSpec, + ordSpecOnArbitrary, + + -- * Monoid properties + monoidSpec, + monoidSpecOnArbitrary, + monoidSpecOnGen, + + -- * Functor properties + functorSpec, + functorSpecOnArbitrary, + functorSpecOnGens, + + -- * Applicative properties + applicativeSpec, + applicativeSpecOnArbitrary, + applicativeSpecOnGens, + + -- * Monad properties + 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 --- a/src/Test/Syd/Validity/Applicative.hs +++ b/src/Test/Syd/Validity/Applicative.hs @@ -1,116 +1,106 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} -- | Applicative properties -- -- You will need @TypeApplications@ to use these. module Test.Syd.Validity.Applicative - ( applicativeSpecOnValid - , applicativeSpec - , applicativeSpecOnArbitrary - , applicativeSpecOnGens - ) where + ( applicativeSpec, + applicativeSpecOnArbitrary, + applicativeSpecOnGens, + ) +where import Data.Data - import Data.GenValidity import Data.Kind - -import Test.Syd import Test.QuickCheck - +import Test.Syd import Test.Syd.Validity.Functions import Test.Syd.Validity.Utils {-# ANN module "HLint: ignore Avoid lambda" #-} pureTypeStr :: - forall (f :: Type -> Type). (Typeable f) - => String + forall (f :: Type -> Type). + (Typeable f) => + String pureTypeStr = unwords ["pure", "::", "a", "->", nameOf @f, "a"] seqTypeStr :: - forall (f :: Type -> Type). (Typeable f) - => String + forall (f :: Type -> Type). + (Typeable f) => + String seqTypeStr = - unwords - [ "(<*>)" - , "::" - , nameOf @f - , "(a" - , "->" - , "b)" - , "->" - , nameOf @f - , "a" - , "->" - , nameOf @f - , "b" - ] + unwords + [ "(<*>)", + "::", + nameOf @f, + "(a", + "->", + "b)", + "->", + nameOf @f, + "a", + "->", + nameOf @f, + "b" + ] seqrTypeStr :: - forall (f :: Type -> Type). (Typeable f) - => String + forall (f :: Type -> Type). + (Typeable f) => + String seqrTypeStr = - unwords - [ "(*>)" - , "::" - , nameOf @f - , "a" - , "->" - , nameOf @f - , "b" - , "->" - , nameOf @f - , "b" - ] + unwords + [ "(*>)", + "::", + nameOf @f, + "a", + "->", + nameOf @f, + "b", + "->", + nameOf @f, + "b" + ] seqlTypeStr :: - forall (f :: Type -> Type). (Typeable f) - => String + forall (f :: Type -> Type). + (Typeable f) => + String seqlTypeStr = - unwords - [ "(<*)" - , "::" - , nameOf @f - , "a" - , "->" - , nameOf @f - , "b" - , "->" - , nameOf @f - , "a" - ] + 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 + forall (f :: Type -> Type). + ( Eq (f Int), + Show (f Int), + Applicative f, + Typeable f, + GenValid (f Int) + ) => + Spec +applicativeSpec = applicativeSpecWithInts @f genValid -- | Standard test spec for properties of Applicative instances for values generated with Arbitrary instances -- @@ -118,32 +108,32 @@ -- -- > applicativeSpecOnArbitrary @[] applicativeSpecOnArbitrary :: - forall (f :: Type -> Type). - (Eq (f Int), Show (f Int), Applicative f, Typeable f, Arbitrary (f Int)) - => Spec + 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 + 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"]) + applicativeSpecOnGens + @f + @Int + genValid + "int" + gen + (unwords [nameOf @f, "of ints"]) + gen + (unwords [nameOf @f, "of ints"]) + ((+) <$> genValid) + "increments" + (pure <$> ((+) <$> genValid)) + (unwords [nameOf @f, "of increments"]) + (pure <$> ((*) <$> genValid)) + (unwords [nameOf @f, "of scalings"]) -- | Standard test spec for properties of Applicative instances for values generated by given generators (and names for those generator). -- @@ -167,118 +157,127 @@ -- > (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 + 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 $ + 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 + 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 --- a/src/Test/Syd/Validity/Arbitrary.hs +++ b/src/Test/Syd/Validity/Arbitrary.hs @@ -1,23 +1,21 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# 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 + ( arbitrarySpec, + arbitraryGeneratesOnlyValid, + ) +where import Data.Data - import Data.GenValidity - -import Test.Syd import Test.QuickCheck - +import Test.Syd import Test.Syd.Validity.GenValidity import Test.Syd.Validity.Utils @@ -28,18 +26,20 @@ -- -- > arbitrarySpec @Int arbitrarySpec :: - forall a. (Typeable a, Show a, Validity a, Arbitrary a) - => Spec + 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 + 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 + 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 --- a/src/Test/Syd/Validity/Eq.hs +++ b/src/Test/Syd/Validity/Eq.hs @@ -1,69 +1,48 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} -- | Eq properties -- -- You will need @TypeApplications@ to use these. module Test.Syd.Validity.Eq - ( eqSpecOnValid - , eqSpecOnInvalid - , eqSpec - , eqSpecOnArbitrary - , eqSpecOnGen - ) where + ( eqSpec, + eqSpecOnArbitrary, + eqSpecOnGen, + ) +where import Data.Data - import Data.GenValidity - -import Test.Syd import Test.QuickCheck - +import Test.Syd import Test.Syd.Validity.Functions import Test.Syd.Validity.Relations import Test.Syd.Validity.Utils eqTypeStr :: - forall a. Typeable a - => String + forall a. + Typeable a => + String eqTypeStr = binRelStr @a "==" neqTypeStr :: - forall a. Typeable a - => String + 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 + forall a. + (Show a, Eq a, Typeable a, GenValid a) => + Spec +eqSpec = eqSpecOnGen @a genValid "valid" shrinkValid -- | Standard test spec for properties of Eq instances for arbitrary values -- @@ -71,8 +50,9 @@ -- -- > eqSpecOnArbitrary @Int eqSpecOnArbitrary :: - forall a. (Show a, Eq a, Typeable a, Arbitrary a) - => Spec + 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). @@ -81,63 +61,70 @@ -- -- > eqSpecOnGen ((* 2) <$> genValid @Int) "even" eqSpecOnGen :: - forall a. (Show a, Eq a, Typeable a) - => Gen a - -> String - -> (a -> [a]) - -> Spec + 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 + 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 --- a/src/Test/Syd/Validity/Functions.hs +++ b/src/Test/Syd/Validity/Functions.hs @@ -3,99 +3,13 @@ -- | 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 + ( module Test.Syd.Validity.Functions.CanFail, + module Test.Syd.Validity.Functions.Equivalence, + module Test.Syd.Validity.Functions.Idempotence, + module Test.Syd.Validity.Functions.Inverse, + module Test.Syd.Validity.Functions.Validity, + ) +where import Test.Syd.Validity.Functions.CanFail import Test.Syd.Validity.Functions.Equivalence diff --git a/src/Test/Syd/Validity/Functions/CanFail.hs b/src/Test/Syd/Validity/Functions/CanFail.hs --- a/src/Test/Syd/Validity/Functions/CanFail.hs +++ b/src/Test/Syd/Validity/Functions/CanFail.hs @@ -3,35 +3,28 @@ 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 import Test.Syd.Validity.Property.Utils import Test.Syd.Validity.Types @@ -41,12 +34,8 @@ 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 +succeeds :: (Show a, Show (f b), GenValid a, CanFail f) => (a -> f b) -> Property +succeeds f = succeedsOnGen f genValid shrinkValid -- | The function succeeds if the input is generated by @arbitrary@ succeedsOnArbitrary :: @@ -58,10 +47,6 @@ (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 :: @@ -74,20 +59,14 @@ -- | 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 +-- that is generated by @genValid@. +validIfSucceeds :: (Show a, Show b, GenValid a, Validity b, CanFail f) => (a -> f b) -> Property +validIfSucceeds f = validIfSucceedsOnGen f genValid shrinkValid succeedsOnGens2 :: (Show a, Show b, Show (f c), CanFail f) => @@ -98,17 +77,11 @@ 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) => + (Show a, Show b, Show (f c), GenValid a, GenValid b, CanFail f) => (a -> b -> f c) -> Property -succeeds2 func = succeedsOnGens2 func genUnchecked shrinkUnchecked +succeeds2 func = succeedsOnGens2 func genValid shrinkValid succeedsOnArbitrary2 :: (Show a, Show b, Show (f c), Arbitrary a, Arbitrary b, CanFail f) => @@ -127,22 +100,6 @@ 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) -> @@ -155,17 +112,11 @@ 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) => + (Show a, Show b, Show c, GenValid a, GenValid b, Validity c, CanFail f) => (a -> b -> f c) -> Property -validIfSucceeds2 func = validIfSucceedsOnGens2 func genUnchecked shrinkUnchecked +validIfSucceeds2 func = validIfSucceedsOnGens2 func genValid shrinkValid validIfSucceedsOnArbitrary2 :: (Show a, Show b, Show c, Arbitrary a, Arbitrary b, Validity c, CanFail f) => @@ -185,26 +136,20 @@ 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, + GenValid a, + GenValid b, + GenValid c, Validity d, CanFail f ) => (a -> b -> c -> f d) -> Property -validIfSucceeds3 func = validIfSucceedsOnGens3 func genUnchecked shrinkUnchecked +validIfSucceeds3 func = validIfSucceedsOnGens3 func genValid shrinkValid validIfSucceedsOnArbitrary3 :: (Show a, Show b, Show c, Show d, Arbitrary a, Arbitrary b, Arbitrary c, Validity d, CanFail f) => diff --git a/src/Test/Syd/Validity/Functions/Equivalence.hs b/src/Test/Syd/Validity/Functions/Equivalence.hs --- a/src/Test/Syd/Validity/Functions/Equivalence.hs +++ b/src/Test/Syd/Validity/Functions/Equivalence.hs @@ -2,458 +2,352 @@ {-# 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 + ( equivalentOnGen, + equivalent, + equivalentOnArbitrary, + equivalentOnGens2, + equivalent2, + equivalentOnArbitrary2, + equivalentWhenFirstSucceedsOnGen, + equivalentWhenFirstSucceeds, + equivalentWhenFirstSucceedsOnArbitrary, + equivalentWhenFirstSucceedsOnGens2, + equivalentWhenFirstSucceeds2, + equivalentWhenFirstSucceedsOnArbitrary2, + equivalentWhenSecondSucceedsOnGen, + equivalentWhenSecondSucceeds, + equivalentWhenSecondSucceedsOnArbitrary, + equivalentWhenSecondSucceedsOnGens2, + equivalentWhenSecondSucceeds2, + equivalentWhenSecondSucceedsOnArbitrary2, + equivalentWhenSucceedOnGen, + equivalentWhenSucceed, + equivalentWhenSucceedOnArbitrary, + equivalentWhenSucceedOnGens2, + equivalentWhenSucceed2, + equivalentWhenSucceedOnArbitrary2, + equivalentOnGens3, + equivalent3, + equivalentOnArbitrary3, + ) +where import Data.GenValidity - -import Test.Syd import Test.QuickCheck - +import Test.Syd import Test.Syd.Validity.Types equivalentOnGen :: - (Show a, Show b, Eq b) - => (a -> b) - -> (a -> b) - -> Gen a - -> (a -> [a]) - -> Property + (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 + (Show a, GenValid a, Show b, Eq b) => + (a -> b) -> + (a -> b) -> + Property +equivalent f g = equivalentOnGen f g genValid shrinkValid -- | -- -- prop> equivalentOnArbitrary ((* 2) . (+ 1)) ((+ 2) . (* 2) :: Int -> Int) equivalentOnArbitrary :: - (Show a, Arbitrary a, Show b, Eq b) - => (a -> b) - -> (a -> b) - -> Property + (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 + (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 + forAllShrink gen s $ \(a, b) -> f a b `shouldBe` g a b 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 + (Show a, GenValid a, Show b, GenValid b, Show c, Eq c) => + (a -> b -> c) -> + (a -> b -> c) -> + Property +equivalent2 f g = equivalentOnGens2 f g genValid shrinkValid -- | -- -- 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 + (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 + (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 + forAllShrink gen s $ \a -> + case resultIfSucceeded (f a) of + Nothing -> return () -- fine + Just r -> r `shouldBe` g a equivalentWhenFirstSucceedsOnArbitrary :: - (Show a, Arbitrary a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> b) - -> Property + (Show a, Arbitrary a, Show b, Eq b, CanFail f) => + (a -> f b) -> + (a -> b) -> + Property equivalentWhenFirstSucceedsOnArbitrary f g = - equivalentWhenFirstSucceedsOnGen f g arbitrary shrink + equivalentWhenFirstSucceedsOnGen f g arbitrary shrink equivalentWhenFirstSucceeds :: - (Show a, GenUnchecked a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> b) - -> Property + (Show a, GenValid a, Show b, Eq b, CanFail f) => + (a -> f b) -> + (a -> b) -> + Property equivalentWhenFirstSucceeds f g = - equivalentWhenFirstSucceedsOnGen f g genUnchecked shrinkUnchecked + equivalentWhenFirstSucceedsOnGen f g genValid shrinkValid 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 + (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 + forAllShrink gen s $ \(a, b) -> + case resultIfSucceeded (f a b) of + Nothing -> return () -- fine + Just rs -> rs `shouldBe` g a b equivalentWhenFirstSucceedsOnArbitrary2 :: - ( Show a - , Arbitrary a - , Show b - , Arbitrary b - , Show c - , Eq c - , CanFail f - ) - => (a -> b -> f c) - -> (a -> b -> c) - -> Property + ( 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 + 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 + ( Show a, + GenValid a, + Show b, + GenValid b, + Show c, + Eq c, + CanFail f + ) => + (a -> b -> f c) -> + (a -> b -> c) -> + Property equivalentWhenFirstSucceeds2 f g = - equivalentWhenFirstSucceedsOnGens2 f g genUnchecked shrinkUnchecked + equivalentWhenFirstSucceedsOnGens2 f g genValid shrinkValid equivalentWhenSecondSucceedsOnGen :: - (Show a, Show b, Eq b, CanFail f) - => (a -> b) - -> (a -> f b) - -> Gen a - -> (a -> [a]) - -> Property + (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 + forAllShrink gen s $ \a -> + case resultIfSucceeded (g a) of + Nothing -> return () -- fine + Just r -> r `shouldBe` f a equivalentWhenSecondSucceedsOnArbitrary :: - (Show a, Arbitrary a, Show b, Eq b, CanFail f) - => (a -> b) - -> (a -> f b) - -> Property + (Show a, Arbitrary a, Show b, Eq b, CanFail f) => + (a -> b) -> + (a -> f b) -> + Property equivalentWhenSecondSucceedsOnArbitrary f g = - equivalentWhenSecondSucceedsOnGen f g arbitrary shrink + equivalentWhenSecondSucceedsOnGen f g arbitrary shrink equivalentWhenSecondSucceeds :: - (Show a, GenUnchecked a, Show b, Eq b, CanFail f) - => (a -> b) - -> (a -> f b) - -> Property + (Show a, GenValid a, Show b, Eq b, CanFail f) => + (a -> b) -> + (a -> f b) -> + Property equivalentWhenSecondSucceeds f g = - equivalentWhenSecondSucceedsOnGen f g genUnchecked shrinkUnchecked + equivalentWhenSecondSucceedsOnGen f g genValid shrinkValid 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 + (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 + forAllShrink gen s $ \(a, b) -> + case resultIfSucceeded (g a b) of + Nothing -> return () -- fine + Just rs -> rs `shouldBe` f a b equivalentWhenSecondSucceedsOnArbitrary2 :: - ( Show a - , Arbitrary a - , Show b - , Arbitrary b - , Show c - , Eq c - , CanFail f - ) - => (a -> b -> c) - -> (a -> b -> f c) - -> Property + ( 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 + 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 + ( Show a, + GenValid a, + Show b, + GenValid b, + Show c, + Eq c, + CanFail f + ) => + (a -> b -> c) -> + (a -> b -> f c) -> + Property equivalentWhenSecondSucceeds2 f g = - equivalentWhenSecondSucceedsOnGens2 f g genUnchecked shrinkUnchecked + equivalentWhenSecondSucceedsOnGens2 f g genValid shrinkValid equivalentWhenSucceedOnGen :: - (Show a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> f b) - -> Gen a - -> (a -> [a]) - -> Property + (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 + 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 equivalentWhenSucceed :: - (Show a, GenUnchecked a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> f b) - -> Property + (Show a, GenValid a, Show b, Eq b, CanFail f) => + (a -> f b) -> + (a -> f b) -> + Property equivalentWhenSucceed f g = - equivalentWhenSucceedOnGen f g genUnchecked shrinkUnchecked + equivalentWhenSucceedOnGen f g genValid shrinkValid equivalentWhenSucceedOnArbitrary :: - (Show a, Arbitrary a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> f b) - -> Property + (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 + 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 + (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 + 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 equivalentWhenSucceedOnArbitrary2 :: - ( Show a - , Arbitrary a - , Show b - , Arbitrary b - , Show c - , Eq c - , CanFail f - ) - => (a -> b -> f c) - -> (a -> b -> f c) - -> Property + ( 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 + 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 + ( Show a, + GenValid a, + Show b, + GenValid b, + Show c, + Eq c, + CanFail f + ) => + (a -> b -> f c) -> + (a -> b -> f c) -> + Property equivalentWhenSucceed2 f g = - equivalentWhenSucceedOnGens2 f g genUnchecked shrinkUnchecked + equivalentWhenSucceedOnGens2 f g genValid shrinkValid 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 + (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 + forAllShrink gen s $ \(a, b, c) -> f a b c `shouldBe` g a b c 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 + ( 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 +equivalent3 f g = equivalentOnGens3 f g genValid shrinkValid 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 + ( 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 --- a/src/Test/Syd/Validity/Functions/Idempotence.hs +++ b/src/Test/Syd/Validity/Functions/Idempotence.hs @@ -3,25 +3,21 @@ -- | Standard tests involving validity module Test.Syd.Validity.Functions.Idempotence - ( idempotentOnGen - , idempotentOnValid - , idempotent - , idempotentOnArbitrary - ) where + ( idempotentOnGen, + idempotent, + idempotentOnArbitrary, + ) +where import Data.GenValidity - -import Test.Syd import Test.QuickCheck +import Test.Syd 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 +idempotent :: (Show a, Eq a, GenValid a) => (a -> a) -> Property +idempotent func = idempotentOnGen func genValid shrinkValid -- | -- diff --git a/src/Test/Syd/Validity/Functions/Inverse.hs b/src/Test/Syd/Validity/Functions/Inverse.hs --- a/src/Test/Syd/Validity/Functions/Inverse.hs +++ b/src/Test/Syd/Validity/Functions/Inverse.hs @@ -3,159 +3,127 @@ -- | 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 + ( inverseFunctionsOnGen, + inverseFunctions, + inverseFunctionsOnArbitrary, + inverseFunctionsIfFirstSucceedsOnGen, + inverseFunctionsIfFirstSucceeds, + inverseFunctionsIfFirstSucceedsOnArbitrary, + inverseFunctionsIfSecondSucceedsOnGen, + inverseFunctionsIfSecondSucceeds, + inverseFunctionsIfSecondSucceedsOnArbitrary, + inverseFunctionsIfSucceedOnGen, + inverseFunctionsIfSucceed, + inverseFunctionsIfSucceedOnArbitrary, + ) +where import Data.GenValidity - -import Test.Syd import Test.QuickCheck - +import Test.Syd import Test.Syd.Validity.Types inverseFunctionsOnGen :: - (Show a, Eq a) => (a -> b) -> (b -> a) -> Gen a -> (a -> [a]) -> Property + (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 + forAllShrink gen s $ \a -> g (f a) `shouldBe` a inverseFunctions :: - (Show a, Eq a, GenUnchecked a) => (a -> b) -> (b -> a) -> Property -inverseFunctions f g = inverseFunctionsOnGen f g genUnchecked shrinkUnchecked + (Show a, Eq a, GenValid a) => (a -> b) -> (b -> a) -> Property +inverseFunctions f g = inverseFunctionsOnGen f g genValid shrinkValid -- | -- '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 + (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 + (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 + forAllShrink gen s $ \a -> + case resultIfSucceeded (f a) of + Nothing -> return () -- fine + Just b -> g b `shouldBe` a inverseFunctionsIfFirstSucceeds :: - (Show a, Eq a, GenUnchecked a, CanFail f) - => (a -> f b) - -> (b -> a) - -> Property + (Show a, Eq a, GenValid a, CanFail f) => + (a -> f b) -> + (b -> a) -> + Property inverseFunctionsIfFirstSucceeds f g = - inverseFunctionsIfFirstSucceedsOnGen f g genUnchecked shrinkUnchecked + inverseFunctionsIfFirstSucceedsOnGen f g genValid shrinkValid inverseFunctionsIfFirstSucceedsOnArbitrary :: - (Show a, Eq a, Arbitrary a, CanFail f) - => (a -> f b) - -> (b -> a) - -> Property + (Show a, Eq a, Arbitrary a, CanFail f) => + (a -> f b) -> + (b -> a) -> + Property inverseFunctionsIfFirstSucceedsOnArbitrary f g = - inverseFunctionsIfFirstSucceedsOnGen f g arbitrary shrink + inverseFunctionsIfFirstSucceedsOnGen f g arbitrary shrink inverseFunctionsIfSecondSucceedsOnGen :: - (Show a, Eq a, CanFail f) - => (a -> b) - -> (b -> f a) - -> Gen a - -> (a -> [a]) - -> Property + (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 + forAllShrink gen s $ \a -> + case resultIfSucceeded (g (f a)) of + Nothing -> return () -- fine + Just r -> r `shouldBe` a inverseFunctionsIfSecondSucceeds :: - (Show a, Eq a, GenUnchecked a, CanFail f) - => (a -> b) - -> (b -> f a) - -> Property + (Show a, Eq a, GenValid a, CanFail f) => + (a -> b) -> + (b -> f a) -> + Property inverseFunctionsIfSecondSucceeds f g = - inverseFunctionsIfSecondSucceedsOnGen f g genUnchecked shrinkUnchecked + inverseFunctionsIfSecondSucceedsOnGen f g genValid shrinkValid inverseFunctionsIfSecondSucceedsOnArbitrary :: - (Show a, Eq a, Arbitrary a, CanFail f) - => (a -> b) - -> (b -> f a) - -> Property + (Show a, Eq a, Arbitrary a, CanFail f) => + (a -> b) -> + (b -> f a) -> + Property inverseFunctionsIfSecondSucceedsOnArbitrary f g = - inverseFunctionsIfSecondSucceedsOnGen f g arbitrary shrink + 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 + (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 + forAllShrink gen s $ \a -> + case do + fa <- resultIfSucceeded $ f a + resultIfSucceeded $ g fa of + Nothing -> return () -- fine + Just r -> r `shouldBe` a inverseFunctionsIfSucceed :: - (Show a, Eq a, GenUnchecked a, CanFail f, CanFail g) - => (a -> f b) - -> (b -> g a) - -> Property + (Show a, Eq a, GenValid a, CanFail f, CanFail g) => + (a -> f b) -> + (b -> g a) -> + Property inverseFunctionsIfSucceed f g = - inverseFunctionsIfSucceedOnGen f g genUnchecked shrinkUnchecked + inverseFunctionsIfSucceedOnGen f g genValid shrinkValid inverseFunctionsIfSucceedOnArbitrary :: - (Show a, Eq a, Arbitrary a, CanFail f, CanFail g) - => (a -> f b) - -> (b -> g a) - -> Property + (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 + inverseFunctionsIfSucceedOnGen f g arbitrary shrink diff --git a/src/Test/Syd/Validity/Functions/Validity.hs b/src/Test/Syd/Validity/Functions/Validity.hs --- a/src/Test/Syd/Validity/Functions/Validity.hs +++ b/src/Test/Syd/Validity/Functions/Validity.hs @@ -3,128 +3,99 @@ -- | Standard tests involving validity module Test.Syd.Validity.Functions.Validity - ( producesValidsOnGen - , producesValidsOnValids - , producesValid - , producesValidsOnArbitrary - , producesValidsOnGens2 - , producesValidsOnValids2 - , producesValid2 - , producesValidsOnArbitrary2 - , producesValidsOnGens3 - , producesValidsOnValids3 - , producesValid3 - , producesValidsOnArbitrary3 - ) where + ( producesValidsOnGen, + producesValid, + producesValidsOnArbitrary, + producesValidsOnGens2, + producesValid2, + producesValidsOnArbitrary2, + producesValidsOnGens3, + 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 + 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 + (Show a, Show b, GenValid a, Validity b) => (a -> b) -> Property +producesValid f = producesValidsOnGen f genValid shrinkValid -- | The function produces valid output when the input is generated by -- @arbitrary@ producesValidsOnArbitrary :: - (Show a, Show b, Arbitrary a, Validity b) => (a -> b) -> Property + (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 + (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 + forAllShrink gen s $ \(a, b) -> shouldBeValid $ func a b producesValid2 :: - (Show a, Show b, Show c, GenUnchecked a, GenUnchecked b, Validity c) - => (a -> b -> c) - -> Property -producesValid2 func = producesValidsOnGens2 func genUnchecked shrinkUnchecked + (Show a, Show b, Show c, GenValid a, GenValid b, Validity c) => + (a -> b -> c) -> + Property +producesValid2 func = producesValidsOnGens2 func genValid shrinkValid producesValidsOnArbitrary2 :: - (Show a, Show b, Show c, Arbitrary a, Arbitrary b, Validity c) - => (a -> b -> c) - -> Property + (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 + (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 + forAllShrink gen s $ \(a, b, c) -> shouldBeValid $ func a b c 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 + ( Show a, + Show b, + Show c, + Show d, + GenValid a, + GenValid b, + GenValid c, + Validity d + ) => + (a -> b -> c -> d) -> + Property +producesValid3 func = producesValidsOnGens3 func genValid shrinkValid producesValidsOnArbitrary3 :: - ( Show a - , Show b - , Show c - , Show d - , Arbitrary a - , Arbitrary b - , Arbitrary c - , Validity d - ) - => (a -> b -> c -> d) - -> Property + ( 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 --- a/src/Test/Syd/Validity/Functor.hs +++ b/src/Test/Syd/Validity/Functor.hs @@ -1,77 +1,65 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} -- | Functor properties -- -- You will need @TypeApplications@ to use these. module Test.Syd.Validity.Functor - ( functorSpecOnValid - , functorSpec - , functorSpecOnArbitrary - , functorSpecOnGens - ) where + ( functorSpec, + functorSpecOnArbitrary, + functorSpecOnGens, + ) +where import Data.Data - import Data.GenValidity import Data.Kind - -import Test.Syd import Test.QuickCheck - +import Test.Syd import Test.Syd.Validity.Functions import Test.Syd.Validity.Utils {-# ANN module "HLint: ignore Functor law" #-} fmapTypeStr :: - forall (f :: Type -> Type). (Typeable f) - => String + forall (f :: Type -> Type). + (Typeable f) => + String fmapTypeStr = - unwords - [ "fmap" - , "::" - , "(a" - , "->" - , "b)" - , "->" - , nameOf @f - , "a" - , "->" - , nameOf @f - , "b" - ] + unwords + [ "fmap", + "::", + "(a", + "->", + "b)", + "->", + nameOf @f, + "a", + "->", + nameOf @f, + "b" + ] flTypeStr :: - forall (f :: Type -> Type). (Typeable f) - => String + forall (f :: Type -> Type). + (Typeable f) => + String flTypeStr = - unwords ["(<$)", "::", "a", "->", nameOf @f, "b", "->", nameOf @f, "a"] + 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 + forall (f :: Type -> Type). + (Eq (f Int), Show (f Int), Functor f, Typeable f, GenValid (f Int)) => + Spec +functorSpec = functorSpecWithInts @f genValid -- | Standard test spec for properties of Functor instances for values generated with Arbitrary instances -- @@ -79,27 +67,28 @@ -- -- > functorSpecOnArbitrary @[] functorSpecOnArbitrary :: - forall (f :: Type -> Type). - (Eq (f Int), Show (f Int), Functor f, Typeable f, Arbitrary (f Int)) - => Spec + 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 + 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" + functorSpecOnGens + @f + @Int + genValid + "int" + gen + (unwords [nameOf @f, "of ints"]) + ((+) <$> genValid) + "increments" + ((*) <$> genValid) + "scalings" -- | Standard test spec for properties of Functor instances for values generated by given generators (and names for those generator). -- @@ -113,61 +102,64 @@ -- > ((+) <$> 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 + 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 $ + 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 + 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 deleted file mode 100644 --- a/src/Test/Syd/Validity/GenRelativeValidity.hs +++ /dev/null @@ -1,113 +0,0 @@ -{-# 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 --- a/src/Test/Syd/Validity/GenValidity.hs +++ b/src/Test/Syd/Validity/GenValidity.hs @@ -1,49 +1,26 @@ -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | Tests for GenValidity instances -- -- You will need @TypeApplications@ to use these. module Test.Syd.Validity.GenValidity - ( genValiditySpec - , genValidSpec - , genInvalidSpec - , genValidGeneratesValid - , genGeneratesValid - , genInvalidGeneratesInvalid - , genGeneratesInvalid - ) where + ( genValidSpec, + genValidGeneratesValid, + genGeneratesValid, + genGeneratesInvalid, + ) +where import Data.Data - import Data.GenValidity - -import Test.Syd import Test.QuickCheck - +import Test.Syd 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 @@ -53,33 +30,16 @@ -- -- > genValidSpec @Int genValidSpec :: - forall a. (Typeable a, Show a, GenValid a) - => Spec + 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 + parallel $ do + let name = nameOf @a + describe ("GenValid " ++ name) $ + describe ("genValid :: Gen " ++ name) $ + it ("only generates valid \'" ++ name ++ "\'s") $ + genValidGeneratesValid @a -- | @genValid@ only generates valid data -- @@ -94,17 +54,7 @@ -- prop> genValidGeneratesValid @(Maybe Int) -- prop> genValidGeneratesValid @[Int] genValidGeneratesValid :: - forall a. (Show a, GenValid a) - => Property + 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 --- a/src/Test/Syd/Validity/GenValidity/Property.hs +++ b/src/Test/Syd/Validity/GenValidity/Property.hs @@ -1,29 +1,30 @@ -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Tests for GenValidity instances module Test.Syd.Validity.GenValidity.Property - ( genGeneratesValid - , genGeneratesInvalid - ) where + ( 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 + 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 + 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 --- a/src/Test/Syd/Validity/Monad.hs +++ b/src/Test/Syd/Validity/Monad.hs @@ -1,30 +1,27 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} -- | Monad properties -- -- You will need @TypeApplications@ to use these. module Test.Syd.Validity.Monad - ( monadSpecOnValid - , monadSpec - , monadSpecOnArbitrary - , monadSpecOnGens - ) where - -import Data.Data + ( monadSpec, + monadSpecOnArbitrary, + monadSpecOnGens, + ) +where import Control.Monad (ap) -import Data.Kind (Type) +import Data.Data import Data.GenValidity +import Data.Kind (Type) +import Test.QuickCheck 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 @@ -45,50 +42,41 @@ {-# ANN module "HLint: ignore Reduce duplication" #-} returnTypeStr :: - forall (m :: Type -> Type). (Typeable m) - => String + forall (m :: Type -> Type). + (Typeable m) => + String returnTypeStr = unwords ["return", "::", "a", "->", nameOf @m, "a"] bindTypeStr :: - forall (m :: Type -> Type). (Typeable m) - => String + forall (m :: Type -> Type). + (Typeable m) => + String bindTypeStr = - unwords - [ "(>>=)" - , "::" - , nameOf @m - , "a" - , "->" - , "(b" - , "->" - , nameOf @m - , "a)" - , "->" - , nameOf @m - , "b" - ] + 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 + forall (f :: Type -> Type). + (Eq (f Int), Show (f Int), Monad f, Typeable f, GenValid (f Int)) => + Spec +monadSpec = monadSpecWithInts @f genValid -- | Standard test spec for properties of Monad instances for values generated with Arbitrary instances -- @@ -96,35 +84,40 @@ -- -- > monadSpecOnArbitrary @[] monadSpecOnArbitrary :: - forall (f :: Type -> Type). - (Eq (f Int), Show (f Int), Monad f, Typeable f, Arbitrary (f Int)) - => Spec + 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 + 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"]) + monadSpecOnGens + @f + @Int + genValid + "int" + gen + (unwords [nameOf @f, "of ints"]) + gen + (unwords [nameOf @f, "of ints"]) + ((+) <$> genValid) + "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 <$> ((+) <$> genValid)) + (unwords [nameOf @f, "of additions"]) -- | Standard test spec for properties of Monad instances for values generated by given generators (and names for those generator). -- @@ -148,106 +141,113 @@ -- > (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 + 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 $ + 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 + 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 --- a/src/Test/Syd/Validity/Monoid.hs +++ b/src/Test/Syd/Validity/Monoid.hs @@ -1,44 +1,44 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} -- | Monoid properties -- -- You will need @TypeApplications@ to use these. module Test.Syd.Validity.Monoid - ( monoidSpecOnValid - , monoidSpec - , monoidSpecOnArbitrary - , monoidSpecOnGen - ) where + ( monoidSpec, + monoidSpecOnArbitrary, + monoidSpecOnGen, + ) +where import Data.Data - import Data.GenValidity - -import Test.Syd import Test.QuickCheck - +import Test.Syd import Test.Syd.Validity.Functions import Test.Syd.Validity.Operations import Test.Syd.Validity.Utils memptyTypeStr :: - forall a. Typeable a - => String + forall a. + Typeable a => + String memptyTypeStr = unwords ["mempty", "::", nameOf @a] mappendTypeStr :: - forall a. Typeable a - => String + forall a. + Typeable a => + String mappendTypeStr = unwords ["mappend", "::", an, "->", an, "->", an] where an = nameOf @a mconcatTypeStr :: - forall a. Typeable a - => String + forall a. + Typeable a => + String mconcatTypeStr = unwords ["mconcat", "::", "[" ++ an ++ "]", "->", an] where an = nameOf @a @@ -47,21 +47,12 @@ -- -- 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 + forall a. + (Show a, Eq a, Monoid a, Typeable a, GenValid a) => + Spec +monoidSpec = monoidSpecOnGen @a genValid "valid" shrinkValid -- | Standard test spec for properties of 'Monoid' instances for arbitrary values -- @@ -69,8 +60,9 @@ -- -- > monoidSpecOnArbitrary @[Int] monoidSpecOnArbitrary :: - forall a. (Show a, Eq a, Monoid a, Typeable a, Arbitrary a) - => Spec + 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). @@ -79,45 +71,49 @@ -- -- > monoidSpecOnGen (pure "a") "singleton list of 'a'" monoidSpecOnGen :: - forall a. (Show a, Eq a, Monoid a, Typeable a) - => Gen a - -> String - -> (a -> [a]) - -> Spec + 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 + 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 --- a/src/Test/Syd/Validity/Operations.hs +++ b/src/Test/Syd/Validity/Operations.hs @@ -3,31 +3,11 @@ -- | 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 + ( module Test.Syd.Validity.Operations.Associativity, + module Test.Syd.Validity.Operations.Commutativity, + module Test.Syd.Validity.Operations.Identity, + ) +where import Test.Syd.Validity.Operations.Associativity import Test.Syd.Validity.Operations.Commutativity diff --git a/src/Test/Syd/Validity/Operations/Associativity.hs b/src/Test/Syd/Validity/Operations/Associativity.hs --- a/src/Test/Syd/Validity/Operations/Associativity.hs +++ b/src/Test/Syd/Validity/Operations/Associativity.hs @@ -2,16 +2,15 @@ {-# LANGUAGE ScopedTypeVariables #-} module Test.Syd.Validity.Operations.Associativity - ( associativeOnGens - , associativeOnValids - , associative - , associativeOnArbitrary - ) where + ( associativeOnGens, + associative, + associativeOnArbitrary, + ) +where import Data.GenValidity - -import Test.Syd import Test.QuickCheck +import Test.Syd -- | -- @@ -22,29 +21,26 @@ -- (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 + (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 + forAllShrink gen s $ \(a, b, c) -> + ((a `op` b) `op` c) `shouldBe` (a `op` (b `op` c)) -- | -- -- 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 +associative :: (Show a, Eq a, GenValid a) => (a -> a -> a) -> Property +associative op = associativeOnGens op genValid shrinkValid -- | -- -- prop> associativeOnArbitrary ((*) :: Int -> Int -> Int) -- prop> associativeOnArbitrary ((+) :: Int -> Int -> Int) associativeOnArbitrary :: - (Show a, Eq a, Arbitrary a) => (a -> a -> a) -> Property + (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 --- a/src/Test/Syd/Validity/Operations/Commutativity.hs +++ b/src/Test/Syd/Validity/Operations/Commutativity.hs @@ -2,16 +2,15 @@ {-# LANGUAGE ScopedTypeVariables #-} module Test.Syd.Validity.Operations.Commutativity - ( commutativeOnGens - , commutativeOnValids - , commutative - , commutativeOnArbitrary - ) where + ( commutativeOnGens, + commutative, + commutativeOnArbitrary, + ) +where import Data.GenValidity - -import Test.Syd import Test.QuickCheck +import Test.Syd -- | -- @@ -22,31 +21,23 @@ -- a \star b = b \star a -- \] commutativeOnGens :: - (Show a, Show b, Eq b) - => (a -> a -> b) - -> Gen (a, a) - -> ((a, a) -> [(a, a)]) - -> Property + (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 + forAllShrink gen s $ \(a, b) -> (a `op` b) `shouldBe` (b `op` a) -- | -- -- 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 + (Show a, Show b, Eq b, GenValid a) => + (a -> a -> b) -> + Property +commutative op = commutativeOnGens op genValid shrinkValid -- | -- @@ -55,6 +46,7 @@ -- commutativeOnArbitrary :: -- (Show a, Eq a, Arbitrary a) => (a -> a -> a) -> Property commutativeOnArbitrary :: - (Show a, Show b, Eq b, Arbitrary a) - => (a -> a -> b) -> Property + (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 --- a/src/Test/Syd/Validity/Operations/Identity.hs +++ b/src/Test/Syd/Validity/Operations/Identity.hs @@ -2,26 +2,23 @@ {-# 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 + ( leftIdentityOnElemWithEquality, + leftIdentityOnGenWithEquality, + leftIdentityOnGen, + leftIdentity, + leftIdentityOnArbitrary, + rightIdentityOnElemWithEquality, + rightIdentityOnGenWithEquality, + rightIdentityOnGen, + rightIdentity, + rightIdentityOnArbitrary, + identityOnGen, + identity, + identityOnArbitrary, + ) +where import Data.GenValidity - import Test.QuickCheck -- | @@ -32,51 +29,53 @@ -- \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 + -- | A binary operation + (b -> a -> a) -> + -- | An equality + (a -> a -> Bool) -> + -- | A candidate left-identity + b -> + -- | An element + a -> + 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 + Show a => + -- | A binary operation + (b -> a -> a) -> + -- | An equality + (a -> a -> Bool) -> + -- | A candidate left-identity + b -> + Gen a -> + (a -> [a]) -> + Property leftIdentityOnGenWithEquality op eq b gen s = - forAllShrink gen s $ leftIdentityOnElemWithEquality op eq b + 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 + (Show a, Eq a) => + -- | A binary operation + (b -> a -> a) -> + -- | A candidate left-identity + b -> + 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 +leftIdentity :: (Show a, Eq a, GenValid a) => (b -> a -> a) -> b -> Property +leftIdentity op b = leftIdentityOnGen op b genValid shrinkValid -- | -- -- prop> leftIdentityOnArbitrary (flip ((^) :: Int -> Int -> Int)) 1 leftIdentityOnArbitrary :: - (Show a, Eq a, Arbitrary a) => (b -> a -> a) -> b -> Property + (Show a, Eq a, Arbitrary a) => (b -> a -> a) -> b -> Property leftIdentityOnArbitrary op b = leftIdentityOnGen op b arbitrary shrink -- | @@ -87,52 +86,54 @@ -- \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 + -- | A binary operation + (a -> b -> a) -> + -- | An equality + (a -> a -> Bool) -> + -- | A candidate right-identity + b -> + -- | An element + a -> + 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 + Show a => + -- | A binary operation + (a -> b -> a) -> + -- | An equality + (a -> a -> Bool) -> + -- | A candidate right-identity + b -> + Gen a -> + (a -> [a]) -> + Property rightIdentityOnGenWithEquality op eq b gen s = - forAllShrink gen s $ rightIdentityOnElemWithEquality op eq b + 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 + (Show a, Eq a) => + -- | A binary operation + (a -> b -> a) -> + -- | A candidate right-identity + b -> + 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 + (Show a, Eq a, GenValid a) => (a -> b -> a) -> b -> Property +rightIdentity op b = rightIdentityOnGen op b genValid shrinkValid -- | -- -- prop> rightIdentityOnArbitrary ((^) :: Int -> Int -> Int) 1 rightIdentityOnArbitrary :: - (Show a, Eq a, Arbitrary a) => (a -> b -> a) -> b -> Property + (Show a, Eq a, Arbitrary a) => (a -> b -> a) -> b -> Property rightIdentityOnArbitrary op b = rightIdentityOnGen op b arbitrary shrink -- | @@ -143,28 +144,21 @@ -- LeftIdentity(\star, \doteq, b) \wedge RightIdentity(\star, \doteq, b) -- \] identityOnGen :: - (Show a, Eq a) => (a -> a -> a) -> a -> Gen a -> (a -> [a]) -> Property + (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 + leftIdentityOnGen op e gen s .&&. rightIdentityOnGen op e gen s -- | -- -- 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 +identity :: (Show a, Eq a, GenValid a) => (a -> a -> a) -> a -> Property +identity op e = identityOnGen op e genValid shrinkValid -- | -- -- prop> identityOnArbitrary ((*) :: Int -> Int -> Int) 1 -- prop> identityOnArbitrary ((+) :: Int -> Int -> Int) 0 identityOnArbitrary :: - (Show a, Eq a, Arbitrary a) => (a -> a -> a) -> a -> Property + (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 --- a/src/Test/Syd/Validity/Ord.hs +++ b/src/Test/Syd/Validity/Ord.hs @@ -9,8 +9,6 @@ -- You will need @TypeApplications@ to use these. module Test.Syd.Validity.Ord ( ordSpecOnGen, - ordSpecOnValid, - ordSpecOnInvalid, ordSpec, ordSpecOnArbitrary, ) @@ -60,34 +58,12 @@ -- -- 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) => + (Show a, Ord a, Typeable a, GenValid a) => Spec -ordSpec = ordSpecOnGen @a genUnchecked "unchecked" shrinkUnchecked +ordSpec = ordSpecOnGen @a genValid "valid" shrinkValid -- | Standard test spec for properties of Ord instances for arbitrary values -- diff --git a/src/Test/Syd/Validity/Property.hs b/src/Test/Syd/Validity/Property.hs --- a/src/Test/Syd/Validity/Property.hs +++ b/src/Test/Syd/Validity/Property.hs @@ -2,192 +2,188 @@ {-# 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 + ( module Data.GenValidity, + forAllValid, -import Data.GenValidity + -- * Tests for GenValidity instances + genGeneratesValid, + -- * Standard tests involving functions + + -- ** Standard tests involving validity + producesValidsOnGen, + producesValid, + producesValidsOnArbitrary, + producesValidsOnGens2, + producesValid2, + producesValidsOnArbitrary2, + producesValidsOnGens3, + producesValid3, + producesValidsOnArbitrary3, + + -- ** Standard tests involving functions that can fail + CanFail (..), + succeedsOnGen, + succeeds, + succeedsOnArbitrary, + succeedsOnGens2, + succeeds2, + succeedsOnArbitrary2, + failsOnGen, + failsOnGens2, + validIfSucceedsOnGen, + validIfSucceedsOnArbitrary, + validIfSucceeds, + validIfSucceedsOnGens2, + validIfSucceeds2, + validIfSucceedsOnArbitrary2, + validIfSucceedsOnGens3, + validIfSucceeds3, + validIfSucceedsOnArbitrary3, + + -- ** Standard tests involving equivalence of functions + + -- *** Simple functions + + -- **** One argument + equivalentOnGen, + equivalent, + equivalentOnArbitrary, + + -- **** Two arguments + equivalentOnGens2, + equivalent2, + equivalentOnArbitrary2, + + -- **** Three arguments + equivalentOnGens3, + equivalent3, + equivalentOnArbitrary3, + + -- *** First function can fail + + -- **** One argument + equivalentWhenFirstSucceedsOnGen, + equivalentWhenFirstSucceeds, + equivalentWhenFirstSucceedsOnArbitrary, + + -- **** Two arguments + equivalentWhenFirstSucceedsOnGens2, + equivalentWhenFirstSucceeds2, + equivalentWhenFirstSucceedsOnArbitrary2, + + -- *** Second function can fail + + -- **** One argument + equivalentWhenSecondSucceedsOnGen, + equivalentWhenSecondSucceeds, + equivalentWhenSecondSucceedsOnArbitrary, + + -- **** Two arguments + equivalentWhenSecondSucceedsOnGens2, + equivalentWhenSecondSucceeds2, + equivalentWhenSecondSucceedsOnArbitrary2, + + -- *** Both functions can fail + + -- **** One argument + equivalentWhenSucceedOnGen, + equivalentWhenSucceed, + equivalentWhenSucceedOnArbitrary, + + -- **** Two arguments + equivalentWhenSucceedOnGens2, + equivalentWhenSucceed2, + equivalentWhenSucceedOnArbitrary2, + + -- ** Standard tests involving inverse functions + inverseFunctionsOnGen, + inverseFunctions, + inverseFunctionsOnArbitrary, + inverseFunctionsIfFirstSucceedsOnGen, + inverseFunctionsIfFirstSucceeds, + inverseFunctionsIfFirstSucceedsOnArbitrary, + inverseFunctionsIfSecondSucceedsOnGen, + inverseFunctionsIfSecondSucceeds, + inverseFunctionsIfSecondSucceedsOnArbitrary, + inverseFunctionsIfSucceedOnGen, + inverseFunctionsIfSucceed, + inverseFunctionsIfSucceedOnArbitrary, + + -- ** Properties involving idempotence + idempotentOnGen, + idempotent, + idempotentOnArbitrary, + + -- * Properties of relations + + -- ** Reflexivity + reflexiveOnElem, + reflexivityOnGen, + reflexivity, + reflexivityOnArbitrary, + + -- ** Transitivity + transitiveOnElems, + transitivityOnGens, + transitivity, + transitivityOnArbitrary, + + -- ** Antisymmetry + antisymmetricOnElemsWithEquality, + antisymmetryOnGensWithEquality, + antisymmetryOnGens, + antisymmetry, + antisymmetryOnArbitrary, + + -- ** Antireflexivity + antireflexiveOnElem, + antireflexivityOnGen, + antireflexivity, + antireflexivityOnArbitrary, + + -- ** Symmetry + symmetricOnElems, + symmetryOnGens, + symmetry, + symmetryOnArbitrary, + + -- * Properties of operations + + -- ** Identity element + + -- *** Left Identity + leftIdentityOnElemWithEquality, + leftIdentityOnGenWithEquality, + leftIdentityOnGen, + leftIdentity, + leftIdentityOnArbitrary, + + -- *** Right Identity + rightIdentityOnElemWithEquality, + rightIdentityOnGenWithEquality, + rightIdentityOnGen, + rightIdentity, + rightIdentityOnArbitrary, + + -- *** Identity + identityOnGen, + identity, + identityOnArbitrary, + + -- ** Associativity + associativeOnGens, + associative, + associativeOnArbitrary, + + -- ** Commutativity + commutativeOnGens, + commutative, + commutativeOnArbitrary, + ) +where + +import Data.GenValidity import Test.Syd.Validity.Functions import Test.Syd.Validity.GenValidity.Property import Test.Syd.Validity.Operations diff --git a/src/Test/Syd/Validity/Property/Utils.hs b/src/Test/Syd/Validity/Property/Utils.hs --- a/src/Test/Syd/Validity/Property/Utils.hs +++ b/src/Test/Syd/Validity/Property/Utils.hs @@ -1,9 +1,5 @@ -{-# LANGUAGE CPP #-} - module Test.Syd.Validity.Property.Utils - ( forAllUnchecked, - forAllValid, - forAllInvalid, + ( forAllValid, shouldBeValid, shouldBeInvalid, (<==>), @@ -15,20 +11,8 @@ 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 diff --git a/src/Test/Syd/Validity/Relations.hs b/src/Test/Syd/Validity/Relations.hs --- a/src/Test/Syd/Validity/Relations.hs +++ b/src/Test/Syd/Validity/Relations.hs @@ -3,33 +3,13 @@ -- | 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 + ( module Test.Syd.Validity.Relations.Antireflexivity, + module Test.Syd.Validity.Relations.Antisymmetry, + module Test.Syd.Validity.Relations.Reflexivity, + module Test.Syd.Validity.Relations.Symmetry, + module Test.Syd.Validity.Relations.Transitivity, + ) +where import Test.Syd.Validity.Relations.Antireflexivity import Test.Syd.Validity.Relations.Antisymmetry diff --git a/src/Test/Syd/Validity/Relations/Antireflexivity.hs b/src/Test/Syd/Validity/Relations/Antireflexivity.hs --- a/src/Test/Syd/Validity/Relations/Antireflexivity.hs +++ b/src/Test/Syd/Validity/Relations/Antireflexivity.hs @@ -2,15 +2,14 @@ {-# LANGUAGE ScopedTypeVariables #-} module Test.Syd.Validity.Relations.Antireflexivity - ( antireflexiveOnElem - , antireflexivityOnGen - , antireflexivityOnValid - , antireflexivity - , antireflexivityOnArbitrary - ) where + ( antireflexiveOnElem, + antireflexivityOnGen, + antireflexivity, + antireflexivityOnArbitrary, + ) +where import Data.GenValidity - import Test.QuickCheck -- | @@ -21,30 +20,24 @@ -- \forall a: \neg (a \prec a) -- \] antireflexiveOnElem :: - (a -> a -> Bool) -- ^ A relation - -> a -- ^ An element - -> Bool + -- | A relation + (a -> a -> Bool) -> + -- | An element + a -> + Bool antireflexiveOnElem func a = not $ func a a antireflexivityOnGen :: - Show a => (a -> a -> Bool) -> Gen a -> (a -> [a]) -> Property + 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 +antireflexivity :: (Show a, GenValid a) => (a -> a -> Bool) -> Property +antireflexivity func = antireflexivityOnGen func genValid shrinkValid -- | -- @@ -52,5 +45,5 @@ -- prop> antireflexivityOnArbitrary ((/=) :: Int -> Int -> Bool) -- prop> antireflexivityOnArbitrary ((>) :: Int -> Int -> Bool) antireflexivityOnArbitrary :: - (Show a, Arbitrary a) => (a -> a -> Bool) -> Property + (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 --- a/src/Test/Syd/Validity/Relations/Antisymmetry.hs +++ b/src/Test/Syd/Validity/Relations/Antisymmetry.hs @@ -2,18 +2,16 @@ {-# LANGUAGE ScopedTypeVariables #-} module Test.Syd.Validity.Relations.Antisymmetry - ( antisymmetricOnElemsWithEquality - , antisymmetryOnGensWithEquality - , antisymmetryOnGens - , antisymmetryOnValid - , antisymmetry - , antisymmetryOnArbitrary - ) where + ( antisymmetricOnElemsWithEquality, + antisymmetryOnGensWithEquality, + antisymmetryOnGens, + antisymmetry, + antisymmetryOnArbitrary, + ) +where import Data.GenValidity - import Test.QuickCheck - import Test.Syd.Validity.Property.Utils -- | @@ -24,48 +22,38 @@ -- \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 + -- | A relation + (a -> a -> Bool) -> + -- | An equivalence relation + (a -> a -> Bool) -> + a -> + -- | Two elements + a -> + Bool antisymmetricOnElemsWithEquality func eq a b = - (func a b && func b a) ===> (a `eq` 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 + Show a => + (a -> a -> Bool) -> + Gen (a, a) -> + (a -> a -> Bool) -> + (a -> [a]) -> + Property antisymmetryOnGensWithEquality func gen eq s = - forAllShrink gen (shrinkT2 s) $ + forAllShrink gen (shrinkT2 s) $ uncurry $ antisymmetricOnElemsWithEquality func eq antisymmetryOnGens :: - (Show a, Eq a) - => (a -> a -> Bool) - -> Gen (a, a) - -> (a -> [a]) - -> Property + (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) @@ -74,8 +62,8 @@ -- 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 +antisymmetry :: (Show a, Eq a, GenValid a) => (a -> a -> Bool) -> Property +antisymmetry func = antisymmetryOnGens func genValid shrinkValid -- | -- @@ -88,5 +76,5 @@ -- 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 + (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 --- a/src/Test/Syd/Validity/Relations/Reflexivity.hs +++ b/src/Test/Syd/Validity/Relations/Reflexivity.hs @@ -2,15 +2,14 @@ {-# LANGUAGE ScopedTypeVariables #-} module Test.Syd.Validity.Relations.Reflexivity - ( reflexiveOnElem - , reflexivityOnGen - , reflexivityOnValid - , reflexivity - , reflexivityOnArbitrary - ) where + ( reflexiveOnElem, + reflexivityOnGen, + reflexivity, + reflexivityOnArbitrary, + ) +where import Data.GenValidity - import Test.QuickCheck -- | @@ -21,36 +20,27 @@ -- \forall a: (a \prec a) -- \] reflexiveOnElem :: - (a -> a -> Bool) -- ^ A relation - -> a -- ^ An element - -> Bool + -- | A relation + (a -> a -> Bool) -> + -- | An element + a -> + Bool reflexiveOnElem func a = func a a reflexivityOnGen :: - Show a => (a -> a -> Bool) -> Gen a -> (a -> [a]) -> Property + 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 +reflexivity :: (Show a, GenValid a) => (a -> a -> Bool) -> Property +reflexivity func = reflexivityOnGen func genValid shrinkValid -- | -- diff --git a/src/Test/Syd/Validity/Relations/Symmetry.hs b/src/Test/Syd/Validity/Relations/Symmetry.hs --- a/src/Test/Syd/Validity/Relations/Symmetry.hs +++ b/src/Test/Syd/Validity/Relations/Symmetry.hs @@ -2,17 +2,15 @@ {-# LANGUAGE ScopedTypeVariables #-} module Test.Syd.Validity.Relations.Symmetry - ( symmetricOnElems - , symmetryOnGens - , symmetryOnValid - , symmetry - , symmetryOnArbitrary - ) where + ( symmetricOnElems, + symmetryOnGens, + symmetry, + symmetryOnArbitrary, + ) +where import Data.GenValidity - import Test.QuickCheck - import Test.Syd.Validity.Property.Utils -- | @@ -23,30 +21,25 @@ -- \forall a, b: (a \prec b) \Leftrightarrow (b \prec a) -- \] symmetricOnElems :: - (a -> a -> Bool) -- ^ A relation - -> a - -> a -- ^ Two elements - -> Bool + -- | A relation + (a -> a -> Bool) -> + a -> + -- | Two elements + a -> + Bool symmetricOnElems func a b = func a b <==> func b a symmetryOnGens :: - Show a => (a -> a -> Bool) -> Gen (a, a) -> (a -> [a]) -> Property + 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 + forAllShrink gen (shrinkT2 s) $ uncurry $ symmetricOnElems func -- | -- -- 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 +symmetry :: (Show a, GenValid a) => (a -> a -> Bool) -> Property +symmetry func = symmetryOnGens func genValid shrinkValid -- | -- diff --git a/src/Test/Syd/Validity/Relations/Transitivity.hs b/src/Test/Syd/Validity/Relations/Transitivity.hs --- a/src/Test/Syd/Validity/Relations/Transitivity.hs +++ b/src/Test/Syd/Validity/Relations/Transitivity.hs @@ -2,17 +2,15 @@ {-# LANGUAGE ScopedTypeVariables #-} module Test.Syd.Validity.Relations.Transitivity - ( transitiveOnElems - , transitivityOnGens - , transitivityOnValid - , transitivity - , transitivityOnArbitrary - ) where + ( transitiveOnElems, + transitivityOnGens, + transitivity, + transitivityOnArbitrary, + ) +where import Data.GenValidity - import Test.QuickCheck - import Test.Syd.Validity.Property.Utils -- | @@ -23,30 +21,19 @@ -- \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 + -- | A relation + (a -> a -> Bool) -> + a -> + a -> + -- | Three elements + a -> + 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 + 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 + forAllShrink gen (shrinkT3 s) $ \(a, b, c) -> transitiveOnElems func a b c -- | -- @@ -58,8 +45,8 @@ -- 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 +transitivity :: (Show a, GenValid a) => (a -> a -> Bool) -> Property +transitivity func = transitivityOnGens func genValid shrinkValid -- | -- diff --git a/src/Test/Syd/Validity/RelativeValidity.hs b/src/Test/Syd/Validity/RelativeValidity.hs deleted file mode 100644 --- a/src/Test/Syd/Validity/RelativeValidity.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# 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 --- a/src/Test/Syd/Validity/Show.hs +++ b/src/Test/Syd/Validity/Show.hs @@ -5,47 +5,32 @@ -- | 'Show' and 'Read' properties module Test.Syd.Validity.Show - ( showReadSpecOnValid - , showReadSpec - , showReadSpecOnArbitrary - , showReadSpecOnGen - , showReadRoundTripOnValid - , showReadRoundTrip - , showReadRoundTripOnArbitrary - , showReadRoundTripOnGen - ) where - -import Data.GenValidity + ( showReadSpec, + showReadSpecOnArbitrary, + showReadSpecOnGen, + showReadRoundTrip, + showReadRoundTripOnArbitrary, + showReadRoundTripOnGen, + ) +where import Data.Data - -import Text.Read - -import Test.Syd +import Data.GenValidity import Test.QuickCheck - +import Test.Syd import Test.Syd.Validity.Utils +import Text.Read -- | 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 - + forall a. + (Show a, Eq a, Read a, Typeable a, GenValid a) => + Spec +showReadSpec = showReadSpecOnGen @a genValid "valid" shrinkValid -- | Standard test spec for properties of Show and Read instances for arbitrary values -- @@ -53,8 +38,9 @@ -- -- > showReadSpecOnArbitrary @Double showReadSpecOnArbitrary :: - forall a. (Show a, Eq a, Read a, Typeable a, Arbitrary a) - => Spec + 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 @@ -63,47 +49,41 @@ -- -- > showReadSpecOnGen ((* 2) <$> genValid @Int) "even" (const []) showReadSpecOnGen :: - forall a. (Show a, Eq a, Read a, Typeable a) - => Gen a - -> String - -> (a -> [a]) - -> Spec + 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]) $ + 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 + showReadRoundTripOnGen gen s -- | -- -- prop> showReadRoundTrip @Int showReadRoundTrip :: - forall a. (Show a, Eq a, Read a, GenUnchecked a) - => Property + forall a. + (Show a, Eq a, Read a, GenValid a) => + Property showReadRoundTrip = - showReadRoundTripOnGen (genUnchecked :: Gen a) shrinkUnchecked + showReadRoundTripOnGen (genValid :: Gen a) shrinkValid -- | -- -- prop> showReadRoundTripOnArbitrary @Double showReadRoundTripOnArbitrary :: - forall a. (Show a, Eq a, Read a, Arbitrary a) - => Property + forall a. + (Show a, Eq a, Read a, Arbitrary a) => + Property showReadRoundTripOnArbitrary = - showReadRoundTripOnGen (arbitrary :: Gen a) shrink + showReadRoundTripOnGen (arbitrary :: Gen a) shrink -- | -- --- prop> showReadRoundTripOnGen (abs <$> genUnchecked :: Gen Int) (const []) +-- prop> showReadRoundTripOnGen (abs <$> genValid :: Gen Int) (const []) showReadRoundTripOnGen :: - (Show a, Eq a, Read a) => Gen a -> (a -> [a]) -> Property + (Show a, Eq a, Read a) => Gen a -> (a -> [a]) -> Property showReadRoundTripOnGen gen s = - forAllShrink gen s $ \v -> readMaybe (show v) `shouldBe` Just v + 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 --- a/src/Test/Syd/Validity/Shrinking.hs +++ b/src/Test/Syd/Validity/Shrinking.hs @@ -1,143 +1,89 @@ -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | 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 + ( shrinkValidSpec, + shrinkValidSpecWithLimit, + shrinkValidPreservesValidOnGenValid, + shrinkValidPreservesValidOnGenValidWithLimit, + shrinkPreservesValidOnGenValid, + shrinkValidPreservesValid, + shrinkingStaysValid, + shrinkingPreserves, + shrinkValidDoesNotShrinkToItself, + shrinkValidDoesNotShrinkToItselfWithLimit, + ) +where +import Control.Monad import Data.Data - import Data.GenValidity - -import Control.Monad - -import Test.Syd import Test.QuickCheck - +import Test.Syd 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 + 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 + 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 + 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 + 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 shrinkValidPreservesValidOnGenValid :: - forall a. (Show a, GenValid a) - => Property + forall a. + (Show a, GenValid a) => + Property shrinkValidPreservesValidOnGenValid = - shrinkingStaysValid @a genValid shrinkValid + shrinkingStaysValid @a genValid shrinkValid shrinkValidPreservesValidOnGenValidWithLimit :: - forall a. (Show a, GenValid a) - => Int - -> Property + 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 + shrinkingStaysValidWithLimit @a genValid shrinkValid shrinkValidDoesNotShrinkToItself :: - forall a. (Show a, Eq a, GenValid a) - => Property + 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 + shrinkDoesNotShrinkToItself @a shrinkValid shrinkValidDoesNotShrinkToItselfWithLimit :: - forall a. (Show a, Eq a, GenValid a) - => Int - -> Property + 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 + shrinkDoesNotShrinkToItselfOnValidWithLimit @a shrinkValid diff --git a/src/Test/Syd/Validity/Shrinking/Property.hs b/src/Test/Syd/Validity/Shrinking/Property.hs --- a/src/Test/Syd/Validity/Shrinking/Property.hs +++ b/src/Test/Syd/Validity/Shrinking/Property.hs @@ -1,201 +1,161 @@ -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# 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 + ( shrinkPreservesValidOnGenValid, + shrinkValidPreservesValid, + shrinkingStaysValid, + shrinkingStaysValidWithLimit, + shrinkingPreserves, + shrinkingPreservesWithLimit, + shrinkDoesNotShrinkToItself, + shrinkDoesNotShrinkToItselfWithLimit, + shrinkDoesNotShrinkToItselfOnValid, + shrinkDoesNotShrinkToItselfOnValidWithLimit, + doesNotShrinkToItself, + doesNotShrinkToItselfWithLimit, + ) +where import Data.GenValidity - import Test.QuickCheck -- | -- -- prop> shrinkPreservesValidOnGenValid ((:[]) :: Int -> [Int]) shrinkPreservesValidOnGenValid :: - forall a. (Show a, GenValid a) - => (a -> [a]) - -> Property + 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 + 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 + 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 + 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 + shrinkingPreservesWithLimit gen s l isValid -- | -- -- prop> shrinkingPreserves (pure 5 :: Gen Int) (:[]) (== 5) shrinkingPreserves :: - forall a. Show a - => Gen a - -> (a -> [a]) - -> (a -> Bool) - -> Property + 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 + 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) + forAll gen $ \d -> not (p d) || all p (take l $ s d) -- | -- --- prop> shrinkDoesNotShrinkToItself (shrinkUnchecked :: Double -> [Double]) +-- prop> shrinkDoesNotShrinkToItself (shrinkValid :: Double -> [Double]) shrinkDoesNotShrinkToItself :: - forall a. (Show a, Eq a, GenUnchecked a) - => (a -> [a]) - -> Property -shrinkDoesNotShrinkToItself = doesNotShrinkToItself genUnchecked + forall a. + (Show a, Eq a, GenValid a) => + (a -> [a]) -> + Property +shrinkDoesNotShrinkToItself = doesNotShrinkToItself genValid -- | -- --- prop> shrinkDoesNotShrinkToItselfWithLimit (shrinkUnchecked :: Double -> [Double]) 100 +-- prop> shrinkDoesNotShrinkToItselfWithLimit (shrinkValid :: Double -> [Double]) 100 shrinkDoesNotShrinkToItselfWithLimit :: - forall a. (Show a, Eq a, GenUnchecked a) - => (a -> [a]) - -> Int - -> Property + forall a. + (Show a, Eq a, GenValid a) => + (a -> [a]) -> + Int -> + Property shrinkDoesNotShrinkToItselfWithLimit = - doesNotShrinkToItselfWithLimit genUnchecked + doesNotShrinkToItselfWithLimit genValid -- | -- -- prop> shrinkDoesNotShrinkToItselfOnValid (shrinkValid :: Rational -> [Rational]) shrinkDoesNotShrinkToItselfOnValid :: - forall a. (Show a, Eq a, GenValid a) - => (a -> [a]) - -> Property + 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 + 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 + doesNotShrinkToItselfWithLimit genValid -- | -- --- prop> doesNotShrinkToItself (pure 5 :: Gen Double) shrinkUnchecked +-- prop> doesNotShrinkToItself (pure 5 :: Gen Double) shrinkValid doesNotShrinkToItself :: - forall a. (Show a, Eq a) - => Gen a - -> (a -> [a]) - -> Property -doesNotShrinkToItself gen s = forAll gen $ \a -> all (/= a) $ s a + forall a. + (Show a, Eq a) => + Gen a -> + (a -> [a]) -> + Property +doesNotShrinkToItself gen s = forAll gen $ \a -> notElem a $ s a -- | -- --- prop> doesNotShrinkToItselfWithLimit (pure 5 :: Gen Double) shrinkUnchecked 100 +-- prop> doesNotShrinkToItselfWithLimit (pure 5 :: Gen Double) shrinkValid 100 doesNotShrinkToItselfWithLimit :: - forall a. (Show a, Eq a) - => Gen a - -> (a -> [a]) - -> Int - -> Property + 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 + forAll gen $ \a -> notElem a $ take l $ s a diff --git a/src/Test/Syd/Validity/Types.hs b/src/Test/Syd/Validity/Types.hs --- a/src/Test/Syd/Validity/Types.hs +++ b/src/Test/Syd/Validity/Types.hs @@ -2,22 +2,23 @@ {-# LANGUAGE ScopedTypeVariables #-} module Test.Syd.Validity.Types - ( CanFail(..) - ) where + ( 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 + 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 + 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 + 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 --- a/src/Test/Syd/Validity/Utils.hs +++ b/src/Test/Syd/Validity/Utils.hs @@ -1,5 +1,4 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/test/Test/Syd/Validity/ApplicativeSpec.hs b/test/Test/Syd/Validity/ApplicativeSpec.hs --- a/test/Test/Syd/Validity/ApplicativeSpec.hs +++ b/test/Test/Syd/Validity/ApplicativeSpec.hs @@ -2,47 +2,44 @@ module Test.Syd.Validity.ApplicativeSpec where -import Test.Syd - import Data.GenValidity +import Test.Syd 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" + 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 --- a/test/Test/Syd/Validity/ArbitrarySpec.hs +++ b/test/Test/Syd/Validity/ArbitrarySpec.hs @@ -3,7 +3,6 @@ module Test.Syd.Validity.ArbitrarySpec where import Test.Syd - import Test.Syd.Validity.Arbitrary spec :: Spec diff --git a/test/Test/Syd/Validity/EqSpec.hs b/test/Test/Syd/Validity/EqSpec.hs --- a/test/Test/Syd/Validity/EqSpec.hs +++ b/test/Test/Syd/Validity/EqSpec.hs @@ -11,7 +11,7 @@ spec :: Spec spec = do - eqSpecOnValid @Rational + eqSpec @Rational eqSpec @Int -- eqSpec @Double DOES NOT HOLD because of NaN eqSpecOnArbitrary @Int diff --git a/test/Test/Syd/Validity/FunctorSpec.hs b/test/Test/Syd/Validity/FunctorSpec.hs --- a/test/Test/Syd/Validity/FunctorSpec.hs +++ b/test/Test/Syd/Validity/FunctorSpec.hs @@ -12,8 +12,6 @@ functorSpec @Maybe functorSpec @(Either Int) functorSpec @((,) Int) - functorSpecOnValid @[] - functorSpecOnValid @Maybe functorSpecOnArbitrary @[] functorSpecOnArbitrary @Maybe functorSpecOnGens diff --git a/test/Test/Syd/Validity/GenValiditySpec.hs b/test/Test/Syd/Validity/GenValiditySpec.hs --- a/test/Test/Syd/Validity/GenValiditySpec.hs +++ b/test/Test/Syd/Validity/GenValiditySpec.hs @@ -3,11 +3,9 @@ module Test.Syd.Validity.GenValiditySpec where import Test.Syd - import Test.Syd.Validity.GenValidity spec :: Spec spec = do - genValiditySpec @Rational - genValidSpec @Rational - genInvalidSpec @Rational + genValidSpec @Rational + genValidSpec @Rational diff --git a/test/Test/Syd/Validity/MonadSpec.hs b/test/Test/Syd/Validity/MonadSpec.hs --- a/test/Test/Syd/Validity/MonadSpec.hs +++ b/test/Test/Syd/Validity/MonadSpec.hs @@ -2,53 +2,50 @@ module Test.Syd.Validity.MonadSpec where -import Test.Syd - import Data.GenValidity +import Test.Syd 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" + monadSpec @[] + monadSpec @Maybe + monadSpec @(Either Int) + 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 --- a/test/Test/Syd/Validity/MonoidSpec.hs +++ b/test/Test/Syd/Validity/MonoidSpec.hs @@ -3,12 +3,11 @@ 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 []) + monoidSpec @[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 --- a/test/Test/Syd/Validity/Operations/CommutativitySpec.hs +++ b/test/Test/Syd/Validity/Operations/CommutativitySpec.hs @@ -1,13 +1,13 @@ {-# LANGUAGE TypeApplications #-} module Test.Syd.Validity.Operations.CommutativitySpec - ( spec - ) where + ( spec, + ) +where -import Test.Syd +import Data.GenValidity (GenValid) import Test.QuickCheck -import Data.GenValidity (GenUnchecked) - +import Test.Syd import Test.Syd.Validity.Operations.Commutativity (commutative) spec :: Spec @@ -20,7 +20,7 @@ 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 :: (Show a, Show b, Eq b, GenValid a) => (a -> a -> b) -> Property notCommmutative op = expectFailure (commutative op) type Point = (Int, Int) diff --git a/test/Test/Syd/Validity/OrdSpec.hs b/test/Test/Syd/Validity/OrdSpec.hs --- a/test/Test/Syd/Validity/OrdSpec.hs +++ b/test/Test/Syd/Validity/OrdSpec.hs @@ -8,7 +8,7 @@ spec :: Spec spec = do - ordSpecOnValid @Rational + ordSpec @Rational ordSpec @Int ordSpecOnArbitrary @Int ordSpecOnGen ((* 2) <$> genValid @Int) "even" (const []) diff --git a/test/Test/Syd/Validity/ShowSpec.hs b/test/Test/Syd/Validity/ShowSpec.hs --- a/test/Test/Syd/Validity/ShowSpec.hs +++ b/test/Test/Syd/Validity/ShowSpec.hs @@ -11,7 +11,7 @@ spec :: Spec spec = do - showReadSpecOnValid @Rational + showReadSpec @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 --- a/test/Test/Syd/Validity/ShrinkingSpec.hs +++ b/test/Test/Syd/Validity/ShrinkingSpec.hs @@ -9,20 +9,17 @@ spec :: Spec spec = do - shrinkValiditySpec @(Ratio Int8) + shrinkValidSpec @(Ratio Int8) shrinkValidSpec @Int - shrinkInvalidSpec @(Ratio Int8) - describe "shrinkUncheckedPreservesValidOnGenValid" $ do + describe "shrinkValidPreservesValidOnGenValid" $ 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 "Int" $ shrinkValidDoesNotShrinkToItself @Int + it "[Int]" $ shrinkValidDoesNotShrinkToItself @[Int] describe "shrinkValidDoesNotShrinkToItself" $ do it "Ordering" $ shrinkValidDoesNotShrinkToItself @Ordering it "[Ordering]" $ shrinkValidDoesNotShrinkToItself @[Ordering]