diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,77 @@ +# Changelog + +## [1.0.0.4] - 2022-10-04 + +### Changed + +* Compatibility with `hspec >= 2.11.10`. + +## [1.0.0.3] - 2022-10-04 + +### Changed + +* Compatibility with `hspec-core >= 2.11`. + +## [1.0.0.2] - 2022-09-20 + +Same as 1.0.0.1, but with the right commit. + +## [1.0.0.1] - 2022-09-02 + +### Changed + +* Compatibility with `hspec-core >= 2.10` + +## [1.0.0.0] - 2021-11-20 + +### Changed + +* Compatibility with `validity >= 0.12.0.0` +* 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. +* Everything related to `RelativeValidity`. + + +## [0.7.0.3] - 2020-02-10 + +### Changed + +* Removed doctests +* Improved the cabal file +* Fixed the `monadSpec` to not generate the list length using `genUnchecked` + +## [0.7.0.2] - 2019-09-23 + +* Removed nonsense shrinking from `genValidSpec` and `genInvalidSpec`. + +## [0.7.0.1] - 2019-09-23 + +* Removed nonsense shrinking from `arbitraryGeneratesOnlyValid`, `genValidGeneratesValid` and `genInvalidGeneratesInvalid`. + +## [0.7.0.0] - 2019-03-06 + +### Changed + +* Fixed compatibility with genvalidity >=0.8 + +## [0.6.2.3] - 2019-02-28 + +### Changed + +* Clearer docs + +## [0.6.2.2] - 2019-01-09 + +### Changed + +* Fixed a forward incompatibility with hspec 2.6.x. + +## [0.3.0.1] - 2018-10-07 + +### Changed + +* Compatibility with validity >=0.9, genvalidity >=0.7 and genvalidity-property >=0.3 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ The MIT License (MIT) -Copyright (c) 2016 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,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/genvalidity-hspec.cabal b/genvalidity-hspec.cabal --- a/genvalidity-hspec.cabal +++ b/genvalidity-hspec.cabal @@ -1,64 +1,93 @@ -name: genvalidity-hspec -version: 0.2.0.5 -synopsis: Standard spec's for GenValidity instances -description: Please see README.md -homepage: https://github.com/NorfairKing/validity#readme -license: MIT -license-file: LICENSE -author: Tom Sydney Kerckhove -maintainer: syd.kerckhove@gmail.com -copyright: Copyright: (c) 2016 Tom Sydney Kerckhove -category: Testing -build-type: Simple --- extra-source-files: -cabal-version: >=1.10 +cabal-version: 1.12 +-- This file has been generated from package.yaml by hpack version 0.36.1. +-- +-- see: https://github.com/sol/hpack + +name: genvalidity-hspec +version: 1.0.0.4 +synopsis: Standard spec's for GenValidity instances +description: Note: There are companion packages for this library: + . + * + . + * + . + * + . + * +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) 2016-2021 Tom Sydney Kerckhove +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + LICENSE + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/NorfairKing/validity + library - hs-source-dirs: src exposed-modules: Test.Validity - , Test.Validity.Arbitrary - , Test.Validity.Eq - , Test.Validity.Ord - , Test.Validity.Functions - , Test.Validity.Functions.CanFail - , Test.Validity.Functions.Equivalence - , Test.Validity.Functions.Idempotence - , Test.Validity.Functions.Inverse - , Test.Validity.Functions.Validity - , Test.Validity.GenValidity - , Test.Validity.GenRelativeValidity - , Test.Validity.Operations - , Test.Validity.Operations.Identity - , Test.Validity.Operations.Associativity - , Test.Validity.Operations.Commutativity - , Test.Validity.Relations - , Test.Validity.Relations.Antisymmetry - , Test.Validity.Relations.Reflexivity - , Test.Validity.Relations.Symmetry - , Test.Validity.Relations.Transitivity - , Test.Validity.RelativeValidity - , Test.Validity.Types - other-modules: + Test.Validity.Applicative + Test.Validity.Arbitrary + Test.Validity.Eq + Test.Validity.Functor + Test.Validity.GenValidity + Test.Validity.Monad + Test.Validity.Monoid + Test.Validity.Ord + Test.Validity.Show + Test.Validity.Shrinking Test.Validity.Utils - build-depends: base < 5 - , validity >= 0.3 && < 0.4 - , genvalidity - , QuickCheck - , hspec >= 2.2 && < 2.3 - default-language: Haskell2010 - + other-modules: + Paths_genvalidity_hspec + hs-source-dirs: + src + ghc-options: -Wall -fwarn-redundant-constraints + build-depends: + QuickCheck + , base >=4.9 && <5 + , genvalidity >=1.0 + , genvalidity-property >=0.5 + , hspec + , hspec-core >=2.5.0 + , transformers + , validity >=0.5 + default-language: Haskell2010 -test-suite genvalidity-hspec-doctests - default-language: Haskell2010 - hs-source-dirs: test - type: exitcode-stdio-1.0 - ghc-options: -threaded - main-is: DocTest.hs - build-depends: base - , doctest >= 0.11 && < 0.12 +test-suite genvalidity-hspec-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Test.Validity.ApplicativeSpec + Test.Validity.ArbitrarySpec + Test.Validity.EqSpec + Test.Validity.FunctorSpec + Test.Validity.GenRelativeValiditySpec + Test.Validity.GenValiditySpec + Test.Validity.MonadSpec + Test.Validity.MonoidSpec + Test.Validity.OrdSpec + Test.Validity.RelativeValiditySpec + Test.Validity.ShowSpec + Test.Validity.ShrinkingSpec + Paths_genvalidity_hspec + hs-source-dirs: + test/ + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + QuickCheck + , base >=4.9 && <5 + , genvalidity , genvalidity-hspec - -source-repository head - type: git - location: https://github.com/NorfairKing/validity + , hspec + , hspec-core >=2.5.0 + default-language: Haskell2010 diff --git a/src/Test/Validity.hs b/src/Test/Validity.hs --- a/src/Test/Validity.hs +++ b/src/Test/Validity.hs @@ -1,213 +1,268 @@ {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | To use the 'Spec' functions in this module, you will need @TypeApplications@. +-- +-- +-- The most interesting functions in this module for most uses are: +-- +-- * 'genValidSpec' +-- * 'eqSpec' +-- * 'ordSpec' +-- * 'producesValidsOnValids' +-- * 'forAllValid' +-- * 'shouldBeValid' module Test.Validity - ( module Data.GenValidity - , Proxy(Proxy) + ( -- * Writing properties - -- * Tests for Arbitrary instances involving Validity - , arbitrarySpec - , arbitraryGeneratesOnlyValid - , shrinkProducesOnlyValids + -- ** Cheap generation with shrinking + forAllValid, - -- * Tests for GenValidity instances - , genValiditySpec - , genValidityValidGeneratesValid - , genGeneratesValid - , genValidityInvalidGeneratesInvalid - , genGeneratesInvalid + -- ** Cheap assertions + shouldBeValid, + shouldBeInvalid, - -- * Tests for RelativeValidity instances - , relativeValiditySpec - , relativeValidityImpliesValidA - , relativeValidityImpliesValidB + -- * Tests for GenValidity instances + genValidSpec, + genValidGeneratesValid, + genGeneratesValid, + shrinkValidSpec, + shrinkValidSpecWithLimit, + shrinkValidPreservesValidOnGenValid, + shrinkPreservesValidOnGenValid, + shrinkValidPreservesValid, + shrinkingStaysValid, + shrinkingPreserves, - -- * Tests for GenRelativeValidity instances - , genRelativeValiditySpec - , genRelativeValidityValidGeneratesValid - , genRelativeValidityInvalidGeneratesInvalid + -- * Tests for Arbitrary instances involving Validity + arbitrarySpec, + arbitraryGeneratesOnlyValid, + -- * Standard tests involving functions - -- * Standard tests involving functions + -- ** Standard tests involving validity + producesValidsOnGen, + producesValid, + producesValidsOnArbitrary, + producesValidsOnGens2, + producesValid2, + producesValidsOnArbitrary2, + producesValidsOnGens3, + producesValid3, + producesValidsOnArbitrary3, - -- ** 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, + succeeds, + succeedsOnArbitrary, + succeedsOnGens2, + succeeds2, + succeedsOnArbitrary2, + failsOnGen, + failsOnGens2, + validIfSucceedsOnGen, + validIfSucceedsOnArbitrary, + validIfSucceeds, + validIfSucceedsOnGens2, + validIfSucceeds2, + validIfSucceedsOnArbitrary2, + validIfSucceedsOnGens3, + validIfSucceeds3, + validIfSucceedsOnArbitrary3, - -- ** Standard tests involving functions that can fail - , CanFail(..) + -- ** Standard tests involving equivalence of functions - , succeedsOnGen - , succeedsOnValid - , succeeds - , succeedsOnArbitrary + -- *** Simple functions - , succeedsOnGens2 - , succeedsOnValids2 - , succeeds2 - , succeedsOnArbitrary2 + -- **** One argument + equivalentOnGen, + equivalent, + equivalentOnArbitrary, - , failsOnGen - , failsOnInvalid + -- **** Two arguments + equivalentOnGens2, + equivalent2, + equivalentOnArbitrary2, - , failsOnGens2 - , failsOnInvalid2 + -- **** Three arguments + equivalentOnGens3, + equivalent3, + equivalentOnArbitrary3, - , validIfSucceedsOnGen - , validIfSucceedsOnValid - , validIfSucceedsOnArbitrary - , validIfSucceeds + -- *** First function can fail - , validIfSucceedsOnGens2 - , validIfSucceedsOnValids2 - , validIfSucceeds2 - , validIfSucceedsOnArbitrary2 + -- **** One argument + equivalentWhenFirstSucceedsOnGen, + equivalentWhenFirstSucceeds, + equivalentWhenFirstSucceedsOnArbitrary, - -- ** Standard tests involving equivalence of functions - , equivalentOnGen - , equivalentOnValid - , equivalent - , equivalentOnGens2 - , equivalentOnValids2 - , equivalent2 - , equivalentWhenFirstSucceedsOnGen - , equivalentWhenFirstSucceedsOnValid - , equivalentWhenFirstSucceeds - , equivalentWhenFirstSucceedsOnGens2 - , equivalentWhenFirstSucceedsOnValids2 - , equivalentWhenFirstSucceeds2 - , equivalentWhenSecondSucceedsOnGen - , equivalentWhenSecondSucceedsOnValid - , equivalentWhenSecondSucceeds - , equivalentWhenSecondSucceedsOnGens2 - , equivalentWhenSecondSucceedsOnValids2 - , equivalentWhenSecondSucceeds2 - , equivalentWhenSucceedOnGen - , equivalentWhenSucceedOnValid - , equivalentWhenSucceed - , equivalentWhenSucceedOnGens2 - , equivalentWhenSucceedOnValids2 - , equivalentWhenSucceed2 + -- **** Two arguments + equivalentWhenFirstSucceedsOnGens2, + equivalentWhenFirstSucceeds2, + equivalentWhenFirstSucceedsOnArbitrary2, - -- ** Standard tests involving inverse functions - , inverseFunctionsOnGen - , inverseFunctionsOnValid - , inverseFunctions - , inverseFunctionsOnArbitrary - , inverseFunctionsIfFirstSucceedsOnGen - , inverseFunctionsIfFirstSucceedsOnValid - , inverseFunctionsIfFirstSucceeds - , inverseFunctionsIfFirstSucceedsOnArbitrary - , inverseFunctionsIfSecondSucceedsOnGen - , inverseFunctionsIfSecondSucceedsOnValid - , inverseFunctionsIfSecondSucceeds - , inverseFunctionsIfSecondSucceedsOnArbitrary - , inverseFunctionsIfSucceedOnGen - , inverseFunctionsIfSucceedOnValid - , inverseFunctionsIfSucceed - , inverseFunctionsIfSucceedOnArbitrary + -- *** Second function can fail - -- ** Properties involving idempotence - , idempotentOnGen - , idempotentOnValid - , idempotent - , idempotentOnArbitrary + -- **** One argument + equivalentWhenSecondSucceedsOnGen, + equivalentWhenSecondSucceeds, + equivalentWhenSecondSucceedsOnArbitrary, + -- **** Two arguments + equivalentWhenSecondSucceedsOnGens2, + equivalentWhenSecondSucceeds2, + equivalentWhenSecondSucceedsOnArbitrary2, - -- * Properties of relations + -- *** Both functions can fail - -- ** Reflexivity - , reflexiveOnElem - , reflexivityOnGen - , reflexivityOnValid - , reflexivity - , reflexivityOnArbitrary + -- **** One argument + equivalentWhenSucceedOnGen, + equivalentWhenSucceed, + equivalentWhenSucceedOnArbitrary, - -- ** Transitivity - , transitiveOnElems - , transitivityOnGens - , transitivityOnValid - , transitivity - , transitivityOnArbitrary + -- **** Two arguments + equivalentWhenSucceedOnGens2, + equivalentWhenSucceed2, + equivalentWhenSucceedOnArbitrary2, - -- ** Antisymmetry - , antisymmetricOnElemsWithEquality - , antisymmetryOnGensWithEquality - , antisymmetryOnGensEq - , antisymmetryOnValid - , antisymmetry - , antisymmetryOnArbitrary + -- ** Standard tests involving inverse functions + inverseFunctionsOnGen, + inverseFunctions, + inverseFunctionsOnArbitrary, + inverseFunctionsIfFirstSucceedsOnGen, + inverseFunctionsIfFirstSucceeds, + inverseFunctionsIfFirstSucceedsOnArbitrary, + inverseFunctionsIfSecondSucceedsOnGen, + inverseFunctionsIfSecondSucceeds, + inverseFunctionsIfSecondSucceedsOnArbitrary, + inverseFunctionsIfSucceedOnGen, + inverseFunctionsIfSucceed, + inverseFunctionsIfSucceedOnArbitrary, - -- ** Symmetry - , symmetricOnElems - , symmetryOnGens - , symmetryOnValid - , symmetry - , symmetryOnArbitrary + -- ** Properties involving idempotence + idempotentOnGen, + idempotent, + idempotentOnArbitrary, + -- * Properties of relations - -- * Properties of operations + -- ** Reflexivity + reflexiveOnElem, + reflexivityOnGen, + reflexivity, + reflexivityOnArbitrary, - -- ** Identity element + -- ** Transitivity + transitiveOnElems, + transitivityOnGens, + transitivity, + transitivityOnArbitrary, - -- *** Left Identity - , leftIdentityOnElemWithEquality - , leftIdentityOnGenWithEquality - , leftIdentityOnGen - , leftIdentityOnValid - , leftIdentity + -- ** Antisymmetry + antisymmetricOnElemsWithEquality, + antisymmetryOnGensWithEquality, + antisymmetryOnGens, + antisymmetry, + antisymmetryOnArbitrary, - -- *** Right Identity - , rightIdentityOnElemWithEquality - , rightIdentityOnGenWithEquality - , rightIdentityOnGen - , rightIdentityOnValid - , rightIdentity + -- ** Antireflexivity + antireflexiveOnElem, + antireflexivityOnGen, + antireflexivity, + antireflexivityOnArbitrary, - -- *** Identity - , identityOnGen - , identityOnValid - , identity + -- ** Symmetry + symmetricOnElems, + symmetryOnGens, + symmetry, + symmetryOnArbitrary, - -- ** Associativity - , associativeOnGens - , associativeOnValids - , associative - , associativeOnArbitrary + -- * Properties of operations - -- ** Commutativity - , commutativeOnGens - , commutativeOnValids - , commutative - , commutativeOnArbitrary + -- ** Identity element + -- *** Left Identity + leftIdentityOnElemWithEquality, + leftIdentityOnGenWithEquality, + leftIdentityOnGen, + leftIdentity, + leftIdentityOnArbitrary, - -- * Eq properties - , eqSpec + -- *** Right Identity + rightIdentityOnElemWithEquality, + rightIdentityOnGenWithEquality, + rightIdentityOnGen, + rightIdentity, + rightIdentityOnArbitrary, - -- * Ord properties - , ordSpec - ) where + -- *** Identity + identityOnGen, + identity, + identityOnArbitrary, -import Data.GenValidity -import Data.Data + -- ** Associativity + associativeOnGens, + associative, + associativeOnArbitrary, -import Test.Validity.Arbitrary -import Test.Validity.Eq -import Test.Validity.Functions -import Test.Validity.GenRelativeValidity -import Test.Validity.GenValidity -import Test.Validity.Operations -import Test.Validity.Ord -import Test.Validity.Relations -import Test.Validity.RelativeValidity -import Test.Validity.Types + -- ** 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.Validity.Applicative +import Test.Validity.Arbitrary +import Test.Validity.Eq +import Test.Validity.Functions +import Test.Validity.Functor +import Test.Validity.GenValidity +import Test.Validity.Monad +import Test.Validity.Monoid +import Test.Validity.Operations +import Test.Validity.Ord +import Test.Validity.Property +import Test.Validity.Show +import Test.Validity.Shrinking +import Test.Validity.Utils diff --git a/src/Test/Validity/Applicative.hs b/src/Test/Validity/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Applicative.hs @@ -0,0 +1,296 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Applicative properties +-- +-- You will need @TypeApplications@ to use these. +module Test.Validity.Applicative + ( applicativeSpec, + applicativeSpecOnArbitrary, + applicativeSpecOnGens, + ) +where + +import Data.Data +import Data.GenValidity +import Data.Kind +import GHC.Stack +import Test.Hspec +import Test.QuickCheck +import Test.Validity.Functions +import Test.Validity.Utils + +{-# ANN module "HLint: ignore Avoid lambda" #-} + +pureTypeStr :: + forall (f :: Type -> Type). + (Typeable f) => + String +pureTypeStr = unwords ["pure", "::", "a", "->", nameOf @f, "a"] + +seqTypeStr :: + forall (f :: Type -> Type). + (Typeable f) => + String +seqTypeStr = + unwords + [ "(<*>)", + "::", + nameOf @f, + "(a", + "->", + "b)", + "->", + nameOf @f, + "a", + "->", + nameOf @f, + "b" + ] + +seqrTypeStr :: + forall (f :: Type -> Type). + (Typeable f) => + String +seqrTypeStr = + unwords + [ "(*>)", + "::", + nameOf @f, + "a", + "->", + nameOf @f, + "b", + "->", + nameOf @f, + "b" + ] + +seqlTypeStr :: + forall (f :: Type -> Type). + (Typeable f) => + String +seqlTypeStr = + unwords + [ "(<*)", + "::", + nameOf @f, + "a", + "->", + nameOf @f, + "b", + "->", + nameOf @f, + "a" + ] + +-- | Standard test spec for properties of Applicative instances for values generated with GenValid instances +-- +-- Example usage: +-- +-- > applicativeSpecOnArbitrary @[] +applicativeSpec :: + forall (f :: Type -> Type). + ( HasCallStack, + Eq (f Int), + Show (f Int), + Applicative f, + Typeable f, + GenValid (f Int) + ) => + Spec +applicativeSpec = withFrozenCallStack $ applicativeSpecWithInts @f genValid + +-- | Standard test spec for properties of Applicative instances for values generated with Arbitrary instances +-- +-- Example usage: +-- +-- > applicativeSpecOnArbitrary @[] +applicativeSpecOnArbitrary :: + forall (f :: Type -> Type). + ( HasCallStack, + Eq (f Int), + Show (f Int), + Applicative f, + Typeable f, + Arbitrary (f Int) + ) => + Spec +applicativeSpecOnArbitrary = withFrozenCallStack $ applicativeSpecWithInts @f arbitrary + +applicativeSpecWithInts :: + forall (f :: Type -> Type). + (HasCallStack, Show (f Int), Eq (f Int), Applicative f, Typeable f) => + Gen (f Int) -> + Spec +applicativeSpecWithInts gen = + withFrozenCallStack $ + 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). +-- +-- Unless you are building a specific regression test, you probably want to use the other 'applicativeSpec' functions. +-- +-- Example usage: +-- +-- > applicativeSpecOnGens +-- > @Maybe +-- > @String +-- > (pure "ABC") +-- > "ABC" +-- > (Just <$> pure "ABC") +-- > "Just an ABC" +-- > (pure Nothing) +-- > "purely Nothing" +-- > ((++) <$> genValid) +-- > "prepends" +-- > (pure <$> ((++) <$> genValid)) +-- > "prepends in a Just" +-- > (pure <$> (flip (++) <$> genValid)) +-- > "appends in a Just" +applicativeSpecOnGens :: + forall (f :: Type -> Type) (a :: Type) (b :: Type) (c :: Type). + ( HasCallStack, + 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 = + withFrozenCallStack $ + parallel $ + describe ("Applicative " ++ nameOf @f) $ do + describe (unwords [pureTypeStr @f, "and", seqTypeStr @f]) $ do + it + ( unwords + [ "satisfy the identity law: 'pure id <*> v = v' for", + genDescr @(f a) genname + ] + ) + $ equivalentOnGen (pure id <*>) id gen shrinkNothing + it + ( unwords + [ "satisfy the composition law: 'pure (.) <*> u <*> v <*> w = u <*> (v <*> w)' for", + genDescr @(f (b -> c)) genffbname, + "composed with", + genDescr @(f (a -> b)) genffaname, + "and applied to", + genDescr @(f a) genname + ] + ) + $ equivalentOnGens3 + ( \(Anon u) (Anon v) w -> + pure (.) + <*> (u :: f (b -> c)) + <*> (v :: f (a -> b)) + <*> (w :: f a) :: + f c + ) + (\(Anon u) (Anon v) w -> u <*> (v <*> w) :: f c) + ((,,) <$> (Anon <$> genffb) <*> (Anon <$> genffa) <*> gen) + shrinkNothing + it + ( unwords + [ "satisfy the homomorphism law: 'pure f <*> pure x = pure (f x)' for", + genDescr @(a -> b) genfaname, + "sequenced with", + genDescr @a genaname + ] + ) + $ equivalentOnGens2 + (\(Anon f) x -> pure f <*> pure x :: f b) + (\(Anon f) x -> pure $ f x :: f b) + ((,) <$> (Anon <$> genfa) <*> gena) + shrinkNothing + it + ( unwords + [ "satisfy the interchange law: 'u <*> pure y = pure ($ y) <*> u' for", + genDescr @(f (a -> b)) genffaname, + "sequenced with", + genDescr @a genaname + ] + ) + $ equivalentOnGens2 + (\(Anon u) y -> u <*> pure y :: f b) + (\(Anon u) y -> pure ($ y) <*> u :: f b) + ((,) <$> (Anon <$> genffa) <*> gena) + shrinkNothing + it + ( unwords + [ "satisfy the law about the functor instance: fmap f x = pure f <*> x for", + genDescr @(a -> b) genfaname, + "mapped over", + genDescr @(f a) genname + ] + ) + $ equivalentOnGens2 + (\(Anon f) x -> fmap f x) + (\(Anon f) x -> pure f <*> x) + ((,) <$> (Anon <$> genfa) <*> gen) + shrinkNothing + describe (seqrTypeStr @f) + $ it + ( unwords + [ "is equivalent to its default implementation 'u Type> v = pure (const id) <*> u <*> v' for", + genDescr @(f a) genname, + "in front of", + genDescr @b genbname + ] + ) + $ equivalentOnGens2 + (\u v -> u *> v) + (\u v -> pure (const id) <*> u <*> v) + ((,) <$> gen <*> genb) + shrinkNothing + describe (seqlTypeStr @f) + $ it + ( unwords + [ "is equivalent to its default implementation 'u <* v = pure const <*> u <*> v' for", + genDescr @b genbname, + "behind", + genDescr @(f a) genname + ] + ) + $ equivalentOnGens2 + (\u v -> u <* v) + (\u v -> pure const <*> u <*> v) + ((,) <$> gen <*> genb) + shrinkNothing diff --git a/src/Test/Validity/Arbitrary.hs b/src/Test/Validity/Arbitrary.hs --- a/src/Test/Validity/Arbitrary.hs +++ b/src/Test/Validity/Arbitrary.hs @@ -1,60 +1,46 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Arbitrary - ( -- * Tests for Arbitrary instances involving Validity - arbitrarySpec - , arbitraryGeneratesOnlyValid - , shrinkProducesOnlyValids - ) where - -import Data.Data -import Data.Proxy - -import Data.GenValidity +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -import Test.Hspec -import Test.QuickCheck +-- | Tests for Arbitrary instances involving Validity +-- +-- You will need @TypeApplications@ to use these. +module Test.Validity.Arbitrary + ( arbitrarySpec, + arbitraryGeneratesOnlyValid, + ) +where -import Test.Validity.Utils -import Test.Validity.GenValidity +import Data.Data +import Data.GenValidity +import Test.Hspec +import Test.QuickCheck +import Test.Validity.GenValidity +import Test.Validity.Utils -- | A @Spec@ that specifies that @arbitrary@ only generates data that --- satisfy @isValid@ and that @shrink@ only produces data that satisfy --- @isValid@. +-- satisfy @isValid@ -- -- Example usage: -- --- > arbitrarySpec (Proxy :: Proxy MyData) -arbitrarySpec - :: (Typeable a, Show a, Validity a, Arbitrary a) - => Proxy a - -> Spec -arbitrarySpec proxy = do - let name = nameOf proxy - describe ("Arbitrary " ++ name) $ do - it ("is instantiated such that 'arbitrary' only generates valid \'" - ++ name - ++ "\'s.") $ - arbitraryGeneratesOnlyValid proxy - - it ("is instantiated such that 'shrink' only produces valid \'" - ++ name - ++ "\'s.") $ - forAll arbitrary $ \a -> - shrink (a `asProxyTypeOf` proxy) `shouldSatisfy` all isValid +-- > arbitrarySpec @Int +arbitrarySpec :: + forall a. + (Typeable a, Show a, Validity a, Arbitrary a) => + Spec +arbitrarySpec = do + let name = nameOf @a + describe ("Arbitrary " ++ name) $ + describe ("arbitrary :: Gen " ++ name) $ + it "only generates valid values" $ + arbitraryGeneratesOnlyValid @a -- | @arbitrary@ only generates valid data -arbitraryGeneratesOnlyValid - :: forall a. (Show a, Validity a, Arbitrary a) - => Proxy a - -> Property -arbitraryGeneratesOnlyValid _ = - genGeneratesValid (arbitrary :: Gen a) - --- | @shrink@, applied to valid data only produces valid data -shrinkProducesOnlyValids - :: forall a. (Show a, Validity a, Arbitrary a) - => Proxy a - -> Property -shrinkProducesOnlyValids _ = - genGeneratesValid (shrink <$> arbitrary :: Gen [a]) +-- +-- prop> arbitraryGeneratesOnlyValid @Int +arbitraryGeneratesOnlyValid :: + forall a. + (Show a, Validity a, Arbitrary a) => + Property +arbitraryGeneratesOnlyValid = genGeneratesValid @a arbitrary diff --git a/src/Test/Validity/Eq.hs b/src/Test/Validity/Eq.hs --- a/src/Test/Validity/Eq.hs +++ b/src/Test/Validity/Eq.hs @@ -1,47 +1,130 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Eq - ( -- * Eq properties - eqSpec - ) where - -import Data.Data -import Data.Proxy +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -import Data.GenValidity +-- | Eq properties +-- +-- You will need @TypeApplications@ to use these. +module Test.Validity.Eq + ( eqSpec, + eqSpecOnArbitrary, + eqSpecOnGen, + ) +where -import Test.Hspec +import Data.Data +import Data.GenValidity +import Test.Hspec +import Test.QuickCheck +import Test.Validity.Functions +import Test.Validity.Relations +import Test.Validity.Utils -import Test.Validity.Relations -import Test.Validity.Utils +eqTypeStr :: + forall a. + (Typeable a) => + String +eqTypeStr = binRelStr @a "==" -eqSpec - :: (Show a, Eq a, Typeable a, GenValidity a) - => Proxy a - -> Spec -eqSpec proxy = do - let name = nameOf proxy - funeqstr = unwords - [ "(==) ::" - , name - , "->" - , name - , "-> Bool" - ] - eq a b = a `asProxyTypeOf` proxy == b - describe ("Eq " ++ name) $ do - it ("is instantated such that " - ++ funeqstr - ++ " is reflexive") $ - reflexivity eq +neqTypeStr :: + forall a. + (Typeable a) => + String +neqTypeStr = binRelStr @a "/=" - it ("is instantated such that " - ++ funeqstr - ++ " is symmetric") $ - symmetry eq +-- | Standard test spec for properties of Eq instances for valid values +-- +-- Example usage: +-- +-- > eqSpec @Int +eqSpec :: + forall a. + (Show a, Eq a, Typeable a, GenValid a) => + Spec +eqSpec = eqSpecOnGen @a genValid "valid" shrinkValid - it ("is instantated such that " - ++ funeqstr - ++ " is transitive") $ - transitivity eq +-- | Standard test spec for properties of Eq instances for arbitrary values +-- +-- Example usage: +-- +-- > eqSpecOnArbitrary @Int +eqSpecOnArbitrary :: + forall a. + (Show a, Eq a, Typeable a, Arbitrary a) => + Spec +eqSpecOnArbitrary = eqSpecOnGen @a arbitrary "arbitrary" shrink +-- | Standard test spec for properties of Eq instances for values generated by a given generator (and name for that generator). +-- +-- Example usage: +-- +-- > eqSpecOnGen ((* 2) <$> genValid @Int) "even" +eqSpecOnGen :: + forall a. + (Show a, Eq a, Typeable a) => + Gen a -> + String -> + (a -> [a]) -> + Spec +eqSpecOnGen gen genname s = + parallel $ do + let name = nameOf @a + funeqstr = eqTypeStr @a + funneqstr = neqTypeStr @a + gen2 = (,) <$> gen <*> gen + gen3 = (,,) <$> gen <*> gen <*> gen + s2 = shrinkT2 s + describe ("Eq " ++ name) $ do + let eq = (==) @a + neq = (/=) @a + describe funeqstr $ do + it + ( unwords + [ "is reflexive for", + "\"" ++ genname, + name ++ "\"" ++ "s" + ] + ) + $ reflexivityOnGen eq gen s + it + ( unwords + [ "is symmetric for", + "\"" ++ genname, + name ++ "\"" ++ "s" + ] + ) + $ symmetryOnGens eq gen2 s + it + ( unwords + [ "is transitive for", + "\"" ++ genname, + name ++ "\"" ++ "s" + ] + ) + $ transitivityOnGens eq gen3 s + it + ( unwords + [ "is equivalent to (\\a b -> not $ a /= b) for", + "\"" ++ genname, + name ++ "\"" ++ "s" + ] + ) + $ equivalentOnGens2 eq (\a b -> not $ a `neq` b) gen2 s2 + describe funneqstr $ do + it + ( unwords + [ "is antireflexive for", + "\"" ++ genname, + name ++ "\"" ++ "s" + ] + ) + $ antireflexivityOnGen neq gen s + it + ( unwords + [ "is equivalent to (\\a b -> not $ a == b) for", + "\"" ++ genname, + name ++ "\"" ++ "s" + ] + ) + $ equivalentOnGens2 neq (\a b -> not $ a `eq` b) gen2 s2 diff --git a/src/Test/Validity/Functions.hs b/src/Test/Validity/Functions.hs deleted file mode 100644 --- a/src/Test/Validity/Functions.hs +++ /dev/null @@ -1,103 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Functions - ( -- * Validity 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 - , succeedsOnGen - , succeedsOnValid - , succeeds - , succeedsOnArbitrary - - , succeedsOnGens2 - , succeedsOnValids2 - , succeeds2 - , succeedsOnArbitrary2 - - , failsOnGen - , failsOnInvalid - - , failsOnGens2 - , failsOnInvalid2 - - , validIfSucceedsOnGen - , validIfSucceedsOnValid - , validIfSucceedsOnArbitrary - , validIfSucceeds - - , validIfSucceedsOnGens2 - , validIfSucceedsOnValids2 - , validIfSucceeds2 - , validIfSucceedsOnArbitrary2 - - -- ** Standard tests involving equivalence of functions - , equivalentOnGen - , equivalentOnValid - , equivalent - , equivalentOnGens2 - , equivalentOnValids2 - , equivalent2 - , equivalentWhenFirstSucceedsOnGen - , equivalentWhenFirstSucceedsOnValid - , equivalentWhenFirstSucceeds - , equivalentWhenFirstSucceedsOnGens2 - , equivalentWhenFirstSucceedsOnValids2 - , equivalentWhenFirstSucceeds2 - , equivalentWhenSecondSucceedsOnGen - , equivalentWhenSecondSucceedsOnValid - , equivalentWhenSecondSucceeds - , equivalentWhenSecondSucceedsOnGens2 - , equivalentWhenSecondSucceedsOnValids2 - , equivalentWhenSecondSucceeds2 - , equivalentWhenSucceedOnGen - , equivalentWhenSucceedOnValid - , equivalentWhenSucceed - , equivalentWhenSucceedOnGens2 - , equivalentWhenSucceedOnValids2 - , equivalentWhenSucceed2 - - -- ** 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 - ) where - -import Test.Validity.Functions.CanFail -import Test.Validity.Functions.Equivalence -import Test.Validity.Functions.Idempotence -import Test.Validity.Functions.Inverse -import Test.Validity.Functions.Validity - diff --git a/src/Test/Validity/Functions/CanFail.hs b/src/Test/Validity/Functions/CanFail.hs deleted file mode 100644 --- a/src/Test/Validity/Functions/CanFail.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Functions.CanFail - ( -- ** Standard tests involving functions that can fail - succeedsOnGen - , succeedsOnValid - , succeeds - , succeedsOnArbitrary - - , succeedsOnGens2 - , succeedsOnValids2 - , succeeds2 - , succeedsOnArbitrary2 - - , failsOnGen - , failsOnInvalid - - , failsOnGens2 - , failsOnInvalid2 - - , validIfSucceedsOnGen - , validIfSucceedsOnValid - , validIfSucceedsOnArbitrary - , validIfSucceeds - - , validIfSucceedsOnGens2 - , validIfSucceedsOnValids2 - , validIfSucceeds2 - , validIfSucceedsOnArbitrary2 - ) where - -import Data.GenValidity - -import Test.Hspec -import Test.QuickCheck - -import Test.Validity.Types - --- | The function succeeds if the input is generated by the given generator -succeedsOnGen - :: (Show a, Show b, Show (f b), CanFail f) - => (a -> f b) - -> Gen a - -> Property -succeedsOnGen func gen - = forAll gen $ \a -> func a `shouldNotSatisfy` hasFailed - --- | The function succeeds if the input is generated by @genValid@ -succeedsOnValid - :: (Show a, Show b, Show (f b), GenValidity a, CanFail f) - => (a -> f b) - -> Property -succeedsOnValid = (`succeedsOnGen` genValid) - --- | The function succeeds if the input is generated by @genUnchecked@ -succeeds - :: (Show a, Show b, Show (f b), GenValidity a, CanFail f) - => (a -> f b) - -> Property -succeeds = (`succeedsOnGen` genUnchecked) - --- | The function succeeds if the input is generated by @arbitrary@ -succeedsOnArbitrary - :: (Show a, Show b, Show (f b), Arbitrary a, CanFail f) - => (a -> f b) - -> Property -succeedsOnArbitrary = (`succeedsOnGen` arbitrary) - --- | The function fails if the input is generated by the given generator -failsOnGen - :: (Show a, Show b, Show (f b), CanFail f) - => (a -> f b) - -> Gen a - -> Property -failsOnGen func gen - = forAll gen $ \a -> func a `shouldSatisfy` hasFailed - --- | The function fails if the input is generated by @genInvalid@ -failsOnInvalid - :: (Show a, Show b, Show (f b), GenValidity a, CanFail f) - => (a -> f b) - -> Property -failsOnInvalid = (`failsOnGen` genInvalid) - --- | The function produces output that satisfies @isValid@ if it is given input --- that is generated by the given generator. -validIfSucceedsOnGen - :: (Show a, Show b, Show (f b), Validity b, CanFail f) - => (a -> f b) - -> Gen a - -> Property -validIfSucceedsOnGen func gen - = forAll gen $ \a -> - case resultIfSucceeded (func a) of - Nothing -> return () -- Can happen - Just res -> res `shouldSatisfy` isValid - --- | The function produces output that satisfies @isValid@ if it is given input --- that is generated by @arbitrary@. -validIfSucceedsOnValid - :: (Show a, Show b, Show (f b), GenValidity a, Validity b, CanFail f) - => (a -> f b) - -> Property -validIfSucceedsOnValid = (`validIfSucceedsOnGen` genValid) - - --- | The function produces output that satisfies @isValid@ if it is given input --- that is generated by @arbitrary@. -validIfSucceedsOnArbitrary - :: (Show a, Show b, Show (f b), Arbitrary a, Validity b, CanFail f) - => (a -> f b) - -> Property -validIfSucceedsOnArbitrary = (`validIfSucceedsOnGen` arbitrary) - --- | The function produces output that satisfies @isValid@ if it is given input --- that is generated by @genUnchecked@. -validIfSucceeds - :: (Show a, Show b, Show (f b), GenValidity a, Validity b, CanFail f) - => (a -> f b) - -> Property -validIfSucceeds = (`validIfSucceedsOnGen` genUnchecked) - - -succeedsOnGens2 - :: (Show a, Show b, Show c, Show (f c), - CanFail f) - => (a -> b -> f c) - -> Gen (a, b) - -> Property -succeedsOnGens2 func gen = - forAll gen $ \(a, b) -> - func a b `shouldNotSatisfy` hasFailed - - -succeedsOnValids2 - :: (Show a, Show b, Show c, Show (f c), - GenValidity a, GenValidity b, - CanFail f) - => (a -> b -> f c) - -> Property -succeedsOnValids2 func - = succeedsOnGens2 func genValid - -succeeds2 - :: (Show a, Show b, Show c, Show (f c), - GenValidity a, GenValidity b, - CanFail f) - => (a -> b -> f c) - -> Property -succeeds2 func - = succeedsOnGens2 func genUnchecked - -succeedsOnArbitrary2 - :: (Show a, Show b, Show c, Show (f c), - Arbitrary a, Arbitrary b, - CanFail f) - => (a -> b -> f c) - -> Property -succeedsOnArbitrary2 func - = succeedsOnGens2 func arbitrary - - -failsOnGens2 - :: (Show a, Show b, Show c, Show (f c), - CanFail f) - => (a -> b -> f c) - -> Gen a -> Gen b - -> Property -failsOnGens2 func genA genB = - forAll genA $ \a -> - forAll genB $ \b -> - func a b `shouldSatisfy` hasFailed - - -failsOnInvalid2 - :: (Show a, Show b, Show c, Show (f c), - GenValidity a, GenValidity b, - CanFail f) - => (a -> b -> f c) - -> Property -failsOnInvalid2 func - = failsOnGens2 func genInvalid genUnchecked - .&&. failsOnGens2 func genUnchecked genInvalid - - -validIfSucceedsOnGens2 - :: (Show a, Show b, Show c, Show (f c), - Validity c, CanFail f) - => (a -> b -> f c) - -> Gen (a, b) - -> Property -validIfSucceedsOnGens2 func gen = - forAll gen $ \(a, b) -> - case resultIfSucceeded (func a b) of - Nothing -> return () -- Can happen - Just res -> res `shouldSatisfy` isValid - -validIfSucceedsOnValids2 - :: (Show a, Show b, Show c, Show (f c), - GenValidity a, GenValidity b, - Validity c, CanFail f) - => (a -> b -> f c) - -> Property -validIfSucceedsOnValids2 func - = validIfSucceedsOnGens2 func genValid - -validIfSucceeds2 - :: (Show a, Show b, Show c, Show (f c), - GenValidity a, GenValidity b, - Validity c, CanFail f) - => (a -> b -> f c) - -> Property -validIfSucceeds2 func - = validIfSucceedsOnGens2 func genUnchecked - -validIfSucceedsOnArbitrary2 - :: (Show a, Show b, Show c, Show (f c), - Arbitrary a, Arbitrary b, - Validity c, CanFail f) - => (a -> b -> f c) - -> Property -validIfSucceedsOnArbitrary2 func - = validIfSucceedsOnGens2 func arbitrary diff --git a/src/Test/Validity/Functions/Equivalence.hs b/src/Test/Validity/Functions/Equivalence.hs deleted file mode 100644 --- a/src/Test/Validity/Functions/Equivalence.hs +++ /dev/null @@ -1,295 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Functions.Equivalence - ( -- ** Standard tests involving equivalence of functions - equivalentOnGen - , equivalentOnValid - , equivalent - , equivalentOnGens2 - , equivalentOnValids2 - , equivalent2 - , equivalentWhenFirstSucceedsOnGen - , equivalentWhenFirstSucceedsOnValid - , equivalentWhenFirstSucceeds - , equivalentWhenFirstSucceedsOnGens2 - , equivalentWhenFirstSucceedsOnValids2 - , equivalentWhenFirstSucceeds2 - , equivalentWhenSecondSucceedsOnGen - , equivalentWhenSecondSucceedsOnValid - , equivalentWhenSecondSucceeds - , equivalentWhenSecondSucceedsOnGens2 - , equivalentWhenSecondSucceedsOnValids2 - , equivalentWhenSecondSucceeds2 - , equivalentWhenSucceedOnGen - , equivalentWhenSucceedOnValid - , equivalentWhenSucceed - , equivalentWhenSucceedOnGens2 - , equivalentWhenSucceedOnValids2 - , equivalentWhenSucceed2 - ) where - -import Data.GenValidity - -import Test.Hspec -import Test.QuickCheck - -import Test.Validity.Types - -equivalentOnGen - :: (Show a, Eq a, Show b, Eq b) - => (a -> b) - -> (a -> b) - -> Gen a - -> Property -equivalentOnGen f g gen = - forAll gen $ \a -> - f a `shouldBe` g a - -equivalentOnValid - :: (Show a, Eq a, GenValidity a, Show b, Eq b) - => (a -> b) - -> (a -> b) - -> Property -equivalentOnValid f g - = equivalentOnGen f g genValid - -equivalent - :: (Show a, Eq a, GenValidity a, Show b, Eq b) - => (a -> b) - -> (a -> b) - -> Property -equivalent f g - = equivalentOnGen f g genUnchecked - -equivalentOnGens2 - :: (Show a, Eq a, - Show b, Eq b, - Show c, Eq c) - => (a -> b -> c) - -> (a -> b -> c) - -> Gen (a, b) - -> Property -equivalentOnGens2 f g gen = - forAll gen $ \(a, b) -> - f a b `shouldBe` g a b - -equivalentOnValids2 - :: (Show a, Eq a, GenValidity a, - Show b, Eq b, GenValidity b, - Show c, Eq c) - => (a -> b -> c) - -> (a -> b -> c) - -> Property -equivalentOnValids2 f g - = equivalentOnGens2 f g genValid - -equivalent2 - :: (Show a, Eq a, GenValidity a, - Show b, Eq b, GenValidity b, - Show c, Eq c) - => (a -> b -> c) - -> (a -> b -> c) - -> Property -equivalent2 f g - = equivalentOnGens2 f g genUnchecked - -equivalentWhenFirstSucceedsOnGen - :: (Show a, Eq a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> b) - -> Gen a - -> Property -equivalentWhenFirstSucceedsOnGen f g gen = - forAll gen $ \a -> - case resultIfSucceeded (f a) of - Nothing -> return () -- fine - Just r -> r `shouldBe` g a - -equivalentWhenFirstSucceedsOnValid - :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> b) - -> Property -equivalentWhenFirstSucceedsOnValid f g - = equivalentWhenFirstSucceedsOnGen f g genValid - -equivalentWhenFirstSucceeds - :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> b) - -> Property -equivalentWhenFirstSucceeds f g - = equivalentWhenFirstSucceedsOnGen f g genUnchecked - -equivalentWhenFirstSucceedsOnGens2 - :: (Show a, Eq a, - Show b, Eq b, - Show c, Eq c, - CanFail f) - => (a -> b -> f c) - -> (a -> b -> c) - -> Gen (a, b) - -> Property -equivalentWhenFirstSucceedsOnGens2 f g gen = - forAll gen $ \(a, b) -> - case resultIfSucceeded (f a b) of - Nothing -> return () -- fine - Just rs -> rs `shouldBe` g a b - -equivalentWhenFirstSucceedsOnValids2 - :: (Show a, Eq a, GenValidity a, - Show b, Eq b, GenValidity b, - Show c, Eq c, - CanFail f) - => (a -> b -> f c) - -> (a -> b -> c) - -> Property -equivalentWhenFirstSucceedsOnValids2 f g - = equivalentWhenFirstSucceedsOnGens2 f g genValid - -equivalentWhenFirstSucceeds2 - :: (Show a, Eq a, GenValidity a, - Show b, Eq b, GenValidity b, - Show c, Eq c, - CanFail f) - => (a -> b -> f c) - -> (a -> b -> c) - -> Property -equivalentWhenFirstSucceeds2 f g - = equivalentWhenFirstSucceedsOnGens2 f g genUnchecked - -equivalentWhenSecondSucceedsOnGen - :: (Show a, Eq a, Show b, Eq b, CanFail f) - => (a -> b) - -> (a -> f b) - -> Gen a - -> Property -equivalentWhenSecondSucceedsOnGen f g gen = - forAll gen $ \a -> - case resultIfSucceeded (g a) of - Nothing -> return () -- fine - Just r -> r `shouldBe` f a - -equivalentWhenSecondSucceedsOnValid - :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f) - => (a -> b) - -> (a -> f b) - -> Property -equivalentWhenSecondSucceedsOnValid f g - = equivalentWhenSecondSucceedsOnGen f g genValid - -equivalentWhenSecondSucceeds - :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f) - => (a -> b) - -> (a -> f b) - -> Property -equivalentWhenSecondSucceeds f g - = equivalentWhenSecondSucceedsOnGen f g genUnchecked - -equivalentWhenSecondSucceedsOnGens2 - :: (Show a, Eq a, - Show b, Eq b, - Show c, Eq c, - CanFail f) - => (a -> b -> c) - -> (a -> b -> f c) - -> Gen (a, b) - -> Property -equivalentWhenSecondSucceedsOnGens2 f g gen = - forAll gen $ \(a, b) -> - case resultIfSucceeded (g a b) of - Nothing -> return () -- fine - Just rs -> rs `shouldBe` f a b - -equivalentWhenSecondSucceedsOnValids2 - :: (Show a, Eq a, GenValidity a, - Show b, Eq b, GenValidity b, - Show c, Eq c, - CanFail f) - => (a -> b -> c) - -> (a -> b -> f c) - -> Property -equivalentWhenSecondSucceedsOnValids2 f g - = equivalentWhenSecondSucceedsOnGens2 f g genValid - -equivalentWhenSecondSucceeds2 - :: (Show a, Eq a, GenValidity a, - Show b, Eq b, GenValidity b, - Show c, Eq c, - CanFail f) - => (a -> b -> c) - -> (a -> b -> f c) - -> Property -equivalentWhenSecondSucceeds2 f g - = equivalentWhenSecondSucceedsOnGens2 f g genUnchecked - -equivalentWhenSucceedOnGen - :: (Show a, Eq a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> f b) - -> Gen a - -> Property -equivalentWhenSucceedOnGen f g gen = - forAll gen $ \a -> - case do fa <- resultIfSucceeded $ f a - ga <- resultIfSucceeded $ g a - return (fa, ga) - of - Nothing -> return () -- fine - Just (fa, ga) -> fa `shouldBe` ga - -equivalentWhenSucceedOnValid - :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> f b) - -> Property -equivalentWhenSucceedOnValid f g - = equivalentWhenSucceedOnGen f g genValid - -equivalentWhenSucceed - :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f) - => (a -> f b) - -> (a -> f b) - -> Property -equivalentWhenSucceed f g - = equivalentWhenSucceedOnGen f g genUnchecked - -equivalentWhenSucceedOnGens2 - :: (Show a, Eq a, - Show b, Eq b, - Show c, Eq c, - CanFail f) - => (a -> b -> f c) - -> (a -> b -> f c) - -> Gen (a, b) - -> Property -equivalentWhenSucceedOnGens2 f g gen = - forAll gen $ \(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, Eq a, GenValidity a, - Show b, Eq b, GenValidity b, - Show c, Eq c, - CanFail f) - => (a -> b -> f c) - -> (a -> b -> f c) - -> Property -equivalentWhenSucceedOnValids2 f g - = equivalentWhenSucceedOnGens2 f g genValid - -equivalentWhenSucceed2 - :: (Show a, Eq a, GenValidity a, - Show b, Eq b, GenValidity b, - Show c, Eq c, - CanFail f) - => (a -> b -> f c) - -> (a -> b -> f c) - -> Property -equivalentWhenSucceed2 f g - = equivalentWhenSucceedOnGens2 f g genUnchecked diff --git a/src/Test/Validity/Functions/Idempotence.hs b/src/Test/Validity/Functions/Idempotence.hs deleted file mode 100644 --- a/src/Test/Validity/Functions/Idempotence.hs +++ /dev/null @@ -1,50 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Functions.Idempotence - ( -- ** Standard tests involving validity - idempotentOnGen - , idempotentOnValid - , idempotent - , idempotentOnArbitrary - ) where - -import Data.GenValidity - -import Test.Hspec -import Test.QuickCheck - -idempotentOnGen - :: (Show a, Eq a) - => (a -> a) - -> Gen a - -> Property -idempotentOnGen f gen - = forAll gen $ \a -> - f (f a) `shouldBe` f a - -idempotentOnValid - :: (Show a, Eq a, GenValidity a) - => (a -> a) - -> Property -idempotentOnValid func = idempotentOnGen func genValid - -idempotent - :: (Show a, Eq a, GenValidity a) - => (a -> a) - -> Property -idempotent func = idempotentOnGen func genUnchecked - --- | --- --- 'id' is idempotent for any type: --- --- prop> idempotentOnArbitrary (id :: Int -> Int) --- --- 'const', given any input, is idempotent for any type as well: --- --- prop> \int -> idempotentOnArbitrary (const int :: Int -> Int) -idempotentOnArbitrary - :: (Show a, Eq a, Arbitrary a) - => (a -> a) - -> Property -idempotentOnArbitrary func = idempotentOnGen func arbitrary diff --git a/src/Test/Validity/Functions/Inverse.hs b/src/Test/Validity/Functions/Inverse.hs deleted file mode 100644 --- a/src/Test/Validity/Functions/Inverse.hs +++ /dev/null @@ -1,185 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Functions.Inverse - ( -- ** Standard tests involving inverse functions - inverseFunctionsOnGen - , inverseFunctionsOnValid - , inverseFunctions - , inverseFunctionsOnArbitrary - , inverseFunctionsIfFirstSucceedsOnGen - , inverseFunctionsIfFirstSucceedsOnValid - , inverseFunctionsIfFirstSucceeds - , inverseFunctionsIfFirstSucceedsOnArbitrary - , inverseFunctionsIfSecondSucceedsOnGen - , inverseFunctionsIfSecondSucceedsOnValid - , inverseFunctionsIfSecondSucceeds - , inverseFunctionsIfSecondSucceedsOnArbitrary - , inverseFunctionsIfSucceedOnGen - , inverseFunctionsIfSucceedOnValid - , inverseFunctionsIfSucceed - , inverseFunctionsIfSucceedOnArbitrary - ) where - -import Data.GenValidity - -import Test.Hspec -import Test.QuickCheck - -import Test.Validity.Types - -inverseFunctionsOnGen - :: (Show a, Eq a) - => (a -> b) - -> (b -> a) - -> Gen a - -> Property -inverseFunctionsOnGen f g gen = - forAll gen $ \a -> - g (f a) `shouldBe` a - - -inverseFunctionsOnValid - :: (Show a, Eq a, GenValidity a) - => (a -> b) - -> (b -> a) - -> Property -inverseFunctionsOnValid f g - = inverseFunctionsOnGen f g genValid - - -inverseFunctions - :: (Show a, Eq a, GenValidity a) - => (a -> b) - -> (b -> a) - -> Property -inverseFunctions f g - = inverseFunctionsOnGen f g genUnchecked - --- | --- 'id' is its own inverse function for every type: --- prop> inverseFunctionsOnArbitrary id (id :: Int -> Int) -inverseFunctionsOnArbitrary - :: (Show a, Eq a, Arbitrary a) - => (a -> b) - -> (b -> a) - -> Property -inverseFunctionsOnArbitrary f g - = inverseFunctionsOnGen f g arbitrary - - -inverseFunctionsIfFirstSucceedsOnGen - :: (Show a, Eq a, CanFail f) - => (a -> f b) - -> (b -> a) - -> Gen a - -> Property -inverseFunctionsIfFirstSucceedsOnGen f g gen = - forAll gen $ \a -> - case resultIfSucceeded (f a) of - Nothing -> return () -- fine - Just b -> g b `shouldBe` a - - -inverseFunctionsIfFirstSucceedsOnValid - :: (Show a, Eq a, GenValidity a, CanFail f) - => (a -> f b) - -> (b -> a) - -> Property -inverseFunctionsIfFirstSucceedsOnValid f g - = inverseFunctionsIfFirstSucceedsOnGen f g genValid - - -inverseFunctionsIfFirstSucceeds - :: (Show a, Eq a, GenValidity a, CanFail f) - => (a -> f b) - -> (b -> a) - -> Property -inverseFunctionsIfFirstSucceeds f g - = inverseFunctionsIfFirstSucceedsOnGen f g genUnchecked - -inverseFunctionsIfFirstSucceedsOnArbitrary - :: (Show a, Eq a, Arbitrary a, CanFail f) - => (a -> f b) - -> (b -> a) - -> Property -inverseFunctionsIfFirstSucceedsOnArbitrary f g - = inverseFunctionsIfFirstSucceedsOnGen f g arbitrary - - -inverseFunctionsIfSecondSucceedsOnGen - :: (Show a, Eq a, CanFail f) - => (a -> b) - -> (b -> f a) - -> Gen a - -> Property -inverseFunctionsIfSecondSucceedsOnGen f g gen = - forAll gen $ \a -> - case resultIfSucceeded (g (f a)) of - Nothing -> return () -- fine - Just r -> r `shouldBe` a - - -inverseFunctionsIfSecondSucceedsOnValid - :: (Show a, Eq a, GenValidity a, CanFail f) - => (a -> b) - -> (b -> f a) - -> Property -inverseFunctionsIfSecondSucceedsOnValid f g - = inverseFunctionsIfSecondSucceedsOnGen f g genValid - - -inverseFunctionsIfSecondSucceeds - :: (Show a, Eq a, GenValidity a, CanFail f) - => (a -> b) - -> (b -> f a) - -> Property -inverseFunctionsIfSecondSucceeds f g - = inverseFunctionsIfSecondSucceedsOnGen f g genUnchecked - -inverseFunctionsIfSecondSucceedsOnArbitrary - :: (Show a, Eq a, Arbitrary a, CanFail f) - => (a -> b) - -> (b -> f a) - -> Property -inverseFunctionsIfSecondSucceedsOnArbitrary f g - = inverseFunctionsIfSecondSucceedsOnGen f g arbitrary - - -inverseFunctionsIfSucceedOnGen - :: (Show a, Eq a, CanFail f, CanFail g) - => (a -> f b) - -> (b -> g a) - -> Gen a - -> Property -inverseFunctionsIfSucceedOnGen f g gen = - forAll gen $ \a -> - case do fa <- resultIfSucceeded $ f a - resultIfSucceeded $ g fa - of - Nothing -> return () -- fine - Just r -> r `shouldBe` a - - -inverseFunctionsIfSucceedOnValid - :: (Show a, Eq a, GenValidity a, CanFail f, CanFail g) - => (a -> f b) - -> (b -> g a) - -> Property -inverseFunctionsIfSucceedOnValid f g - = inverseFunctionsIfSucceedOnGen f g genValid - -inverseFunctionsIfSucceed - :: (Show a, Eq a, GenValidity a, CanFail f, CanFail g) - => (a -> f b) - -> (b -> g a) - -> Property -inverseFunctionsIfSucceed f g - = inverseFunctionsIfSucceedOnGen f g genUnchecked - -inverseFunctionsIfSucceedOnArbitrary - :: (Show a, Eq a, Arbitrary a, CanFail f, CanFail g) - => (a -> f b) - -> (b -> g a) - -> Property -inverseFunctionsIfSucceedOnArbitrary f g - = inverseFunctionsIfSucceedOnGen f g arbitrary diff --git a/src/Test/Validity/Functions/Validity.hs b/src/Test/Validity/Functions/Validity.hs deleted file mode 100644 --- a/src/Test/Validity/Functions/Validity.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Functions.Validity - ( -- ** Standard tests involving validity - producesValidsOnGen - , producesValidsOnValids - , producesValid - , producesValidsOnArbitrary - , producesValidsOnGens2 - , producesValidsOnValids2 - , producesValid2 - , producesValidsOnArbitrary2 - , producesValidsOnGens3 - , producesValidsOnValids3 - , producesValid3 - , producesValidsOnArbitrary3 - ) where - -import Data.GenValidity - -import Test.Hspec -import Test.QuickCheck - --- | The function produces valid output when the input is generated as --- specified by the given generator. -producesValidsOnGen - :: (Show a, Show b, Validity b) - => (a -> b) - -> Gen a - -> Property -producesValidsOnGen func gen - = forAll gen $ \a -> func a `shouldSatisfy` isValid - --- | The function produces valid output when the input is generated by --- @arbitrary@ -producesValidsOnArbitrary - :: (Show a, Show b, Arbitrary a, Validity b) - => (a -> b) - -> Property -producesValidsOnArbitrary = (`producesValidsOnGen` arbitrary) - --- | The function produces valid output when the input is generated by --- @genUnchecked@ -producesValid - :: (Show a, Show b, GenValidity a, Validity b) - => (a -> b) - -> Property -producesValid = (`producesValidsOnGen` genUnchecked) - --- | The function produces valid output when the input is generated by --- @genValid@ -producesValidsOnValids - :: (Show a, Show b, GenValidity a, Validity b) - => (a -> b) - -> Property -producesValidsOnValids = (`producesValidsOnGen` genValid) - -producesValidsOnGens2 - :: (Show a, Show b, Show c, Validity c) - => (a -> b -> c) - -> Gen (a, b) - -> Property -producesValidsOnGens2 func gen - = forAll gen $ \(a, b) -> - func a b `shouldSatisfy` isValid - -producesValidsOnValids2 - :: (Show a, Show b, Show c, GenValidity a, GenValidity b, Validity c) - => (a -> b -> c) - -> Property -producesValidsOnValids2 func - = producesValidsOnGens2 func genValid - -producesValidsOnArbitrary2 - :: (Show a, Show b, Show c, Arbitrary a, Arbitrary b, Validity c) - => (a -> b -> c) - -> Property -producesValidsOnArbitrary2 func - = producesValidsOnGens2 func arbitrary - -producesValid2 - :: (Show a, Show b, Show c, GenValidity a, GenValidity b, Validity c) - => (a -> b -> c) - -> Property -producesValid2 func - = producesValidsOnGens2 func genUnchecked - -producesValidsOnGens3 - :: (Show a, Show b, Show c, Show d, Validity d) - => (a -> b -> c -> d) - -> Gen (a, b, c) - -> Property -producesValidsOnGens3 func gen - = forAll gen $ \(a, b, c) -> - func a b c `shouldSatisfy` isValid - -producesValid3 - :: (Show a, Show b, Show c, Show d, - GenValidity a, GenValidity b, GenValidity c, - Validity d) - => (a -> b -> c -> d) - -> Property -producesValid3 func - = producesValidsOnGens3 func genUnchecked - -producesValidsOnValids3 - :: (Show a, Show b, Show c, Show d, - GenValidity a, GenValidity b, GenValidity c, - Validity d) - => (a -> b -> c -> d) - -> Property -producesValidsOnValids3 func - = producesValidsOnGens3 func genValid - -producesValidsOnArbitrary3 - :: (Show a, Show b, Show c, Show d, - Arbitrary a, Arbitrary b, Arbitrary c, - Validity d) - => (a -> b -> c -> d) - -> Property -producesValidsOnArbitrary3 func - = producesValidsOnGens3 func arbitrary diff --git a/src/Test/Validity/Functor.hs b/src/Test/Validity/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Functor.hs @@ -0,0 +1,167 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Functor properties +-- +-- You will need @TypeApplications@ to use these. +module Test.Validity.Functor + ( functorSpec, + functorSpecOnArbitrary, + functorSpecOnGens, + ) +where + +import Data.Data +import Data.GenValidity +import Data.Kind +import Test.Hspec +import Test.QuickCheck +import Test.Validity.Functions +import Test.Validity.Utils + +{-# ANN module "HLint: ignore Functor law" #-} + +fmapTypeStr :: + forall (f :: Type -> Type). + (Typeable f) => + String +fmapTypeStr = + unwords + [ "fmap", + "::", + "(a", + "->", + "b)", + "->", + nameOf @f, + "a", + "->", + nameOf @f, + "b" + ] + +flTypeStr :: + forall (f :: Type -> Type). + (Typeable f) => + String +flTypeStr = + unwords ["(<$)", "::", "a", "->", nameOf @f, "b", "->", nameOf @f, "a"] + +-- | Standard test spec for properties of Functor instances for values generated with GenValid instances +-- +-- Example usage: +-- +-- > functorSpecOnArbitrary @[] +functorSpec :: + 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 +-- +-- Example usage: +-- +-- > functorSpecOnArbitrary @[] +functorSpecOnArbitrary :: + forall (f :: Type -> Type). + (Eq (f Int), Show (f Int), Functor f, Typeable f, Arbitrary (f Int)) => + Spec +functorSpecOnArbitrary = functorSpecWithInts @f arbitrary + +functorSpecWithInts :: + forall (f :: Type -> Type). + (Eq (f Int), Show (f Int), Functor f, Typeable f) => + Gen (f Int) -> + Spec +functorSpecWithInts gen = + functorSpecOnGens + @f + @Int + 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). +-- +-- Example usage: +-- +-- > functorSpecOnGens +-- > @[] +-- > @Int +-- > (pure 4) "four" +-- > (genListOf $ pure 5) "list of fives" +-- > ((+) <$> genValid) "additions" +-- > ((*) <$> genValid) "multiplications" +functorSpecOnGens :: + forall (f :: Type -> Type) (a :: Type) (b :: Type) (c :: Type). + ( Show a, + Show (f a), + Show (f c), + Eq (f a), + Eq (f c), + Functor f, + Typeable f, + Typeable a, + Typeable b, + Typeable c + ) => + Gen a -> + String -> + Gen (f a) -> + String -> + Gen (b -> c) -> + String -> + Gen (a -> b) -> + String -> + Spec +functorSpecOnGens gena genaname gen genname genf genfname geng gengname = + parallel $ + describe ("Functor " ++ nameOf @f) $ do + describe (fmapTypeStr @f) $ do + it + ( unwords + [ "satisfies the first Fuctor law: 'fmap id == id' for", + genDescr @(f a) genname + ] + ) + $ equivalentOnGen (fmap @f id) (id @(f a)) gen shrinkNothing + it + ( unwords + [ "satisfieds the second Functor law: 'fmap (f . g) == fmap f . fmap g' for", + genDescr @(f a) genname, + "'s", + "given to", + genDescr @(b -> c) genfname, + "and", + genDescr @(a -> b) gengname + ] + ) + $ forAll (Anon <$> genf) + $ \(Anon f) -> + forAll (Anon <$> geng) $ \(Anon g) -> + equivalentOnGen + (fmap (f . g)) + (fmap f . fmap g) + gen + shrinkNothing + describe (flTypeStr @f) + $ it + ( unwords + [ "is equivalent to its default implementation for", + genDescr @a genaname, + "and", + genDescr @(f a) genname + ] + ) + $ forAll gena + $ \a -> + equivalentOnGen (a <$) (fmap $ const a) gen shrinkNothing diff --git a/src/Test/Validity/GenRelativeValidity.hs b/src/Test/Validity/GenRelativeValidity.hs deleted file mode 100644 --- a/src/Test/Validity/GenRelativeValidity.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.GenRelativeValidity - ( -- * Tests for GenRelativeValidity instances - genRelativeValiditySpec - , genRelativeValidityValidGeneratesValid - , genRelativeValidityInvalidGeneratesInvalid - ) where - -import Data.Data -import Data.Proxy - -import Data.GenRelativeValidity -import Data.GenValidity - -import Test.Hspec -import Test.QuickCheck - -import Test.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 (proxy :: MyDataFor) (proxy :: MyOtherData) -genRelativeValiditySpec - :: (Typeable a, Typeable b, - Show a, Show b, - GenValidity a, GenValidity b, - RelativeValidity a b, - GenRelativeValidity a b) - => Proxy a - -> Proxy b - -> Spec -genRelativeValiditySpec one two = do - let nameOne = nameOf one - let nameTwo = nameOf two - describe ("GenRelativeValidity " ++ nameOne ++ " " ++ nameTwo) $ do - describe ("genValidFor :: " ++ nameTwo ++ " -> Gen " ++ nameOne) $ - it ("only generates valid \'" - ++ nameOne - ++ "\'s for the " - ++ nameTwo) $ - genRelativeValidityValidGeneratesValid one two - - describe ("genInvalidFor :: " ++ nameTwo ++ " -> Gen " ++ nameOne) $ - it ("only generates invalid \'" - ++ nameOne - ++ "\'s for the " - ++ nameTwo) $ - genRelativeValidityInvalidGeneratesInvalid one two - --- | @genValidFor b@ only generates values that satisfy @isValidFor b@ -genRelativeValidityValidGeneratesValid - :: (Show a, Show b, - GenValidity a, GenValidity b, - RelativeValidity a b, - GenRelativeValidity a b) - => Proxy a - -> Proxy b - -> Property -genRelativeValidityValidGeneratesValid one two = - forAll genValid $ \b -> - forAll (genValidFor b) $ \a -> - (a `asProxyTypeOf` one) - `shouldSatisfy` (`isValidFor` (b `asProxyTypeOf` two)) - --- | @genInvalidFor b@ only generates values that do not satisfy @isValidFor b@ -genRelativeValidityInvalidGeneratesInvalid - :: (Show a, Show b, - GenValidity a, GenValidity b, - RelativeValidity a b, - GenRelativeValidity a b) - => Proxy a - -> Proxy b - -> Property -genRelativeValidityInvalidGeneratesInvalid one two = - forAll genUnchecked $ \b -> - forAll (genInvalidFor b) $ \a -> - (a `asProxyTypeOf` one) - `shouldNotSatisfy` (`isValidFor` (b `asProxyTypeOf` two)) diff --git a/src/Test/Validity/GenValidity.hs b/src/Test/Validity/GenValidity.hs --- a/src/Test/Validity/GenValidity.hs +++ b/src/Test/Validity/GenValidity.hs @@ -1,77 +1,60 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.GenValidity - ( -- * Tests for GenValidity instances - genValiditySpec - , genValidityValidGeneratesValid - , genGeneratesValid - , genValidityInvalidGeneratesInvalid - , genGeneratesInvalid - ) where - -import Data.Data - -import Data.GenValidity +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -import Test.Hspec -import Test.QuickCheck +-- | Tests for GenValidity instances +-- +-- You will need @TypeApplications@ to use these. +module Test.Validity.GenValidity + ( genValidSpec, + genValidGeneratesValid, + genGeneratesValid, + genGeneratesInvalid, + ) +where -import Test.Validity.Utils +import Data.Data +import Data.GenValidity +import Test.Hspec +import Test.QuickCheck +import Test.Validity.GenValidity.Property +import Test.Validity.Utils --- | A @Spec@ that specifies that @genValid@ only generates valid data and that --- @genInvalid@ only generates invalid data. +-- | A @Spec@ that specifies that @genValid@ only generates valid data. -- -- In general it is a good idea to add this spec to your test suite if you --- write a custom implementation of @genValid@ or @genInvalid@. +-- write a custom implementation of @genValid@. -- -- Example usage: -- --- > genValiditySpec (Proxy :: Proxy MyData) -genValiditySpec - :: (Typeable a, Show a, GenValidity a) - => Proxy a - -> Spec -genValiditySpec proxy = do - let name = nameOf proxy - describe ("GenValidity " ++ name) $ do - describe ("genValid :: Gen " ++ name) $ - it ("only generates valid \'" ++ name ++ "\'s") $ - genValidityValidGeneratesValid proxy - - describe ("genInvalid :: Gen " ++ name) $ - it ("only generates invalid \'" ++ name ++ "\'s") $ - genValidityInvalidGeneratesInvalid proxy +-- > genValidSpec @Int +genValidSpec :: + forall a. + (Typeable a, Show a, GenValid a) => + Spec +genValidSpec = + parallel $ do + let name = nameOf @a + describe ("GenValid " ++ name) $ + describe ("genValid :: Gen " ++ name) $ + it ("only generates valid \'" ++ name ++ "\'s") $ + genValidGeneratesValid @a -- | @genValid@ only generates valid data -genValidityValidGeneratesValid - :: forall a. (Show a, GenValidity a) - => Proxy a - -> Property -genValidityValidGeneratesValid _ = - genGeneratesValid (genValid :: Gen a) - --- | The given generator generates only valid data points -genGeneratesValid - :: (Show a, Validity a) - => Gen a - -> Property -genGeneratesValid gen = - forAll gen (`shouldSatisfy` isValid) - - --- | @genValid@ only generates invalid data -genValidityInvalidGeneratesInvalid - :: forall a. (Show a, GenValidity a) - => Proxy a - -> Property -genValidityInvalidGeneratesInvalid _ = - genGeneratesInvalid (genInvalid :: Gen a) - --- | The given generator generates only invalid data points -genGeneratesInvalid - :: (Show a, Validity a) - => Gen a - -> Property -genGeneratesInvalid gen = - forAll gen (`shouldNotSatisfy` isValid) - +-- +-- prop> genValidGeneratesValid @() +-- prop> genValidGeneratesValid @Bool +-- prop> genValidGeneratesValid @Ordering +-- prop> genValidGeneratesValid @Char +-- prop> genValidGeneratesValid @Int +-- prop> genValidGeneratesValid @Float +-- prop> genValidGeneratesValid @Double +-- prop> genValidGeneratesValid @Integer +-- prop> genValidGeneratesValid @(Maybe Int) +-- prop> genValidGeneratesValid @[Int] +genValidGeneratesValid :: + forall a. + (Show a, GenValid a) => + Property +genValidGeneratesValid = genGeneratesValid @a genValid diff --git a/src/Test/Validity/Monad.hs b/src/Test/Validity/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Monad.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Monad properties +-- +-- You will need @TypeApplications@ to use these. +module Test.Validity.Monad + ( monadSpec, + monadSpecOnArbitrary, + monadSpecOnGens, + ) +where + +import Control.Monad (ap) +import Data.Data +import Data.GenValidity +import Data.Kind (Type) +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Gen (unGen) +import Test.QuickCheck.Random (mkQCGen) +import Test.Validity.Functions +import Test.Validity.Utils + +{-# ANN module "HLint: ignore Use fmap" #-} + +{-# ANN module "HLint: ignore Use <$>" #-} + +{-# ANN module "HLint: ignore Use >=>" #-} + +{-# ANN module "HLint: ignore Use id" #-} + +{-# ANN module "HLint: ignore Monad law, left identity" #-} + +{-# ANN module "HLint: ignore Monad law, right identity" #-} + +{-# ANN module "HLint: ignore Avoid lambda" #-} + +{-# ANN module "HLint: ignore Reduce duplication" #-} + +returnTypeStr :: + forall (m :: Type -> Type). + (Typeable m) => + String +returnTypeStr = unwords ["return", "::", "a", "->", nameOf @m, "a"] + +bindTypeStr :: + forall (m :: Type -> Type). + (Typeable m) => + String +bindTypeStr = + unwords + [ "(>>=)", + "::", + nameOf @m, + "a", + "->", + "(b", + "->", + nameOf @m, + "a)", + "->", + nameOf @m, + "b" + ] + +-- | Standard test spec for properties of Monad instances for values generated with GenValid instances +-- +-- Example usage: +-- +-- > monadSpec @[] +monadSpec :: + 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 +-- +-- Example usage: +-- +-- > monadSpecOnArbitrary @[] +monadSpecOnArbitrary :: + forall (f :: Type -> Type). + (Eq (f Int), Show (f Int), Monad f, Typeable f, Arbitrary (f Int)) => + Spec +monadSpecOnArbitrary = monadSpecWithInts @f arbitrary + +monadSpecWithInts :: + forall (f :: Type -> Type). + (Eq (f Int), Show (f Int), Monad f, Typeable f) => + Gen (f Int) -> + Spec +monadSpecWithInts gen = + monadSpecOnGens + @f + @Int + 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). +-- +-- Example usage: +-- +-- > monadSpecOnGens +-- > @[] +-- > @Int +-- > (pure 4) +-- > "four" +-- > (genListOf $ pure 5) +-- > "list of fives" +-- > (genListOf $ pure 6) +-- > "list of sixes" +-- > ((*) <$> genValid) +-- > "factorisations" +-- > (pure $ \a -> [a]) +-- > "singletonisation" +-- > (pure $ \a -> [a]) +-- > "singletonisation" +-- > (pure $ pure (+ 1)) +-- > "increment in list" +monadSpecOnGens :: + forall (f :: Type -> Type) (a :: Type) (b :: Type) (c :: Type). + ( Show a, + Show (f a), + Show (f b), + Show (f c), + Eq (f a), + Eq (f b), + Eq (f c), + Monad f, + Typeable f, + Typeable a, + Typeable b, + Typeable c + ) => + Gen a -> + String -> + Gen (f a) -> + String -> + Gen (f b) -> + String -> + Gen (a -> b) -> + String -> + Gen (a -> f b) -> + String -> + Gen (b -> f c) -> + String -> + Gen (f (a -> b)) -> + String -> + Spec +monadSpecOnGens gena genaname gen genname genb genbname geng gengname genbf genbfname gencf gencfname genfab genfabname = + parallel $ + describe ("Monad " ++ nameOf @f) $ do + describe (unwords [returnTypeStr @f, "and", bindTypeStr @f]) $ do + it + ( unwords + [ "satisfy the first Monad law: 'return a >>= k = k a' for", + genDescr @a genaname, + "and", + genDescr @(a -> f b) genbfname + ] + ) + $ equivalentOnGens2 + (\a (Anon k) -> return a >>= k) + (\a (Anon k) -> k a) + ((,) <$> gena <*> (Anon <$> genbf)) + shrinkNothing + it + ( unwords + [ "satisfy the second Monad law: 'm >>= return = m' for", + genDescr @(f a) genname + ] + ) + $ equivalentOnGen (\m -> m >>= return) (\m -> m) gen shrinkNothing + describe (bindTypeStr @f) + $ it + ( unwords + [ "satisfies the third Monad law: 'm >>= (x -> k x >>= h) = (m >>= k) >>= h' for", + genDescr @(f a) genname, + genDescr @(a -> f b) genbfname, + "and", + genDescr @(b -> f c) gencfname + ] + ) + $ equivalentOnGens3 + (\m (Anon k) (Anon h) -> m >>= (\x -> k x >>= h)) + (\m (Anon k) (Anon h) -> (m >>= k) >>= h) + ((,,) <$> gen <*> (Anon <$> genbf) <*> (Anon <$> gencf)) + shrinkNothing + describe (unwords ["relation with Applicative", nameOf @f]) $ do + it + ( unwords + ["satisfies 'pure = return' for", genDescr @(f a) genname] + ) + $ equivalentOnGen (pure @f) (return @f) gena shrinkNothing + it + ( unwords + [ "satisfies '(<*>) = ap' for", + genDescr @(f (a -> b)) genfabname, + "and", + genDescr @(f a) genname + ] + ) + $ equivalentOnGens2 + (\(Anon a) b -> a <*> b) + (\(Anon a) b -> ap a b) + ((,) <$> (Anon <$> genfab) <*> gen) + shrinkNothing + it + ( unwords + [ "satisfies '(>>) = (*>)' for", + genDescr @(f a) genname, + "and", + genDescr @(f b) genbname + ] + ) + $ equivalentOnGens2 (>>) (*>) ((,) <$> gen <*> genb) shrinkNothing + describe (unwords ["relation with Functor", nameOf @f]) + $ it + ( unwords + [ "satisfies 'fmap f xs = xs >>= return . f' for", + genDescr @(a -> b) gengname, + "and", + genDescr @(f a) genname + ] + ) + $ equivalentOnGens2 + (\(Anon f) xs -> fmap f xs) + (\(Anon f) xs -> xs >>= (return . f)) + ((,) <$> (Anon <$> geng) <*> gen) + shrinkNothing diff --git a/src/Test/Validity/Monoid.hs b/src/Test/Validity/Monoid.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Monoid.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Monoid properties +-- +-- You will need @TypeApplications@ to use these. +module Test.Validity.Monoid + ( monoidSpecOnValid, + monoidSpec, + monoidSpecOnArbitrary, + monoidSpecOnGen, + ) +where + +import Data.Data +import Data.GenValidity +import Test.Hspec +import Test.QuickCheck +import Test.Validity.Functions +import Test.Validity.Operations +import Test.Validity.Utils + +memptyTypeStr :: + forall a. + (Typeable a) => + String +memptyTypeStr = unwords ["mempty", "::", nameOf @a] + +mappendTypeStr :: + forall a. + (Typeable a) => + String +mappendTypeStr = unwords ["mappend", "::", an, "->", an, "->", an] + where + an = nameOf @a + +mconcatTypeStr :: + forall a. + (Typeable a) => + String +mconcatTypeStr = unwords ["mconcat", "::", "[" ++ an ++ "]", "->", an] + where + an = nameOf @a + +-- | Standard test spec for properties of 'Monoid' instances for valid values +-- +-- Example usage: +-- +-- > monoidSpecOnValid @[Double] +monoidSpecOnValid :: + forall a. + (Show a, Eq a, Monoid a, Typeable a, GenValid a) => + Spec +monoidSpecOnValid = monoidSpecOnGen @a genValid "valid" shrinkValid + +-- | Standard test spec for properties of 'Monoid' instances for valid values +-- +-- Example usage: +-- +-- > monoidSpec @[Int] +monoidSpec :: + 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 +-- +-- Example usage: +-- +-- > monoidSpecOnArbitrary @[Int] +monoidSpecOnArbitrary :: + forall a. + (Show a, Eq a, Monoid a, Typeable a, Arbitrary a) => + Spec +monoidSpecOnArbitrary = monoidSpecOnGen @a arbitrary "arbitrary" shrink + +-- | Standard test spec for properties of Monoid instances for values generated by a given generator (and name for that generator). +-- +-- Example usage: +-- +-- > monoidSpecOnGen (pure "a") "singleton list of 'a'" +monoidSpecOnGen :: + forall a. + (Show a, Eq a, Monoid a, Typeable a) => + Gen a -> + String -> + (a -> [a]) -> + Spec +monoidSpecOnGen gen genname s = + parallel $ do + let name = nameOf @a + memptystr = memptyTypeStr @a + mappendstr = mappendTypeStr @a + mconcatstr = mconcatTypeStr @a + gen3 = (,,) <$> gen <*> gen <*> gen + s3 (a, b, c) = (,,) <$> s a <*> s b <*> s c + genl = genListOf gen + sl = shrinkList s + describe ("Monoid " ++ name) $ do + let mem = mempty @a + mapp = mappend @a + mcon = mconcat @a + describe memptystr + $ it + ( unwords + [ "is the identity for", + mappendstr, + "for", + genDescr @a genname + ] + ) + $ identityOnGen mapp mem gen s + describe mappendstr + $ it + ( unwords + [ "is an associative operation for", + genDescr @(a, a, a) genname + ] + ) + $ associativeOnGens mapp gen3 s3 + describe mconcatstr + $ it + ( unwords + [ "is equivalent to its default implementation for", + genDescr @[a] genname + ] + ) + $ equivalentOnGen mcon (foldr mapp mem) genl sl diff --git a/src/Test/Validity/Operations.hs b/src/Test/Validity/Operations.hs deleted file mode 100644 --- a/src/Test/Validity/Operations.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Operations - ( -- * Properties of operations - - -- ** Identity element - - -- *** Left identity - leftIdentityOnElemWithEquality - , leftIdentityOnGenWithEquality - , leftIdentityOnGen - , leftIdentityOnValid - , leftIdentity - - -- *** Right identity - , rightIdentityOnElemWithEquality - , rightIdentityOnGenWithEquality - , rightIdentityOnGen - , rightIdentityOnValid - , rightIdentity - - -- *** Identity - , identityOnGen - , identityOnValid - , identity - - -- ** Associativity - , associativeOnGens - , associativeOnValids - , associative - , associativeOnArbitrary - - -- ** Commutativity - , commutativeOnGens - , commutativeOnValids - , commutative - , commutativeOnArbitrary - ) where - -import Test.Validity.Operations.Identity -import Test.Validity.Operations.Associativity -import Test.Validity.Operations.Commutativity diff --git a/src/Test/Validity/Operations/Associativity.hs b/src/Test/Validity/Operations/Associativity.hs deleted file mode 100644 --- a/src/Test/Validity/Operations/Associativity.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Operations.Associativity - ( -- ** Associativity - associativeOnGens - , associativeOnValids - , associative - , associativeOnArbitrary - ) where - -import Data.GenValidity - -import Test.Hspec -import Test.QuickCheck - -associativeOnGens - :: (Show a, Eq a) - => (a -> a -> a) - -> Gen (a, a, a) - -> Property -associativeOnGens op gen = - forAll gen $ \(a, b, c) -> - ((a `op` b) `op` c) `shouldBe` (a `op` (b `op` c)) - -associativeOnValids - :: (Show a, Eq a, GenValidity a) - => (a -> a -> a) - -> Property -associativeOnValids op - = associativeOnGens op genValid - -associative - :: (Show a, Eq a, GenValidity a) - => (a -> a -> a) - -> Property -associative op - = associativeOnGens op genUnchecked - -associativeOnArbitrary - :: (Show a, Eq a, Arbitrary a) - => (a -> a -> a) - -> Property -associativeOnArbitrary op - = associativeOnGens op arbitrary diff --git a/src/Test/Validity/Operations/Commutativity.hs b/src/Test/Validity/Operations/Commutativity.hs deleted file mode 100644 --- a/src/Test/Validity/Operations/Commutativity.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Operations.Commutativity - ( -- ** Commutativity - commutativeOnGens - , commutativeOnValids - , commutative - , commutativeOnArbitrary - ) where - -import Data.GenValidity - -import Test.Hspec -import Test.QuickCheck - -commutativeOnGens - :: (Show a, Eq a) - => (a -> a -> a) - -> Gen (a, a) - -> Property -commutativeOnGens op gen = - forAll gen $ \(a, b) -> - (a `op` b) `shouldBe` (b `op` a) - -commutativeOnValids - :: (Show a, Eq a, GenValidity a) - => (a -> a -> a) - -> Property -commutativeOnValids op - = commutativeOnGens op genValid - -commutative - :: (Show a, Eq a, GenValidity a) - => (a -> a -> a) - -> Property -commutative op - = commutativeOnGens op genUnchecked - -commutativeOnArbitrary - :: (Show a, Eq a, Arbitrary a) - => (a -> a -> a) - -> Property -commutativeOnArbitrary op - = commutativeOnGens op arbitrary diff --git a/src/Test/Validity/Operations/Identity.hs b/src/Test/Validity/Operations/Identity.hs deleted file mode 100644 --- a/src/Test/Validity/Operations/Identity.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Operations.Identity - ( -- *** Left identity - leftIdentityOnElemWithEquality - , leftIdentityOnGenWithEquality - , leftIdentityOnGen - , leftIdentityOnValid - , leftIdentity - - -- *** Right identity - , rightIdentityOnElemWithEquality - , rightIdentityOnGenWithEquality - , rightIdentityOnGen - , rightIdentityOnValid - , rightIdentity - - , identityOnGen - , identityOnValid - , identity - ) where - -import Data.GenValidity - -import Test.QuickCheck - --- | --- --- \[ --- LeftIdentity(\star, \doteq, b) --- \quad\equiv\quad --- \forall a: (b \star a) \doteq a --- \] -leftIdentityOnElemWithEquality - :: (b -> a -> a) -- ^ A binary operation - -> (a -> a -> Bool) -- ^ An equality - -> b -- ^ A candidate left-identity - -> a -- ^ An element - -> Bool -leftIdentityOnElemWithEquality op eq b a = (b `op` a) `eq` a - -leftIdentityOnGenWithEquality - :: Show a - => (b -> a -> a) -- ^ A binary operation - -> (a -> a -> Bool) -- ^ An equality - -> b -- ^ A candidate left-identity - -> Gen a - -> Property -leftIdentityOnGenWithEquality op eq b gen = - forAll gen $ leftIdentityOnElemWithEquality op eq b - -leftIdentityOnGen - :: (Show a, Eq a) - => (b -> a -> a) -- ^ A binary operation - -> b -- ^ A candidate left-identity - -> Gen a - -> Property -leftIdentityOnGen op = leftIdentityOnGenWithEquality op (==) - -leftIdentityOnValid - :: (Show a, Eq a, GenValidity a) - => (b -> a -> a) - -> b - -> Property -leftIdentityOnValid op b - = leftIdentityOnGen op b genValid - -leftIdentity - :: (Show a, Eq a, GenValidity a) - => (b -> a -> a) - -> b - -> Property -leftIdentity op b - = leftIdentityOnGen op b genUnchecked - --- | --- --- \[ --- RightIdentity(\star, \doteq, b) --- \quad\equiv\quad --- \forall a: (a \star b) \doteq a --- \] -rightIdentityOnElemWithEquality - :: (a -> b -> a) -- ^ A binary operation - -> (a -> a -> Bool) -- ^ An equality - -> b -- ^ A candidate right-identity - -> a -- ^ An element - -> Bool -rightIdentityOnElemWithEquality op eq b a = (a `op` b) `eq` a - -rightIdentityOnGenWithEquality - :: Show a - => (a -> b -> a) -- ^ A binary operation - -> (a -> a -> Bool) -- ^ An equality - -> b -- ^ A candidate right-identity - -> Gen a - -> Property -rightIdentityOnGenWithEquality op eq b gen = - forAll gen $ rightIdentityOnElemWithEquality op eq b - -rightIdentityOnGen - :: (Show a, Eq a) - => (a -> b -> a) -- ^ A binary operation - -> b -- ^ A candidate right-identity - -> Gen a - -> Property -rightIdentityOnGen op = rightIdentityOnGenWithEquality op (==) - -rightIdentityOnValid - :: (Show a, Eq a, GenValidity a) - => (a -> b -> a) - -> b - -> Property -rightIdentityOnValid op b - = rightIdentityOnGen op b genValid - -rightIdentity - :: (Show a, Eq a, GenValidity a) - => (a -> b -> a) - -> b - -> Property -rightIdentity op b - = rightIdentityOnGen op b genUnchecked - -identityOnGen - :: (Show a, Eq a) - => (a -> a -> a) - -> a - -> Gen a - -> Property -identityOnGen op e gen = - leftIdentityOnGen op e gen .&&. rightIdentityOnGen op e gen - -identityOnValid - :: (Show a, Eq a, GenValidity a) - => (a -> a -> a) - -> a - -> Property -identityOnValid op a - = identityOnGen op a genValid - -identity - :: (Show a, Eq a, GenValidity a) - => (a -> a -> a) - -> a - -> Property -identity op e - = identityOnGen op e genUnchecked diff --git a/src/Test/Validity/Ord.hs b/src/Test/Validity/Ord.hs --- a/src/Test/Validity/Ord.hs +++ b/src/Test/Validity/Ord.hs @@ -1,46 +1,150 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Ord properties +-- +-- You will need @TypeApplications@ to use these. module Test.Validity.Ord - ( -- * Ord properties - ordSpec - ) where + ( ordSpec, + ordSpecOnGen, + ordSpecOnArbitrary, + ) +where -import Data.Data -import Data.Proxy +import Data.Data +import Data.GenValidity +import Test.Hspec +import Test.QuickCheck +import Test.Validity.Functions +import Test.Validity.Relations +import Test.Validity.Utils -import Data.GenValidity +{-# ANN module "HLint: ignore Use <=" #-} -import Test.Hspec +{-# ANN module "HLint: ignore Use >=" #-} -import Test.Validity.Relations -import Test.Validity.Utils +{-# ANN module "HLint: ignore Use <" #-} -ordSpec - :: (Show a, Eq a, Ord a, Typeable a, GenValidity a) - => Proxy a - -> Spec -ordSpec proxy = do - let name = nameOf proxy - funlestr = unwords - [ "(<=) ::" - , name - , "->" - , name - , "-> Ordering" - ] - cmp a b = a `asProxyTypeOf` proxy <= b - describe ("Ord " ++ name) $ do - it ("is instantated such that " - ++ funlestr - ++ " is reflexive") $ - reflexivity cmp +{-# ANN module "HLint: ignore Use >" #-} - it ("is instantated such that " - ++ funlestr - ++ " is antisymmetric") $ - antisymmetry cmp +leTypeStr :: + forall a. + (Typeable a) => + String +leTypeStr = binRelStr @a "<=" - it ("is instantated such that " - ++ funlestr - ++ " is transitive") $ - transitivity cmp +geTypeStr :: + forall a. + (Typeable a) => + String +geTypeStr = binRelStr @a ">=" + +ltTypeStr :: + forall a. + (Typeable a) => + String +ltTypeStr = binRelStr @a "<" + +gtTypeStr :: + forall a. + (Typeable a) => + String +gtTypeStr = binRelStr @a ">" + +-- | Standard test spec for properties of Ord instances for valid values +-- +-- Example usage: +-- +-- > ordSpec @Int +ordSpec :: + forall a. + (Show a, Ord a, Typeable a, GenValid a) => + Spec +ordSpec = ordSpecOnGen @a genValid "valid" shrinkValid + +-- | Standard test spec for properties of Ord instances for arbitrary values +-- +-- Example usage: +-- +-- > ordSpecOnArbitrary @Int +ordSpecOnArbitrary :: + forall a. + (Show a, Ord a, Typeable a, Arbitrary a) => + Spec +ordSpecOnArbitrary = ordSpecOnGen @a arbitrary "arbitrary" shrink + +-- | Standard test spec for properties of Ord instances for values generated by a given generator (and name for that generator). +-- +-- Example usage: +-- +-- > ordSpecOnGen ((* 2) <$> genValid @Int) "even" +ordSpecOnGen :: + forall a. + (Show a, Ord a, Typeable a) => + Gen a -> + String -> + (a -> [a]) -> + Spec +ordSpecOnGen gen genname s = + parallel $ do + let name = nameOf @a + funlestr = leTypeStr @a + fungestr = geTypeStr @a + funltstr = ltTypeStr @a + fungtstr = gtTypeStr @a + minmaxtstr = genDescr @(a -> a -> a) + itProp s_ = + it $ + unwords + [ s_, + "\"" ++ genname, + name ++ "\"" ++ "'s" + ] + cmple = (<=) @a + cmpge = (>=) @a + cmplt = (<) @a + cmpgt = (>) @a + gen2 = (,) <$> gen <*> gen + gen3 = (,,) <$> gen <*> gen <*> gen + s2 = shrinkT2 s + describe ("Ord " ++ name) $ do + describe funlestr $ do + itProp "is reflexive for" $ + reflexivityOnGen cmple gen s + itProp "is antisymmetric for" $ + antisymmetryOnGens cmple gen2 s + itProp "is transitive for" $ + transitivityOnGens cmple gen3 s + itProp "is equivalent to (\\a b -> compare a b /= GT) for" $ + equivalentOnGens2 cmple (\a b -> compare a b /= GT) gen2 s2 + describe fungestr $ do + itProp "is reflexive for" $ + reflexivityOnGen cmpge gen s + itProp "is antisymmetric for" $ + antisymmetryOnGens cmpge gen2 s + itProp "is transitive for" $ + transitivityOnGens cmpge gen3 s + itProp "is equivalent to (\\a b -> compare a b /= LT) for" $ + equivalentOnGens2 cmpge (\a b -> compare a b /= LT) gen2 s2 + describe funltstr $ do + itProp "is antireflexive for" $ + antireflexivityOnGen cmplt gen s + itProp "is transitive for" $ + transitivityOnGens cmplt gen3 s + itProp "is equivalent to (\\a b -> compare a b == LT) for" $ + equivalentOnGens2 cmplt (\a b -> compare a b == LT) gen2 s2 + describe fungtstr $ do + itProp "is antireflexive for" $ + antireflexivityOnGen cmpgt gen s + itProp "is transitive for" $ + transitivityOnGens cmpgt gen3 s + itProp "is equivalent to (\\a b -> compare a b == GT) for" $ + equivalentOnGens2 cmpgt (\a b -> compare a b == GT) gen2 s2 + describe (minmaxtstr "min") $ do + itProp "is equivalent to (\\a b -> if a <= b then a else b) for" $ + equivalentOnGens2 min (\a b -> if a <= b then a else b) gen2 s2 + describe (minmaxtstr "max") $ do + itProp "is equivalent to (\\a b -> if a >= b then a else b) for" $ + equivalentOnGens2 max (\a b -> if a >= b then a else b) gen2 s2 diff --git a/src/Test/Validity/Relations.hs b/src/Test/Validity/Relations.hs deleted file mode 100644 --- a/src/Test/Validity/Relations.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Relations - ( - -- * Properties of relations - - -- ** Reflexivity - reflexiveOnElem - , reflexivityOnGen - , reflexivityOnValid - , reflexivity - , reflexivityOnArbitrary - - -- ** Transitivity - , transitiveOnElems - , transitivityOnGens - , transitivityOnValid - , transitivity - , transitivityOnArbitrary - - -- ** Antisymmetry - , antisymmetricOnElemsWithEquality - , antisymmetryOnGensWithEquality - , antisymmetryOnGensEq - , antisymmetryOnValid - , antisymmetry - , antisymmetryOnArbitrary - - -- ** Symmetry - , symmetricOnElems - , symmetryOnGens - , symmetryOnValid - , symmetry - , symmetryOnArbitrary - ) where - -import Test.Validity.Relations.Reflexivity -import Test.Validity.Relations.Antisymmetry -import Test.Validity.Relations.Symmetry -import Test.Validity.Relations.Transitivity - diff --git a/src/Test/Validity/Relations/Antisymmetry.hs b/src/Test/Validity/Relations/Antisymmetry.hs deleted file mode 100644 --- a/src/Test/Validity/Relations/Antisymmetry.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Relations.Antisymmetry - ( antisymmetricOnElemsWithEquality - , antisymmetryOnGensWithEquality - , antisymmetryOnGensEq - , antisymmetryOnValid - , antisymmetry - , antisymmetryOnArbitrary - ) where - -import Data.GenValidity - -import Test.QuickCheck - -import Test.Validity.Utils - --- | --- --- \[ --- Antisymmetric(\prec, \doteq) --- \quad\equiv\quad --- \forall a, b: ((a \prec b) \wedge (b \prec a)) \Rightarrow (a \doteq b) --- \] -antisymmetricOnElemsWithEquality - :: (a -> a -> Bool) -- ^ A relation - -> (a -> a -> Bool) -- ^ An equivalence relation - -> a -> a -- ^ Two elements - -> Bool -antisymmetricOnElemsWithEquality func eq a b = - (func a b && func b a) ===> (a `eq` b) - -antisymmetryOnGensWithEquality - :: Show a - => (a -> a -> Bool) - -> Gen (a, a) - -> (a -> a -> Bool) - -> Property -antisymmetryOnGensWithEquality func gen eq = - forAll gen $ uncurry $ antisymmetricOnElemsWithEquality func eq - -antisymmetryOnGensEq - :: (Show a, Eq a) - => (a -> a -> Bool) - -> Gen (a, a) - -> Property -antisymmetryOnGensEq func gen - = antisymmetryOnGensWithEquality func gen (==) - -antisymmetryOnValid - :: (Show a, Eq a, GenValidity a) - => (a -> a -> Bool) - -> Property -antisymmetryOnValid func = - antisymmetryOnGensEq func genValid - -antisymmetry - :: (Show a, Eq a, GenValidity a) - => (a -> a -> Bool) - -> Property -antisymmetry func = - antisymmetryOnGensEq func genUnchecked - --- | --- --- prop> antisymmetryOnArbitrary ((<=) :: Int -> Int -> Bool) -antisymmetryOnArbitrary - :: (Show a, Eq a, Arbitrary a) - => (a -> a -> Bool) - -> Property -antisymmetryOnArbitrary func = - antisymmetryOnGensEq func arbitrary diff --git a/src/Test/Validity/Relations/Reflexivity.hs b/src/Test/Validity/Relations/Reflexivity.hs deleted file mode 100644 --- a/src/Test/Validity/Relations/Reflexivity.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Relations.Reflexivity - ( reflexiveOnElem - , reflexivityOnGen - , reflexivityOnValid - , reflexivity - , reflexivityOnArbitrary - ) where - -import Data.GenValidity - -import Test.QuickCheck - --- | --- --- \[ --- Reflexive(prec) --- \quad\equiv\quad --- \forall a: (a \prec a) --- \] -reflexiveOnElem - :: (a -> a -> Bool) -- ^ A relation - -> a -- ^ An element - -> Bool -reflexiveOnElem func a = func a a - -reflexivityOnGen - :: Show a - => (a -> a -> Bool) - -> Gen a - -> Property -reflexivityOnGen func gen = - forAll gen $ reflexiveOnElem func - -reflexivityOnValid - :: (Show a, GenValidity a) - => (a -> a -> Bool) - -> Property -reflexivityOnValid func - = reflexivityOnGen func genValid - -reflexivity - :: (Show a, GenValidity a) - => (a -> a -> Bool) - -> Property -reflexivity func - = reflexivityOnGen func genUnchecked - --- | --- --- prop> reflexivityOnArbitrary ((==) :: Int -> Int -> Bool) -reflexivityOnArbitrary - :: (Show a, Arbitrary a) - => (a -> a -> Bool) - -> Property -reflexivityOnArbitrary func - = reflexivityOnGen func arbitrary diff --git a/src/Test/Validity/Relations/Symmetry.hs b/src/Test/Validity/Relations/Symmetry.hs deleted file mode 100644 --- a/src/Test/Validity/Relations/Symmetry.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Relations.Symmetry - ( symmetricOnElems - , symmetryOnGens - , symmetryOnValid - , symmetry - , symmetryOnArbitrary - ) where - -import Data.GenValidity - -import Test.QuickCheck - -import Test.Validity.Utils - --- | --- --- \[ --- Symmetric(\prec) --- \quad\equiv\quad --- \forall a, b: (a \prec b) \Leftrightarrow (b \prec a) --- \] -symmetricOnElems - :: (a -> a -> Bool) -- ^ A relation - -> a -> a -- ^ Two elements - -> Bool -symmetricOnElems func a b = func a b <==> func b a - -symmetryOnGens - :: Show a - => (a -> a -> Bool) - -> Gen (a, a) - -> Property -symmetryOnGens func gen = - forAll gen $ uncurry $ symmetricOnElems func - -symmetryOnValid - :: (Show a, GenValidity a) - => (a -> a -> Bool) - -> Property -symmetryOnValid func = - symmetryOnGens func genValid - -symmetry - :: (Show a, GenValidity a) - => (a -> a -> Bool) - -> Property -symmetry func = - symmetryOnGens func genUnchecked - - --- | --- --- prop> symmetryOnArbitrary ((==) :: Int -> Int -> Bool) -symmetryOnArbitrary - :: (Show a, Arbitrary a) - => (a -> a -> Bool) - -> Property -symmetryOnArbitrary func = - symmetryOnGens func arbitrary diff --git a/src/Test/Validity/Relations/Transitivity.hs b/src/Test/Validity/Relations/Transitivity.hs deleted file mode 100644 --- a/src/Test/Validity/Relations/Transitivity.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Relations.Transitivity - ( transitiveOnElems - , transitivityOnGens - , transitivityOnValid - , transitivity - , transitivityOnArbitrary - ) where - -import Data.GenValidity - -import Test.QuickCheck - -import Test.Validity.Utils - --- | --- --- \[ --- Transitive(\prec) --- \quad\equiv\quad --- \forall a, b, c: ((a \prec b) \wedge (b \prec c)) \Rightarrow (a \prec c) --- \] -transitiveOnElems - :: (a -> a -> Bool) -- ^ A relation - -> a -> a -> a -- ^ Three elements - -> Bool -transitiveOnElems func a b c = (func a b && func b c) ===> func a c - -transitivityOnGens - :: Show a - => (a -> a -> Bool) - -> Gen (a, a, a) - -> Property -transitivityOnGens func gen = - forAll gen $ \(a, b, c) -> transitiveOnElems func a b c - -transitivityOnValid - :: (Show a, GenValidity a) - => (a -> a -> Bool) - -> Property -transitivityOnValid func - = transitivityOnGens func genValid - - -transitivity - :: (Show a, GenValidity a) - => (a -> a -> Bool) - -> Property -transitivity func - = transitivityOnGens func genUnchecked - --- | --- --- prop> transitivityOnArbitrary ((==) :: Int -> Int -> Bool) -transitivityOnArbitrary - :: (Show a, Arbitrary a) - => (a -> a -> Bool) - -> Property -transitivityOnArbitrary func - = transitivityOnGens func arbitrary - diff --git a/src/Test/Validity/RelativeValidity.hs b/src/Test/Validity/RelativeValidity.hs deleted file mode 100644 --- a/src/Test/Validity/RelativeValidity.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.RelativeValidity - ( -- * Tests for RelativeValidity instances - relativeValiditySpec - , relativeValidityImpliesValidA - , relativeValidityImpliesValidB - ) where - -import Data.Data -import Data.Proxy - -import Data.GenRelativeValidity -import Data.GenValidity - -import Test.Hspec -import Test.QuickCheck - -import Test.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 --- > (Proxy :: Proxy MyDataFor) --- > (Proxy :: Proxy MyOtherData) -relativeValiditySpec - :: (Typeable a, Typeable b, - Show a, Show b, - GenValidity a, GenValidity b, GenRelativeValidity a b) - => Proxy a - -> Proxy b - -> Spec -relativeValiditySpec one two = do - let nameOne = nameOf one - nameTwo = nameOf two - describe ("RelativeValidity " ++ nameOne ++ " " ++ nameTwo) $ - describe ("isValidFor :: " - ++ nameOne - ++ " -> " - ++ nameTwo - ++ " -> Bool") $ do - it ("implies isValid " ++ nameOne ++ " for any " ++ nameTwo) $ - relativeValidityImpliesValidA one two - it ("implies isValid " ++ nameTwo ++ " for any " ++ nameOne) $ - relativeValidityImpliesValidB one two - --- | @isValidFor a b@ implies @isValid a@ for all @b@ -relativeValidityImpliesValidA - :: (Show a, Show b, - GenValidity a, GenValidity b, RelativeValidity a b) - => Proxy a - -> Proxy b - -> Property -relativeValidityImpliesValidA one two = - forAll genUnchecked $ \a -> - forAll genUnchecked $ \b -> - not ((a `asProxyTypeOf` one) `isValidFor` (b `asProxyTypeOf` two)) - || isValid a - --- | @isValidFor a b@ implies @isValid b@ for all @a@ -relativeValidityImpliesValidB - :: (Show a, Show b, - GenValidity a, GenValidity b, RelativeValidity a b) - => Proxy a - -> Proxy b - -> Property -relativeValidityImpliesValidB one two = - forAll genUnchecked $ \a -> - forAll genUnchecked $ \b -> - not ((a `asProxyTypeOf` one) `isValidFor` (b `asProxyTypeOf` two)) - || isValid b - diff --git a/src/Test/Validity/Show.hs b/src/Test/Validity/Show.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Show.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | 'Show' and 'Read' properties +module Test.Validity.Show + ( showReadSpec, + showReadSpecOnArbitrary, + showReadSpecOnGen, + showReadRoundTrip, + showReadRoundTripOnArbitrary, + showReadRoundTripOnGen, + ) +where + +import Data.Data +import Data.GenValidity +import Test.Hspec +import Test.QuickCheck +import Test.Validity.Utils +import Text.Read + +-- | Standard test spec for properties of Show and Read instances for valid values +-- +-- Example usage: +-- +-- > showReadSpec @Int +showReadSpec :: + 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 +-- +-- Example usage: +-- +-- > showReadSpecOnArbitrary @Double +showReadSpecOnArbitrary :: + forall a. + (Show a, Eq a, Read a, Typeable a, Arbitrary a) => + Spec +showReadSpecOnArbitrary = showReadSpecOnGen @a arbitrary "arbitrary" shrink + +-- | Standard test spec for properties of Show and Read instances for values generated by a custom generator +-- +-- Example usage: +-- +-- > showReadSpecOnGen ((* 2) <$> genValid @Int) "even" (const []) +showReadSpecOnGen :: + forall a. + (Show a, Eq a, Read a, Typeable a) => + Gen a -> + String -> + (a -> [a]) -> + Spec +showReadSpecOnGen gen n s = + describe (unwords ["Show", nameOf @a, "and Read", nameOf @a]) $ + it (unwords ["are implemented such that read . show == id for", n, "values"]) $ + showReadRoundTripOnGen gen s + +-- | +-- +-- prop> showReadRoundTrip @Int +showReadRoundTrip :: + forall a. + (Show a, Eq a, Read a, GenValid a) => + Property +showReadRoundTrip = + showReadRoundTripOnGen (genValid :: Gen a) shrinkValid + +-- | +-- +-- prop> showReadRoundTripOnArbitrary @Double +showReadRoundTripOnArbitrary :: + forall a. + (Show a, Eq a, Read a, Arbitrary a) => + Property +showReadRoundTripOnArbitrary = + showReadRoundTripOnGen (arbitrary :: Gen a) shrink + +-- | +-- +-- prop> showReadRoundTripOnGen (abs <$> genValid :: Gen Int) (const []) +showReadRoundTripOnGen :: + (Show a, Eq a, Read a) => Gen a -> (a -> [a]) -> Property +showReadRoundTripOnGen gen s = + forAllShrink gen s $ \v -> readMaybe (show v) `shouldBe` Just v diff --git a/src/Test/Validity/Shrinking.hs b/src/Test/Validity/Shrinking.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Shrinking.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | Tests for Shrinking functions +-- +-- You will need @TypeApplications@ to use these. +module Test.Validity.Shrinking + ( shrinkValidSpec, + shrinkValidSpecWithLimit, + shrinkValidPreservesValidOnGenValid, + shrinkValidPreservesValidOnGenValidWithLimit, + shrinkPreservesValidOnGenValid, + shrinkValidPreservesValid, + shrinkingStaysValid, + shrinkingPreserves, + shrinkValidDoesNotShrinkToItself, + shrinkValidDoesNotShrinkToItselfWithLimit, + ) +where + +import Control.Monad +import Data.Data +import Data.GenValidity +import Test.Hspec +import Test.QuickCheck +import Test.Validity.Shrinking.Property +import Test.Validity.Utils + +shrinkValidSpec :: + forall a. + (Show a, Eq a, Typeable a, GenValid a) => + Spec +shrinkValidSpec = + describe ("shrinkValid :: " ++ nameOf @(a -> [a])) $ do + it "preserves validity" $ + forAll (genValid @a) $ + \a -> forM_ (shrinkValid a) shouldBeValid + it "never shrinks to itself for valid values" $ + shrinkValidDoesNotShrinkToItself @a + +shrinkValidSpecWithLimit :: + forall a. + (Show a, Eq a, Typeable a, GenValid a) => + Int -> + Spec +shrinkValidSpecWithLimit l = + describe ("shrinkValid :: " ++ nameOf @(a -> [a])) $ do + it (unwords ["preserves validity for the first", show l, "elements"]) $ + forAll (genValid @a) $ \a -> + forM_ (take l $ shrinkValid a) shouldBeValid + it + ( unwords + [ "never shrinks to itself for valid values for the first", + show l, + "elements" + ] + ) + $ shrinkValidDoesNotShrinkToItselfWithLimit @a l + +shrinkValidPreservesValidOnGenValid :: + forall a. + (Show a, GenValid a) => + Property +shrinkValidPreservesValidOnGenValid = + shrinkingStaysValid @a genValid shrinkValid + +shrinkValidPreservesValidOnGenValidWithLimit :: + forall a. + (Show a, GenValid a) => + Int -> + Property +shrinkValidPreservesValidOnGenValidWithLimit = + shrinkingStaysValidWithLimit @a genValid shrinkValid + +shrinkValidDoesNotShrinkToItself :: + forall a. + (Show a, Eq a, GenValid a) => + Property +shrinkValidDoesNotShrinkToItself = + shrinkDoesNotShrinkToItself @a shrinkValid + +shrinkValidDoesNotShrinkToItselfWithLimit :: + forall a. + (Show a, Eq a, GenValid a) => + Int -> + Property +shrinkValidDoesNotShrinkToItselfWithLimit = + shrinkDoesNotShrinkToItselfOnValidWithLimit @a shrinkValid diff --git a/src/Test/Validity/Types.hs b/src/Test/Validity/Types.hs deleted file mode 100644 --- a/src/Test/Validity/Types.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Test.Validity.Types - ( CanFail(..) - ) where - --- | A class of types that are the result of functions that can fail -class CanFail f where - hasFailed :: f a -> Bool - resultIfSucceeded :: f a -> Maybe a - -instance CanFail Maybe where - hasFailed Nothing = True - hasFailed _ = False - - resultIfSucceeded Nothing = Nothing - resultIfSucceeded (Just r) = Just r - -instance CanFail (Either e) where - hasFailed (Left _) = True - hasFailed _ = False - - resultIfSucceeded (Left _) = Nothing - resultIfSucceeded (Right r) = Just r - diff --git a/src/Test/Validity/Utils.hs b/src/Test/Validity/Utils.hs --- a/src/Test/Validity/Utils.hs +++ b/src/Test/Validity/Utils.hs @@ -1,20 +1,125 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +-- | Utilities for defining your own validity 'Spec's +-- +-- You will need @TypeApplications@ to use these. module Test.Validity.Utils - ( (<==>) - , (===>) - , nameOf - ) where + ( nameOf, + genDescr, + binRelStr, + shouldFail, + failsBecause, + Anon (..), + shouldBeValid, + shouldBeInvalid, + ) +where -import Data.Data +import Control.Arrow (second) +import Control.Monad.Trans.Writer (mapWriterT) +import Data.Data +import Test.Hspec +import Test.Hspec.Core.Formatters +import Test.Hspec.Core.Runner +import Test.Hspec.Core.Spec +import Test.QuickCheck.Property +import Test.Validity.Property.Utils -(===>) :: Bool -> Bool -> Bool -(===>) a b = not a || b +nameOf :: + forall a. + (Typeable a) => + String +nameOf = + let s = show $ typeRep (Proxy @a) + in if ' ' `elem` s + then "(" ++ s ++ ")" + else s -(<==>) :: Bool -> Bool -> Bool -(<==>) a b = a ===> b && b ===> a +genDescr :: + forall a. + (Typeable a) => + String -> + String +genDescr genname = unwords ["\"" ++ genname, "::", nameOf @a ++ "\""] -nameOf :: Typeable a => Proxy a -> String -nameOf proxy = - let (_, [ty]) = splitTyConApp $ typeOf proxy - in show ty +binRelStr :: + forall a. + (Typeable a) => + String -> + String +binRelStr op = unwords ["(" ++ op ++ ")", "::", name, "->", name, "->", "Bool"] + where + name = nameOf @a + +newtype Anon a + = Anon a + +instance Show (Anon a) where + show _ = "Anonymous" + +instance Functor Anon where + fmap f (Anon a) = Anon (f a) + +-- I'm not sure why mapSpecTree was removed from hspec-core, +-- but it has been copied here for convenience. +-- https://github.com/hspec/hspec/commit/020c7ecc4a73c24af38e9fab049f60bb9aec6981#diff-29cb22f0ef6e98086a71fc045847bd21L22 +mapSpecTree' :: (SpecTree a -> SpecTree b) -> SpecM a r -> SpecM b r + +#if MIN_VERSION_hspec(2,10,0) +mapSpecTree' f (SpecM specs) = SpecM (mapWriterT (fmap (second (fmap (map f)))) specs) +#else +mapSpecTree' f (SpecM specs) = SpecM (mapWriterT (fmap (second (map f))) specs) +#endif +{- ORMOLU_DISABLE -} +-- | Asserts that a given 'Spec' tree fails _somewhere_. +-- +-- It also shows the given string when reporting that the tree unexpectedly +-- succeeded. +failsBecause :: String -> SpecWith () -> SpecWith () +failsBecause s = mapSpecTree' go + where + go :: SpecTree () -> SpecTree () + go sp = + Leaf + Item + { itemRequirement = s, + itemLocation = Nothing, + itemIsFocused = False, + itemIsParallelizable = Nothing, +#if MIN_VERSION_hspec(2,11,10) + itemAnnotations = mempty, +#endif + itemExample = + \_ _ _ -> do + let conf = + defaultConfig {configFormatter = Just silent} + r <- hspecWithResult conf $ fromSpecList [sp] + let succesful = + summaryExamples r > 0 && summaryFailures r > 0 + pure $ produceResult succesful + } +{- ORMOLU_ENABLE -} + +produceResult :: Bool -> Test.Hspec.Core.Spec.Result +produceResult succesful = + Result + { resultInfo = "", + resultStatus = + if succesful + then Success + else Failure Nothing $ Test.Hspec.Core.Spec.Reason "Should have failed but didn't." + } + +shouldFail :: Property -> Property +shouldFail = + mapResult $ \res -> + res + { reason = unwords ["Should have failed:", reason res], + expect = not $ expect res + } diff --git a/test/DocTest.hs b/test/DocTest.hs deleted file mode 100644 --- a/test/DocTest.hs +++ /dev/null @@ -1,4 +0,0 @@ -import Test.DocTest - -main :: IO () -main = doctest ["-isrc", "src"] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Test/Validity/ApplicativeSpec.hs b/test/Test/Validity/ApplicativeSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/ApplicativeSpec.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.ApplicativeSpec where + +import Data.GenValidity +import Test.Hspec +import Test.Validity.Applicative + +spec :: Spec +spec = do + applicativeSpec @(Either Int) + applicativeSpec @[] + applicativeSpec @Maybe + applicativeSpecOnArbitrary @[] + applicativeSpecOnArbitrary @Maybe + applicativeSpecOnGens + @[] + @Int + (pure 4) + "four" + (genListOf $ pure 5) + "list of fives" + (pure []) + "purely empty list" + ((+) <$> genValid) + "increments" + (pure <$> ((+) <$> genValid)) + "increments in a list" + (pure <$> ((*) <$> genValid)) + "scalings in a list" + applicativeSpecOnGens + @Maybe + @String + (pure "ABC") + "ABC" + (Just <$> pure "ABC") + "Just an ABC" + (pure Nothing) + "purely Nothing" + ((++) <$> genValid) + "prepends" + (pure <$> ((++) <$> genValid)) + "prepends in a Just" + (pure <$> (flip (++) <$> genValid)) + "appends in a Just" diff --git a/test/Test/Validity/ArbitrarySpec.hs b/test/Test/Validity/ArbitrarySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/ArbitrarySpec.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.ArbitrarySpec where + +import Test.Hspec +import Test.Validity.Arbitrary + +spec :: Spec +spec = arbitrarySpec @Int diff --git a/test/Test/Validity/EqSpec.hs b/test/Test/Validity/EqSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/EqSpec.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.EqSpec where + +import Data.GenValidity +import GHC.Generics (Generic) +import Test.Hspec +import Test.Validity.Eq +import Test.Validity.Utils + +spec :: Spec +spec = do + eqSpec @Rational + eqSpec @Int + -- eqSpec @Double DOES NOT HOLD because of NaN + eqSpecOnArbitrary @Int + eqSpecOnGen ((* 2) <$> genValid @Int) "even" (const []) + failsBecause "(/=) and (==) don't have opposite semantics" $ + eqSpec @EqFuncMismatch + +newtype EqFuncMismatch + = EqFuncMismatch () + deriving (Show, Generic) + +instance Validity EqFuncMismatch + +instance Eq EqFuncMismatch where + (==) _ _ = True + (/=) _ _ = True + +instance GenValid EqFuncMismatch where + genValid = EqFuncMismatch <$> genValid + shrinkValid _ = [] diff --git a/test/Test/Validity/FunctorSpec.hs b/test/Test/Validity/FunctorSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/FunctorSpec.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.FunctorSpec where + +import Data.GenValidity +import GHC.Generics (Generic) +import Test.Hspec +import Test.Validity.Functor +import Test.Validity.Utils + +spec :: Spec +spec = do + functorSpec @[] + functorSpec @Maybe + failsBecause "Fcks does not satisfy any Functor laws" $ functorSpec @Fcks + functorSpec @(Either Int) + functorSpec @((,) Int) + functorSpecOnArbitrary @[] + functorSpecOnArbitrary @Maybe + functorSpecOnGens + @[] + @Int + (pure 4) + "four" + (genListOf $ pure 5) + "list of fives" + ((+) <$> genValid) + "increments" + ((*) <$> genValid) + "scalings" + functorSpecOnGens + @Maybe + @String + (pure "ABC") + "ABC" + (Just <$> pure "ABC") + "Just an ABC" + ((++) <$> genValid) + "prepends" + (flip (++) <$> genValid) + "appends" + +newtype Fcks a + = Fcks Int + deriving (Show, Eq, Generic) + +instance Validity (Fcks a) + +instance GenValid (Fcks a) where + genValid = Fcks <$> genValid + shrinkValid (Fcks i) = Fcks <$> shrinkValid i + +instance Functor Fcks where + fmap _ (Fcks i) = Fcks $ i * 2 diff --git a/test/Test/Validity/GenRelativeValiditySpec.hs b/test/Test/Validity/GenRelativeValiditySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/GenRelativeValiditySpec.hs @@ -0,0 +1,7 @@ +module Test.Validity.GenRelativeValiditySpec where + +import Test.Hspec + +-- import Test.Validity.GenRelativeValidity +spec :: Spec +spec = pure () -- TODO add examples once we have some instances diff --git a/test/Test/Validity/GenValiditySpec.hs b/test/Test/Validity/GenValiditySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/GenValiditySpec.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.GenValiditySpec where + +import Test.Hspec +import Test.Validity.GenValidity + +spec :: Spec +spec = do + genValidSpec @Rational + genValidSpec @Rational diff --git a/test/Test/Validity/MonadSpec.hs b/test/Test/Validity/MonadSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/MonadSpec.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.MonadSpec where + +import Data.GenValidity +import Test.Hspec +import Test.Validity.Monad + +{-# ANN module "HLint: ignore Use :" #-} + +spec :: Spec +spec = do + 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/Validity/MonoidSpec.hs b/test/Test/Validity/MonoidSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/MonoidSpec.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.MonoidSpec where + +import Test.Hspec +import Test.Validity.Monoid + +spec :: Spec +spec = do + monoidSpecOnValid @[Rational] + monoidSpec @[Int] + monoidSpecOnArbitrary @[Int] + monoidSpecOnGen (pure "a") "singleton list of 'a'" (const []) diff --git a/test/Test/Validity/OrdSpec.hs b/test/Test/Validity/OrdSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/OrdSpec.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.OrdSpec where + +import Data.GenValidity +import Test.Hspec +import Test.Validity.Ord +import Test.Validity.Utils + +spec :: Spec +spec = do + ordSpec @Rational + failsBecause "NaN >= NaN is False" $ ordSpec @Double + ordSpec @Int + ordSpecOnArbitrary @Int + ordSpecOnGen ((* 2) <$> genValid @Int) "even" (const []) diff --git a/test/Test/Validity/RelativeValiditySpec.hs b/test/Test/Validity/RelativeValiditySpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/RelativeValiditySpec.hs @@ -0,0 +1,7 @@ +module Test.Validity.RelativeValiditySpec where + +import Test.Hspec + +-- import Test.Validity.RelativeValidity +spec :: Spec +spec = pure () diff --git a/test/Test/Validity/ShowSpec.hs b/test/Test/Validity/ShowSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/ShowSpec.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.ShowSpec where + +import Data.GenValidity +import GHC.Generics (Generic) +import Test.Hspec +import Test.Validity.Show +import Test.Validity.Utils + +spec :: Spec +spec = do + showReadSpec @Rational + showReadSpec @Int + showReadSpecOnArbitrary @Rational + showReadSpecOnGen ((* 2) <$> genValid @Int) "even" (const []) + failsBecause "show and read don't have the correct semantics" $ + showReadSpec @ShowFuncMismatch + +data ShowFuncMismatch + = ShowFuncMismatch + deriving (Eq, Read, Generic) + +instance Validity ShowFuncMismatch + +instance Show ShowFuncMismatch where + show ShowFuncMismatch = "wrong" + +instance GenValid ShowFuncMismatch where + genValid = pure ShowFuncMismatch + shrinkValid _ = [] diff --git a/test/Test/Validity/ShrinkingSpec.hs b/test/Test/Validity/ShrinkingSpec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Validity/ShrinkingSpec.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TypeApplications #-} + +module Test.Validity.ShrinkingSpec where + +import Data.Int +import Data.Ratio +import Test.Hspec +import Test.Validity.Shrinking + +spec :: Spec +spec = do + shrinkValidSpec @(Ratio Int8) + shrinkValidSpec @Int + describe "shrinkValidPreservesValidOnGenValid" $ do + it "Ordering" $ shrinkValidPreservesValidOnGenValid @Ordering + it "[Ordering]" $ shrinkValidPreservesValidOnGenValid @[Ordering] + describe "shrinkValidPreservesValidOnGenValid" $ do + it "Ordering" $ shrinkValidPreservesValidOnGenValid @Ordering + it "[Ordering]" $ shrinkValidPreservesValidOnGenValid @[Ordering] + describe "shrinkValidDoesNotShrinkToItself" $ do + it "Int" $ shrinkValidDoesNotShrinkToItself @Int + it "[Int]" $ shrinkValidDoesNotShrinkToItself @[Int] + describe "shrinkValidDoesNotShrinkToItself" $ do + it "Ordering" $ shrinkValidDoesNotShrinkToItself @Ordering + it "[Ordering]" $ shrinkValidDoesNotShrinkToItself @[Ordering]