diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,16 @@ # Changelog -## [Unreleased] +### 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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,6 +1,6 @@ The MIT License (MIT) -Copyright (c) 2016-2020 Tom Sydney Kerckhove +Copyright (c) 2016-2021 Tom Sydney Kerckhove Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,3 +0,0 @@ -import Distribution.Simple - -main = defaultMain diff --git a/genvalidity-hspec.cabal b/genvalidity-hspec.cabal --- a/genvalidity-hspec.cabal +++ b/genvalidity-hspec.cabal @@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: f5acdda3f053861f0ebdb215817b65bc55fa4b9999a323a9875e7728b8b8f8f1 name: genvalidity-hspec -version: 0.7.0.4 +version: 1.0.0.0 synopsis: Standard spec's for GenValidity instances description: Note: There are companion packages for this library: . @@ -23,11 +21,12 @@ bug-reports: https://github.com/NorfairKing/validity/issues author: Tom Sydney Kerckhove maintainer: syd@cs-syd.eu -copyright: Copyright: (c) 2016-2020 Tom Sydney Kerckhove +copyright: Copyright: (c) 2016-2021 Tom Sydney Kerckhove license: MIT license-file: LICENSE build-type: Simple extra-source-files: + LICENSE CHANGELOG.md source-repository head @@ -41,12 +40,10 @@ Test.Validity.Arbitrary Test.Validity.Eq Test.Validity.Functor - Test.Validity.GenRelativeValidity Test.Validity.GenValidity Test.Validity.Monad Test.Validity.Monoid Test.Validity.Ord - Test.Validity.RelativeValidity Test.Validity.Show Test.Validity.Shrinking Test.Validity.Utils @@ -54,13 +51,14 @@ Paths_genvalidity_hspec hs-source-dirs: src + ghc-options: -Wall -fwarn-redundant-constraints build-depends: QuickCheck , base >=4.9 && <5 - , genvalidity >=0.8 + , genvalidity >=1.0 , genvalidity-property >=0.5 , hspec - , hspec-core + , hspec-core >=2.5.0 , transformers , validity >=0.5 default-language: Haskell2010 @@ -91,5 +89,5 @@ , genvalidity , genvalidity-hspec , hspec - , hspec-core + , 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 @@ -7,283 +7,262 @@ -- The most interesting functions in this module for most uses are: -- -- * 'genValidSpec' --- * 'eqSpecOnValid' --- * 'ordSpecOnValid' +-- * 'eqSpec' +-- * 'ordSpec' -- * 'producesValidsOnValids' -- * 'forAllValid' -- * 'shouldBeValid' module Test.Validity - ( -- * Writing properties - -- ** Cheap generation with shrinking - forAllUnchecked - , forAllValid - , forAllInvalid - -- ** Cheap assertions - , shouldBeValid - , shouldBeInvalid - -- * Tests for GenValidity instances - , genValiditySpec - , genValidSpec - , genInvalidSpec - , genValidGeneratesValid - , genGeneratesValid - , genInvalidGeneratesInvalid - , genGeneratesInvalid - , shrinkValiditySpec - , shrinkValidSpec - , shrinkValidSpecWithLimit - , shrinkInvalidSpec - , shrinkValidPreservesValidOnGenValid - , shrinkInvalidPreservesInvalidOnGenInvalid - , shrinkPreservesValidOnGenValid - , shrinkPreservesInvalidOnGenInvalid - , shrinkValidPreservesValid - , shrinkInvalidPreservesInvalid - , shrinkingStaysValid - , shrinkingStaysInvalid - , shrinkingPreserves - -- * Tests for Arbitrary instances involving Validity - , arbitrarySpec - , arbitraryGeneratesOnlyValid - -- * Tests for RelativeValidity instances - , relativeValiditySpec - , relativeValidityImpliesValidA - , relativeValidityImpliesValidB - -- * Tests for GenRelativeValidity instances - , genRelativeValiditySpec - , genRelativeValidGeneratesValid - , genRelativeInvalidGeneratesInvalid - -- * Standard tests involving functions - -- ** Standard tests involving validity - , producesValidsOnGen - , producesValidsOnValids - , producesValid - , producesValidsOnArbitrary - , producesValidsOnGens2 - , producesValidsOnValids2 - , producesValid2 - , producesValidsOnArbitrary2 - , producesValidsOnGens3 - , producesValidsOnValids3 - , producesValid3 - , producesValidsOnArbitrary3 - -- ** Standard tests involving functions that can fail - , CanFail(..) - , succeedsOnGen - , succeedsOnValid - , succeeds - , succeedsOnArbitrary - , succeedsOnGens2 - , succeedsOnValids2 - , succeeds2 - , succeedsOnArbitrary2 - , failsOnGen - , failsOnInvalid - , failsOnGens2 - , failsOnInvalid2 - , validIfSucceedsOnGen - , validIfSucceedsOnValid - , validIfSucceedsOnArbitrary - , validIfSucceeds - , validIfSucceedsOnGens2 - , validIfSucceedsOnValids2 - , validIfSucceeds2 - , validIfSucceedsOnArbitrary2 - , validIfSucceedsOnGens3 - , validIfSucceedsOnValids3 - , validIfSucceeds3 - , validIfSucceedsOnArbitrary3 - -- ** Standard tests involving equivalence of functions - -- *** Simple functions - -- **** One argument - , equivalentOnGen - , equivalentOnValid - , equivalent - , equivalentOnArbitrary - -- **** Two arguments - , equivalentOnGens2 - , equivalentOnValids2 - , equivalent2 - , equivalentOnArbitrary2 - -- **** Three arguments - , equivalentOnGens3 - , equivalentOnValids3 - , equivalent3 - , equivalentOnArbitrary3 - -- *** First function can fail - -- **** One argument - , equivalentWhenFirstSucceedsOnGen - , equivalentWhenFirstSucceedsOnValid - , equivalentWhenFirstSucceeds - , equivalentWhenFirstSucceedsOnArbitrary - -- **** Two arguments - , equivalentWhenFirstSucceedsOnGens2 - , equivalentWhenFirstSucceedsOnValids2 - , equivalentWhenFirstSucceeds2 - , equivalentWhenFirstSucceedsOnArbitrary2 - -- *** Second function can fail - -- **** One argument - , equivalentWhenSecondSucceedsOnGen - , equivalentWhenSecondSucceedsOnValid - , equivalentWhenSecondSucceeds - , equivalentWhenSecondSucceedsOnArbitrary - -- **** Two arguments - , equivalentWhenSecondSucceedsOnGens2 - , equivalentWhenSecondSucceedsOnValids2 - , equivalentWhenSecondSucceeds2 - , equivalentWhenSecondSucceedsOnArbitrary2 - -- *** Both functions can fail - -- **** One argument - , equivalentWhenSucceedOnGen - , equivalentWhenSucceedOnValid - , equivalentWhenSucceed - , equivalentWhenSucceedOnArbitrary - -- **** Two arguments - , equivalentWhenSucceedOnGens2 - , equivalentWhenSucceedOnValids2 - , equivalentWhenSucceed2 - , equivalentWhenSucceedOnArbitrary2 - -- ** Standard tests involving inverse functions - , inverseFunctionsOnGen - , inverseFunctionsOnValid - , inverseFunctions - , inverseFunctionsOnArbitrary - , inverseFunctionsIfFirstSucceedsOnGen - , inverseFunctionsIfFirstSucceedsOnValid - , inverseFunctionsIfFirstSucceeds - , inverseFunctionsIfFirstSucceedsOnArbitrary - , inverseFunctionsIfSecondSucceedsOnGen - , inverseFunctionsIfSecondSucceedsOnValid - , inverseFunctionsIfSecondSucceeds - , inverseFunctionsIfSecondSucceedsOnArbitrary - , inverseFunctionsIfSucceedOnGen - , inverseFunctionsIfSucceedOnValid - , inverseFunctionsIfSucceed - , inverseFunctionsIfSucceedOnArbitrary - -- ** Properties involving idempotence - , idempotentOnGen - , idempotentOnValid - , idempotent - , idempotentOnArbitrary - -- * Properties of relations - -- ** Reflexivity - , reflexiveOnElem - , reflexivityOnGen - , reflexivityOnValid - , reflexivity - , reflexivityOnArbitrary - -- ** Transitivity - , transitiveOnElems - , transitivityOnGens - , transitivityOnValid - , transitivity - , transitivityOnArbitrary - -- ** Antisymmetry - , antisymmetricOnElemsWithEquality - , antisymmetryOnGensWithEquality - , antisymmetryOnGens - , antisymmetryOnValid - , antisymmetry - , antisymmetryOnArbitrary - -- ** Antireflexivity - , antireflexiveOnElem - , antireflexivityOnGen - , antireflexivityOnValid - , antireflexivity - , antireflexivityOnArbitrary - -- ** Symmetry - , symmetricOnElems - , symmetryOnGens - , symmetryOnValid - , symmetry - , symmetryOnArbitrary - -- * Properties of operations - -- ** Identity element - -- *** Left Identity - , leftIdentityOnElemWithEquality - , leftIdentityOnGenWithEquality - , leftIdentityOnGen - , leftIdentityOnValid - , leftIdentity - , leftIdentityOnArbitrary - -- *** Right Identity - , rightIdentityOnElemWithEquality - , rightIdentityOnGenWithEquality - , rightIdentityOnGen - , rightIdentityOnValid - , rightIdentity - , rightIdentityOnArbitrary - -- *** Identity - , identityOnGen - , identityOnValid - , identity - , identityOnArbitrary - -- ** Associativity - , associativeOnGens - , associativeOnValids - , associative - , associativeOnArbitrary - -- ** Commutativity - , commutativeOnGens - , commutativeOnValids - , commutative - , commutativeOnArbitrary - -- * Show and Read properties - , showReadSpecOnValid - , showReadSpec - , showReadSpecOnArbitrary - , showReadSpecOnGen - -- * Eq properties - , eqSpecOnValid - , eqSpecOnInvalid - , eqSpec - , eqSpecOnArbitrary - , eqSpecOnGen - -- * Ord properties - , ordSpecOnGen - , ordSpecOnValid - , ordSpecOnInvalid - , ordSpec - , ordSpecOnArbitrary - -- * Monoid properties - , monoidSpecOnValid - , monoidSpec - , monoidSpecOnArbitrary - , monoidSpecOnGen - -- * Functor properties - , functorSpecOnValid - , functorSpec - , functorSpecOnArbitrary - , functorSpecOnGens - -- * Applicative properties - , applicativeSpecOnValid - , applicativeSpec - , applicativeSpecOnArbitrary - , applicativeSpecOnGens - -- * Monad properties - , monadSpecOnValid - , monadSpec - , monadSpecOnArbitrary - , monadSpecOnGens - -- * Re-exports - , module Data.GenValidity - ) where + ( -- * Writing properties -import Data.GenValidity + -- ** Cheap generation with shrinking + forAllValid, + -- ** Cheap assertions + shouldBeValid, + shouldBeInvalid, + + -- * Tests for GenValidity instances + genValidSpec, + genValidGeneratesValid, + genGeneratesValid, + shrinkValidSpec, + shrinkValidSpecWithLimit, + shrinkValidPreservesValidOnGenValid, + shrinkPreservesValidOnGenValid, + shrinkValidPreservesValid, + shrinkingStaysValid, + shrinkingPreserves, + + -- * Tests for Arbitrary instances involving Validity + arbitrarySpec, + arbitraryGeneratesOnlyValid, + + -- * Standard tests involving functions + + -- ** Standard tests involving validity + producesValidsOnGen, + producesValid, + producesValidsOnArbitrary, + producesValidsOnGens2, + producesValid2, + producesValidsOnArbitrary2, + producesValidsOnGens3, + producesValid3, + producesValidsOnArbitrary3, + + -- ** Standard tests involving functions that can fail + CanFail (..), + succeedsOnGen, + succeeds, + succeedsOnArbitrary, + succeedsOnGens2, + succeeds2, + succeedsOnArbitrary2, + failsOnGen, + failsOnGens2, + validIfSucceedsOnGen, + validIfSucceedsOnArbitrary, + validIfSucceeds, + validIfSucceedsOnGens2, + validIfSucceeds2, + validIfSucceedsOnArbitrary2, + validIfSucceedsOnGens3, + validIfSucceeds3, + validIfSucceedsOnArbitrary3, + + -- ** Standard tests involving equivalence of functions + + -- *** Simple functions + + -- **** One argument + equivalentOnGen, + equivalent, + equivalentOnArbitrary, + + -- **** Two arguments + equivalentOnGens2, + equivalent2, + equivalentOnArbitrary2, + + -- **** Three arguments + equivalentOnGens3, + equivalent3, + equivalentOnArbitrary3, + + -- *** First function can fail + + -- **** One argument + equivalentWhenFirstSucceedsOnGen, + equivalentWhenFirstSucceeds, + equivalentWhenFirstSucceedsOnArbitrary, + + -- **** Two arguments + equivalentWhenFirstSucceedsOnGens2, + equivalentWhenFirstSucceeds2, + equivalentWhenFirstSucceedsOnArbitrary2, + + -- *** Second function can fail + + -- **** One argument + equivalentWhenSecondSucceedsOnGen, + equivalentWhenSecondSucceeds, + equivalentWhenSecondSucceedsOnArbitrary, + + -- **** Two arguments + equivalentWhenSecondSucceedsOnGens2, + equivalentWhenSecondSucceeds2, + equivalentWhenSecondSucceedsOnArbitrary2, + + -- *** Both functions can fail + + -- **** One argument + equivalentWhenSucceedOnGen, + equivalentWhenSucceed, + equivalentWhenSucceedOnArbitrary, + + -- **** Two arguments + equivalentWhenSucceedOnGens2, + equivalentWhenSucceed2, + equivalentWhenSucceedOnArbitrary2, + + -- ** Standard tests involving inverse functions + inverseFunctionsOnGen, + inverseFunctions, + inverseFunctionsOnArbitrary, + inverseFunctionsIfFirstSucceedsOnGen, + inverseFunctionsIfFirstSucceeds, + inverseFunctionsIfFirstSucceedsOnArbitrary, + inverseFunctionsIfSecondSucceedsOnGen, + inverseFunctionsIfSecondSucceeds, + inverseFunctionsIfSecondSucceedsOnArbitrary, + inverseFunctionsIfSucceedOnGen, + inverseFunctionsIfSucceed, + inverseFunctionsIfSucceedOnArbitrary, + + -- ** Properties involving idempotence + idempotentOnGen, + idempotent, + idempotentOnArbitrary, + + -- * Properties of relations + + -- ** Reflexivity + reflexiveOnElem, + reflexivityOnGen, + reflexivity, + reflexivityOnArbitrary, + + -- ** Transitivity + transitiveOnElems, + transitivityOnGens, + transitivity, + transitivityOnArbitrary, + + -- ** Antisymmetry + antisymmetricOnElemsWithEquality, + antisymmetryOnGensWithEquality, + antisymmetryOnGens, + antisymmetry, + antisymmetryOnArbitrary, + + -- ** Antireflexivity + antireflexiveOnElem, + antireflexivityOnGen, + antireflexivity, + antireflexivityOnArbitrary, + + -- ** Symmetry + symmetricOnElems, + symmetryOnGens, + symmetry, + symmetryOnArbitrary, + + -- * Properties of operations + + -- ** Identity element + + -- *** Left Identity + leftIdentityOnElemWithEquality, + leftIdentityOnGenWithEquality, + leftIdentityOnGen, + leftIdentity, + leftIdentityOnArbitrary, + + -- *** Right Identity + rightIdentityOnElemWithEquality, + rightIdentityOnGenWithEquality, + rightIdentityOnGen, + rightIdentity, + rightIdentityOnArbitrary, + + -- *** Identity + identityOnGen, + identity, + identityOnArbitrary, + + -- ** Associativity + associativeOnGens, + associative, + associativeOnArbitrary, + + -- ** Commutativity + commutativeOnGens, + commutative, + commutativeOnArbitrary, + + -- * Show and Read properties + showReadSpec, + showReadSpecOnArbitrary, + showReadSpecOnGen, + + -- * Eq properties + eqSpec, + eqSpecOnArbitrary, + eqSpecOnGen, + + -- * Ord properties + ordSpecOnGen, + ordSpec, + ordSpecOnArbitrary, + + -- * Monoid properties + monoidSpec, + monoidSpecOnArbitrary, + monoidSpecOnGen, + + -- * Functor properties + functorSpec, + functorSpecOnArbitrary, + functorSpecOnGens, + + -- * Applicative properties + applicativeSpec, + applicativeSpecOnArbitrary, + applicativeSpecOnGens, + + -- * Monad properties + monadSpec, + monadSpecOnArbitrary, + monadSpecOnGens, + + -- * Re-exports + module Data.GenValidity, + ) +where + +import Data.GenValidity import Test.Validity.Applicative import Test.Validity.Arbitrary import Test.Validity.Eq import Test.Validity.Functions import Test.Validity.Functor -import Test.Validity.GenRelativeValidity 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.RelativeValidity 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 --- a/src/Test/Validity/Applicative.hs +++ b/src/Test/Validity/Applicative.hs @@ -1,115 +1,106 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} -- | Applicative properties -- -- You will need @TypeApplications@ to use these. module Test.Validity.Applicative - ( applicativeSpecOnValid - , applicativeSpec - , applicativeSpecOnArbitrary - , applicativeSpecOnGens - ) where + ( applicativeSpec, + applicativeSpecOnArbitrary, + applicativeSpecOnGens, + ) +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 Avoid lambda" #-} pureTypeStr :: - forall (f :: * -> *). (Typeable f) - => String + forall (f :: Type -> Type). + (Typeable f) => + String pureTypeStr = unwords ["pure", "::", "a", "->", nameOf @f, "a"] seqTypeStr :: - forall (f :: * -> *). (Typeable f) - => String + forall (f :: Type -> Type). + (Typeable f) => + String seqTypeStr = - unwords - [ "(<*>)" - , "::" - , nameOf @f - , "(a" - , "->" - , "b)" - , "->" - , nameOf @f - , "a" - , "->" - , nameOf @f - , "b" - ] + unwords + [ "(<*>)", + "::", + nameOf @f, + "(a", + "->", + "b)", + "->", + nameOf @f, + "a", + "->", + nameOf @f, + "b" + ] seqrTypeStr :: - forall (f :: * -> *). (Typeable f) - => String + forall (f :: Type -> Type). + (Typeable f) => + String seqrTypeStr = - unwords - [ "(*>)" - , "::" - , nameOf @f - , "a" - , "->" - , nameOf @f - , "b" - , "->" - , nameOf @f - , "b" - ] + unwords + [ "(*>)", + "::", + nameOf @f, + "a", + "->", + nameOf @f, + "b", + "->", + nameOf @f, + "b" + ] seqlTypeStr :: - forall (f :: * -> *). (Typeable f) - => String + forall (f :: Type -> Type). + (Typeable f) => + String seqlTypeStr = - unwords - [ "(<*)" - , "::" - , nameOf @f - , "a" - , "->" - , nameOf @f - , "b" - , "->" - , nameOf @f - , "a" - ] + unwords + [ "(<*)", + "::", + nameOf @f, + "a", + "->", + nameOf @f, + "b", + "->", + nameOf @f, + "a" + ] -- | Standard test spec for properties of Applicative instances for values generated with GenValid instances -- -- Example usage: -- -- > applicativeSpecOnArbitrary @[] -applicativeSpecOnValid :: - forall (f :: * -> *). - (Eq (f Int), Show (f Int), Applicative f, Typeable f, GenValid (f Int)) - => Spec -applicativeSpecOnValid = applicativeSpecWithInts @f genValid - --- | Standard test spec for properties of Applicative instances for values generated with GenUnchecked instances --- --- Example usage: --- --- > applicativeSpecOnArbitrary @[] applicativeSpec :: - forall (f :: * -> *). - ( Eq (f Int) - , Show (f Int) - , Applicative f - , Typeable f - , GenUnchecked (f Int) - ) - => Spec -applicativeSpec = applicativeSpecWithInts @f genUnchecked + forall (f :: Type -> Type). + ( Eq (f Int), + Show (f Int), + Applicative f, + Typeable f, + GenValid (f Int) + ) => + Spec +applicativeSpec = applicativeSpecWithInts @f genValid -- | Standard test spec for properties of Applicative instances for values generated with Arbitrary instances -- @@ -117,32 +108,32 @@ -- -- > applicativeSpecOnArbitrary @[] applicativeSpecOnArbitrary :: - forall (f :: * -> *). - (Eq (f Int), Show (f Int), Applicative f, Typeable f, Arbitrary (f Int)) - => Spec + forall (f :: Type -> Type). + (Eq (f Int), Show (f Int), Applicative f, Typeable f, Arbitrary (f Int)) => + Spec applicativeSpecOnArbitrary = applicativeSpecWithInts @f arbitrary applicativeSpecWithInts :: - forall (f :: * -> *). - (Show (f Int), Eq (f Int), Applicative f, Typeable f) - => Gen (f Int) - -> Spec + forall (f :: Type -> Type). + (Show (f Int), Eq (f Int), Applicative f, Typeable f) => + Gen (f Int) -> + Spec applicativeSpecWithInts gen = - applicativeSpecOnGens - @f - @Int - genUnchecked - "int" - gen - (unwords [nameOf @f, "of ints"]) - gen - (unwords [nameOf @f, "of ints"]) - ((+) <$> genUnchecked) - "increments" - (pure <$> ((+) <$> genUnchecked)) - (unwords [nameOf @f, "of increments"]) - (pure <$> ((*) <$> genUnchecked)) - (unwords [nameOf @f, "of scalings"]) + applicativeSpecOnGens + @f + @Int + genValid + "int" + gen + (unwords [nameOf @f, "of ints"]) + gen + (unwords [nameOf @f, "of ints"]) + ((+) <$> genValid) + "increments" + (pure <$> ((+) <$> genValid)) + (unwords [nameOf @f, "of increments"]) + (pure <$> ((*) <$> genValid)) + (unwords [nameOf @f, "of scalings"]) -- | Standard test spec for properties of Applicative instances for values generated by given generators (and names for those generator). -- @@ -166,119 +157,127 @@ -- > (pure <$> (flip (++) <$> genValid)) -- > "appends in a Just" applicativeSpecOnGens :: - forall (f :: * -> *) (a :: *) (b :: *) (c :: *). - ( Show a - , Eq a - , Show (f a) - , Eq (f a) - , Show (f b) - , Eq (f b) - , Show (f c) - , Eq (f c) - , Applicative f - , Typeable f - , Typeable a - , Typeable b - , Typeable c - ) - => Gen a - -> String - -> Gen (f a) - -> String - -> Gen (f b) - -> String - -> Gen (a -> b) - -> String - -> Gen (f (a -> b)) - -> String - -> Gen (f (b -> c)) - -> String - -> Spec + forall (f :: Type -> Type) (a :: Type) (b :: Type) (c :: Type). + ( Show a, + Show (f a), + Eq (f a), + Show (f b), + Eq (f b), + Show (f c), + Eq (f c), + Applicative f, + Typeable f, + Typeable a, + Typeable b, + Typeable c + ) => + Gen a -> + String -> + Gen (f a) -> + String -> + Gen (f b) -> + String -> + Gen (a -> b) -> + String -> + Gen (f (a -> b)) -> + String -> + Gen (f (b -> c)) -> + String -> + Spec applicativeSpecOnGens gena genaname gen genname genb genbname genfa genfaname genffa genffaname genffb genffbname = - parallel $ + parallel $ describe ("Applicative " ++ nameOf @f) $ do - describe (unwords [pureTypeStr @f, "and", seqTypeStr @f]) $ do - it - (unwords - [ "satisfy the identity law: 'pure id <*> v = v' for" - , genDescr @(f a) genname - ]) $ - equivalentOnGen (pure id <*>) id gen shrinkNothing - it - (unwords - [ "satisfy the composition law: 'pure (.) <*> u <*> v <*> w = u <*> (v <*> w)' for" - , genDescr @(f (b -> c)) genffbname - , "composed with" - , genDescr @(f (a -> b)) genffaname - , "and applied to" - , genDescr @(f a) genname - ]) $ - equivalentOnGens3 - (\(Anon u) (Anon v) w -> - pure (.) <*> (u :: f (b -> c)) <*> (v :: f (a -> b)) <*> - (w :: f a) :: f c) - (\(Anon u) (Anon v) w -> u <*> (v <*> w) :: f c) - ((,,) <$> (Anon <$> genffb) <*> (Anon <$> genffa) <*> gen) - shrinkNothing - it - (unwords - [ "satisfy the homomorphism law: 'pure f <*> pure x = pure (f x)' for" - , genDescr @(a -> b) genfaname - , "sequenced with" - , genDescr @a genaname - ]) $ - equivalentOnGens2 - (\(Anon f) x -> pure f <*> pure x :: f b) - (\(Anon f) x -> pure $ f x :: f b) - ((,) <$> (Anon <$> genfa) <*> gena) - shrinkNothing - it - (unwords - [ "satisfy the interchange law: 'u <*> pure y = pure ($ y) <*> u' for" - , genDescr @(f (a -> b)) genffaname - , "sequenced with" - , genDescr @a genaname - ]) $ - equivalentOnGens2 - (\(Anon u) y -> u <*> pure y :: f b) - (\(Anon u) y -> pure ($ y) <*> u :: f b) - ((,) <$> (Anon <$> genffa) <*> gena) - shrinkNothing - it - (unwords - [ "satisfy the law about the functor instance: fmap f x = pure f <*> x for" - , genDescr @(a -> b) genfaname - , "mapped over" - , genDescr @(f a) genname - ]) $ - equivalentOnGens2 - (\(Anon f) x -> fmap f x) - (\(Anon f) x -> pure f <*> x) - ((,) <$> (Anon <$> genfa) <*> gen) - shrinkNothing - describe (seqrTypeStr @f) $ - it - (unwords - [ "is equivalent to its default implementation 'u *> v = pure (const id) <*> u <*> v' for" - , genDescr @(f a) genname - , "in front of" - , genDescr @b genbname - ]) $ - equivalentOnGens2 - (\u v -> u *> v) - (\u v -> pure (const id) <*> u <*> v) - ((,) <$> gen <*> genb) - shrinkNothing - describe (seqlTypeStr @f) $ - it - (unwords - [ "is equivalent to its default implementation 'u <* v = pure const <*> u <*> v' for" - , genDescr @b genbname - , "behind" - , genDescr @(f a) genname - ]) $ - equivalentOnGens2 - (\u v -> u <* v) - (\u v -> pure const <*> u <*> v) - ((,) <$> gen <*> genb) - shrinkNothing + describe (unwords [pureTypeStr @f, "and", seqTypeStr @f]) $ do + it + ( unwords + [ "satisfy the identity law: 'pure id <*> v = v' for", + genDescr @(f a) genname + ] + ) + $ equivalentOnGen (pure id <*>) id gen shrinkNothing + it + ( unwords + [ "satisfy the composition law: 'pure (.) <*> u <*> v <*> w = u <*> (v <*> w)' for", + genDescr @(f (b -> c)) genffbname, + "composed with", + genDescr @(f (a -> b)) genffaname, + "and applied to", + genDescr @(f a) genname + ] + ) + $ equivalentOnGens3 + ( \(Anon u) (Anon v) w -> + pure (.) <*> (u :: f (b -> c)) <*> (v :: f (a -> b)) + <*> (w :: f a) :: + f c + ) + (\(Anon u) (Anon v) w -> u <*> (v <*> w) :: f c) + ((,,) <$> (Anon <$> genffb) <*> (Anon <$> genffa) <*> gen) + shrinkNothing + it + ( unwords + [ "satisfy the homomorphism law: 'pure f <*> pure x = pure (f x)' for", + genDescr @(a -> b) genfaname, + "sequenced with", + genDescr @a genaname + ] + ) + $ equivalentOnGens2 + (\(Anon f) x -> pure f <*> pure x :: f b) + (\(Anon f) x -> pure $ f x :: f b) + ((,) <$> (Anon <$> genfa) <*> gena) + shrinkNothing + it + ( unwords + [ "satisfy the interchange law: 'u <*> pure y = pure ($ y) <*> u' for", + genDescr @(f (a -> b)) genffaname, + "sequenced with", + genDescr @a genaname + ] + ) + $ equivalentOnGens2 + (\(Anon u) y -> u <*> pure y :: f b) + (\(Anon u) y -> pure ($ y) <*> u :: f b) + ((,) <$> (Anon <$> genffa) <*> gena) + shrinkNothing + it + ( unwords + [ "satisfy the law about the functor instance: fmap f x = pure f <*> x for", + genDescr @(a -> b) genfaname, + "mapped over", + genDescr @(f a) genname + ] + ) + $ equivalentOnGens2 + (\(Anon f) x -> fmap f x) + (\(Anon f) x -> pure f <*> x) + ((,) <$> (Anon <$> genfa) <*> gen) + shrinkNothing + describe (seqrTypeStr @f) $ + it + ( unwords + [ "is equivalent to its default implementation 'u Type> v = pure (const id) <*> u <*> v' for", + genDescr @(f a) genname, + "in front of", + genDescr @b genbname + ] + ) + $ equivalentOnGens2 + (\u v -> u *> v) + (\u v -> pure (const id) <*> u <*> v) + ((,) <$> gen <*> genb) + shrinkNothing + describe (seqlTypeStr @f) $ + it + ( unwords + [ "is equivalent to its default implementation 'u <* v = pure const <*> u <*> v' for", + genDescr @b genbname, + "behind", + genDescr @(f a) genname + ] + ) + $ equivalentOnGens2 + (\u v -> u <* v) + (\u v -> pure const <*> u <*> v) + ((,) <$> gen <*> genb) + shrinkNothing diff --git a/src/Test/Validity/Arbitrary.hs b/src/Test/Validity/Arbitrary.hs --- a/src/Test/Validity/Arbitrary.hs +++ b/src/Test/Validity/Arbitrary.hs @@ -1,23 +1,21 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-} -- | Tests for Arbitrary instances involving Validity -- -- You will need @TypeApplications@ to use these. module Test.Validity.Arbitrary - ( arbitrarySpec - , arbitraryGeneratesOnlyValid - ) where + ( arbitrarySpec, + arbitraryGeneratesOnlyValid, + ) +where import Data.Data - import Data.GenValidity - import Test.Hspec import Test.QuickCheck - import Test.Validity.GenValidity import Test.Validity.Utils @@ -28,18 +26,20 @@ -- -- > arbitrarySpec @Int arbitrarySpec :: - forall a. (Typeable a, Show a, Validity a, Arbitrary a) - => Spec + forall a. + (Typeable a, Show a, Validity a, Arbitrary a) => + Spec arbitrarySpec = do - let name = nameOf @a - describe ("Arbitrary " ++ name) $ - describe ("arbitrary :: Gen " ++ name) $ - it "only generates valid values" $ arbitraryGeneratesOnlyValid @a + let name = nameOf @a + describe ("Arbitrary " ++ name) $ + describe ("arbitrary :: Gen " ++ name) $ + it "only generates valid values" $ arbitraryGeneratesOnlyValid @a -- | @arbitrary@ only generates valid data -- -- prop> arbitraryGeneratesOnlyValid @Int arbitraryGeneratesOnlyValid :: - forall a. (Show a, Validity a, Arbitrary a) - => Property + forall a. + (Show a, Validity a, Arbitrary a) => + Property arbitraryGeneratesOnlyValid = genGeneratesValid @a arbitrary diff --git a/src/Test/Validity/Eq.hs b/src/Test/Validity/Eq.hs --- a/src/Test/Validity/Eq.hs +++ b/src/Test/Validity/Eq.hs @@ -1,69 +1,48 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} -- | Eq properties -- -- You will need @TypeApplications@ to use these. module Test.Validity.Eq - ( eqSpecOnValid - , eqSpecOnInvalid - , eqSpec - , eqSpecOnArbitrary - , eqSpecOnGen - ) where + ( eqSpec, + eqSpecOnArbitrary, + eqSpecOnGen, + ) +where import Data.Data - import Data.GenValidity - import Test.Hspec import Test.QuickCheck - import Test.Validity.Functions import Test.Validity.Relations import Test.Validity.Utils eqTypeStr :: - forall a. Typeable a - => String + forall a. + Typeable a => + String eqTypeStr = binRelStr @a "==" neqTypeStr :: - forall a. Typeable a - => String + forall a. + Typeable a => + String neqTypeStr = binRelStr @a "/=" -- | Standard test spec for properties of Eq instances for valid values -- -- Example usage: -- --- > eqSpecOnValid @Double -eqSpecOnValid :: - forall a. (Show a, Eq a, Typeable a, GenValid a) - => Spec -eqSpecOnValid = eqSpecOnGen @a genValid "valid" shrinkValid - --- | Standard test spec for properties of Eq instances for invalid values --- --- Example usage: --- --- > eqSpecOnInvalid @Double -eqSpecOnInvalid :: - forall a. (Show a, Eq a, Typeable a, GenInvalid a) - => Spec -eqSpecOnInvalid = eqSpecOnGen @a genInvalid "invalid" shrinkInvalid - --- | Standard test spec for properties of Eq instances for unchecked values --- --- Example usage: --- -- > eqSpec @Int eqSpec :: - forall a. (Show a, Eq a, Typeable a, GenUnchecked a) - => Spec -eqSpec = eqSpecOnGen @a genUnchecked "unchecked" shrinkUnchecked + forall a. + (Show a, Eq a, Typeable a, GenValid a) => + Spec +eqSpec = eqSpecOnGen @a genValid "valid" shrinkValid -- | Standard test spec for properties of Eq instances for arbitrary values -- @@ -71,8 +50,9 @@ -- -- > eqSpecOnArbitrary @Int eqSpecOnArbitrary :: - forall a. (Show a, Eq a, Typeable a, Arbitrary a) - => Spec + forall a. + (Show a, Eq a, Typeable a, Arbitrary a) => + Spec eqSpecOnArbitrary = eqSpecOnGen @a arbitrary "arbitrary" shrink -- | Standard test spec for properties of Eq instances for values generated by a given generator (and name for that generator). @@ -81,63 +61,70 @@ -- -- > eqSpecOnGen ((* 2) <$> genValid @Int) "even" eqSpecOnGen :: - forall a. (Show a, Eq a, Typeable a) - => Gen a - -> String - -> (a -> [a]) - -> Spec + forall a. + (Show a, Eq a, Typeable a) => + Gen a -> + String -> + (a -> [a]) -> + Spec eqSpecOnGen gen genname s = - parallel $ do - let name = nameOf @a - funeqstr = eqTypeStr @a - funneqstr = neqTypeStr @a - gen2 = (,) <$> gen <*> gen - gen3 = (,,) <$> gen <*> gen <*> gen - s2 = shrinkT2 s - describe ("Eq " ++ name) $ do - let eq = (==) @a - neq = (/=) @a - describe funeqstr $ do - it - (unwords - [ "is reflexive for" - , "\"" ++ genname - , name ++ "\"" ++ "s" - ]) $ - reflexivityOnGen eq gen s - it - (unwords - [ "is symmetric for" - , "\"" ++ genname - , name ++ "\"" ++ "s" - ]) $ - symmetryOnGens eq gen2 s - it - (unwords - [ "is transitive for" - , "\"" ++ genname - , name ++ "\"" ++ "s" - ]) $ - transitivityOnGens eq gen3 s - it - (unwords - [ "is equivalent to (\\a b -> not $ a /= b) for" - , "\"" ++ genname - , name ++ "\"" ++ "s" - ]) $ - equivalentOnGens2 eq (\a b -> not $ a `neq` b) gen2 s2 - describe funneqstr $ do - it - (unwords - [ "is antireflexive for" - , "\"" ++ genname - , name ++ "\"" ++ "s" - ]) $ - antireflexivityOnGen neq gen s - it - (unwords - [ "is equivalent to (\\a b -> not $ a == b) for" - , "\"" ++ genname - , name ++ "\"" ++ "s" - ]) $ - equivalentOnGens2 neq (\a b -> not $ a `eq` b) gen2 s2 + parallel $ do + let name = nameOf @a + funeqstr = eqTypeStr @a + funneqstr = neqTypeStr @a + gen2 = (,) <$> gen <*> gen + gen3 = (,,) <$> gen <*> gen <*> gen + s2 = shrinkT2 s + describe ("Eq " ++ name) $ do + let eq = (==) @a + neq = (/=) @a + describe funeqstr $ do + it + ( unwords + [ "is reflexive for", + "\"" ++ genname, + name ++ "\"" ++ "s" + ] + ) + $ reflexivityOnGen eq gen s + it + ( unwords + [ "is symmetric for", + "\"" ++ genname, + name ++ "\"" ++ "s" + ] + ) + $ symmetryOnGens eq gen2 s + it + ( unwords + [ "is transitive for", + "\"" ++ genname, + name ++ "\"" ++ "s" + ] + ) + $ transitivityOnGens eq gen3 s + it + ( unwords + [ "is equivalent to (\\a b -> not $ a /= b) for", + "\"" ++ genname, + name ++ "\"" ++ "s" + ] + ) + $ equivalentOnGens2 eq (\a b -> not $ a `neq` b) gen2 s2 + describe funneqstr $ do + it + ( unwords + [ "is antireflexive for", + "\"" ++ genname, + name ++ "\"" ++ "s" + ] + ) + $ antireflexivityOnGen neq gen s + it + ( unwords + [ "is equivalent to (\\a b -> not $ a == b) for", + "\"" ++ genname, + name ++ "\"" ++ "s" + ] + ) + $ equivalentOnGens2 neq (\a b -> not $ a `eq` b) gen2 s2 diff --git a/src/Test/Validity/Functor.hs b/src/Test/Validity/Functor.hs --- a/src/Test/Validity/Functor.hs +++ b/src/Test/Validity/Functor.hs @@ -1,76 +1,65 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} -- | Functor properties -- -- You will need @TypeApplications@ to use these. module Test.Validity.Functor - ( functorSpecOnValid - , functorSpec - , functorSpecOnArbitrary - , functorSpecOnGens - ) where + ( 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 :: * -> *). (Typeable f) - => String + forall (f :: Type -> Type). + (Typeable f) => + String fmapTypeStr = - unwords - [ "fmap" - , "::" - , "(a" - , "->" - , "b)" - , "->" - , nameOf @f - , "a" - , "->" - , nameOf @f - , "b" - ] + unwords + [ "fmap", + "::", + "(a", + "->", + "b)", + "->", + nameOf @f, + "a", + "->", + nameOf @f, + "b" + ] flTypeStr :: - forall (f :: * -> *). (Typeable f) - => String + forall (f :: Type -> Type). + (Typeable f) => + String flTypeStr = - unwords ["(<$)", "::", "a", "->", nameOf @f, "b", "->", nameOf @f, "a"] + unwords ["(<$)", "::", "a", "->", nameOf @f, "b", "->", nameOf @f, "a"] -- | Standard test spec for properties of Functor instances for values generated with GenValid instances -- -- Example usage: -- -- > functorSpecOnArbitrary @[] -functorSpecOnValid :: - forall (f :: * -> *). - (Eq (f Int), Show (f Int), Functor f, Typeable f, GenValid (f Int)) - => Spec -functorSpecOnValid = functorSpecWithInts @f genValid - --- | Standard test spec for properties of Functor instances for values generated with GenUnchecked instances --- --- Example usage: --- --- > functorSpecOnArbitrary @[] functorSpec :: - forall (f :: * -> *). - (Eq (f Int), Show (f Int), Functor f, Typeable f, GenUnchecked (f Int)) - => Spec -functorSpec = functorSpecWithInts @f genUnchecked + 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 -- @@ -78,27 +67,28 @@ -- -- > functorSpecOnArbitrary @[] functorSpecOnArbitrary :: - forall (f :: * -> *). - (Eq (f Int), Show (f Int), Functor f, Typeable f, Arbitrary (f Int)) - => Spec + forall (f :: Type -> Type). + (Eq (f Int), Show (f Int), Functor f, Typeable f, Arbitrary (f Int)) => + Spec functorSpecOnArbitrary = functorSpecWithInts @f arbitrary functorSpecWithInts :: - forall (f :: * -> *). (Eq (f Int), Show (f Int), Functor f, Typeable f) - => Gen (f Int) - -> Spec + forall (f :: Type -> Type). + (Eq (f Int), Show (f Int), Functor f, Typeable f) => + Gen (f Int) -> + Spec functorSpecWithInts gen = - functorSpecOnGens - @f - @Int - genUnchecked - "int" - gen - (unwords [nameOf @f, "of ints"]) - ((+) <$> genUnchecked) - "increments" - ((*) <$> genUnchecked) - "scalings" + functorSpecOnGens + @f + @Int + genValid + "int" + gen + (unwords [nameOf @f, "of ints"]) + ((+) <$> genValid) + "increments" + ((*) <$> genValid) + "scalings" -- | Standard test spec for properties of Functor instances for values generated by given generators (and names for those generator). -- @@ -112,61 +102,64 @@ -- > ((+) <$> genValid) "additions" -- > ((*) <$> genValid) "multiplications" functorSpecOnGens :: - forall (f :: * -> *) (a :: *) (b :: *) (c :: *). - ( Show a - , Show (f a) - , Show (f c) - , Eq (f a) - , Eq (f c) - , Functor f - , Typeable f - , Typeable a - , Typeable b - , Typeable c - ) - => Gen a - -> String - -> Gen (f a) - -> String - -> Gen (b -> c) - -> String - -> Gen (a -> b) - -> String - -> Spec + forall (f :: Type -> Type) (a :: Type) (b :: Type) (c :: Type). + ( Show a, + Show (f a), + Show (f c), + Eq (f a), + Eq (f c), + Functor f, + Typeable f, + Typeable a, + Typeable b, + Typeable c + ) => + Gen a -> + String -> + Gen (f a) -> + String -> + Gen (b -> c) -> + String -> + Gen (a -> b) -> + String -> + Spec functorSpecOnGens gena genaname gen genname genf genfname geng gengname = - parallel $ + parallel $ describe ("Functor " ++ nameOf @f) $ do - describe (fmapTypeStr @f) $ do - it - (unwords - [ "satisfies the first Fuctor law: 'fmap id == id' for" - , genDescr @(f a) genname - ]) $ - equivalentOnGen (fmap @f id) (id @(f a)) gen shrinkNothing - it - (unwords - [ "satisfieds the second Functor law: 'fmap (f . g) == fmap f . fmap g' for" - , genDescr @(f a) genname - , "'s" - , "given to" - , genDescr @(b -> c) genfname - , "and" - , genDescr @(a -> b) gengname - ]) $ - forAll (Anon <$> genf) $ \(Anon f) -> - forAll (Anon <$> geng) $ \(Anon g) -> - equivalentOnGen - (fmap (f . g)) - (fmap f . fmap g) - gen - shrinkNothing - describe (flTypeStr @f) $ - it - (unwords - [ "is equivalent to its default implementation for" - , genDescr @a genaname - , "and" - , genDescr @(f a) genname - ]) $ - forAll gena $ \a -> - equivalentOnGen (a <$) (fmap $ const a) gen shrinkNothing + describe (fmapTypeStr @f) $ do + it + ( unwords + [ "satisfies the first Fuctor law: 'fmap id == id' for", + genDescr @(f a) genname + ] + ) + $ equivalentOnGen (fmap @f id) (id @(f a)) gen shrinkNothing + it + ( unwords + [ "satisfieds the second Functor law: 'fmap (f . g) == fmap f . fmap g' for", + genDescr @(f a) genname, + "'s", + "given to", + genDescr @(b -> c) genfname, + "and", + genDescr @(a -> b) gengname + ] + ) + $ forAll (Anon <$> genf) $ \(Anon f) -> + forAll (Anon <$> geng) $ \(Anon g) -> + equivalentOnGen + (fmap (f . g)) + (fmap f . fmap g) + gen + shrinkNothing + describe (flTypeStr @f) $ + it + ( unwords + [ "is equivalent to its default implementation for", + genDescr @a genaname, + "and", + genDescr @(f a) genname + ] + ) + $ forAll gena $ \a -> + equivalentOnGen (a <$) (fmap $ const a) gen shrinkNothing diff --git a/src/Test/Validity/GenRelativeValidity.hs b/src/Test/Validity/GenRelativeValidity.hs deleted file mode 100644 --- a/src/Test/Validity/GenRelativeValidity.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Tests for GenRelativeValidity instances --- --- You will need @TypeApplications@ to use these. -module Test.Validity.GenRelativeValidity - ( genRelativeValiditySpec - , genRelativeValidSpec - , genRelativeInvalidSpec - , genRelativeValidGeneratesValid - , genRelativeInvalidGeneratesInvalid - ) where - -import Data.Data - -import Data.GenRelativeValidity -import Data.GenValidity - -import Test.Hspec -import Test.QuickCheck - -import Test.Validity.Property.Utils -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 @MyDataFor @MyOtherData -genRelativeValiditySpec :: - forall a b. - ( Typeable a - , Typeable b - , Show a - , Show b - , GenUnchecked b - , GenValid b - , GenRelativeValid a b - , GenRelativeInvalid a b - ) - => Spec -genRelativeValiditySpec = do - genRelativeValidSpec @a @b - genRelativeInvalidSpec @a @b - -genRelativeValidSpec :: - forall a b. - ( Typeable a - , Typeable b - , Show a - , Show b - , GenValid a - , GenValid b - , RelativeValidity a b - , GenRelativeValid a b - ) - => Spec -genRelativeValidSpec = - parallel $ do - let nameOne = nameOf @a - let nameTwo = nameOf @a - describe ("GenRelativeValidity " ++ nameOne ++ " " ++ nameTwo) $ - describe ("genValidFor :: " ++ nameTwo ++ " -> Gen " ++ nameOne) $ - it - ("only generates valid \'" ++ - nameOne ++ "\'s for the " ++ nameTwo) $ - genRelativeValidGeneratesValid @a @b - -genRelativeInvalidSpec :: - forall a b. - ( Typeable a - , Typeable b - , Show a - , Show b - , GenValid a - , GenUnchecked b - , GenValid b - , RelativeValidity a b - , GenRelativeInvalid a b - ) - => Spec -genRelativeInvalidSpec = - parallel $ do - let nameOne = nameOf @a - let nameTwo = nameOf @a - describe ("GenRelativeInvalid " ++ nameOne ++ " " ++ nameTwo) $ - describe ("genInvalidFor :: " ++ nameTwo ++ " -> Gen " ++ nameOne) $ - it - ("only generates invalid \'" ++ - nameOne ++ "\'s for the " ++ nameTwo) $ - genRelativeInvalidGeneratesInvalid @a @b - --- | @genValidFor b@ only generates values that satisfy @isValidFor b@ -genRelativeValidGeneratesValid :: - forall a b. - (Show a, Show b, GenValid b, RelativeValidity a b, GenRelativeValid a b) - => Property -genRelativeValidGeneratesValid = - forAllValid $ \(b :: b) -> - forAll (genValidFor b) $ \(a :: a) -> a `shouldSatisfy` (`isValidFor` b) - --- | @genInvalidFor b@ only generates values that do not satisfy @isValidFor b@ -genRelativeInvalidGeneratesInvalid :: - forall a b. - ( Show a - , Show b - , GenUnchecked b - , RelativeValidity a b - , GenRelativeInvalid a b - ) - => Property -genRelativeInvalidGeneratesInvalid = - forAllUnchecked $ \(b :: b) -> - forAll (genInvalidFor b) $ \(a :: a) -> - a `shouldNotSatisfy` (`isValidFor` b) diff --git a/src/Test/Validity/GenValidity.hs b/src/Test/Validity/GenValidity.hs --- a/src/Test/Validity/GenValidity.hs +++ b/src/Test/Validity/GenValidity.hs @@ -1,49 +1,26 @@ -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | Tests for GenValidity instances -- -- You will need @TypeApplications@ to use these. module Test.Validity.GenValidity - ( genValiditySpec - , genValidSpec - , genInvalidSpec - , genValidGeneratesValid - , genGeneratesValid - , genInvalidGeneratesInvalid - , genGeneratesInvalid - ) where + ( genValidSpec, + genValidGeneratesValid, + genGeneratesValid, + genGeneratesInvalid, + ) +where import Data.Data - import Data.GenValidity - import Test.Hspec import Test.QuickCheck - import Test.Validity.GenValidity.Property import Test.Validity.Utils --- | A spec for properties of 'GenValid' and 'GenInvalid' instances. --- --- In general it is a good idea to add this spec to your test suite if you --- write a custom implementation of @genValid@ or @genInvalid@. --- --- __It is not a good idea to use this function if invalid values are broken in such a way that 'Show' or even 'isValid' is broken.__ --- In that case you probably want 'genValidSpec'. --- --- Example usage: --- --- > genValiditySpec @Int -genValiditySpec :: - forall a. (Typeable a, Show a, GenValid a, GenInvalid a) - => Spec -genValiditySpec = do - genValidSpec @a - genInvalidSpec @a - -- | A @Spec@ that specifies that @genValid@ only generates valid data. -- -- In general it is a good idea to add this spec to your test suite if you @@ -53,33 +30,16 @@ -- -- > genValidSpec @Int genValidSpec :: - forall a. (Typeable a, Show a, GenValid a) - => Spec + forall a. + (Typeable a, Show a, GenValid a) => + Spec genValidSpec = - parallel $ do - let name = nameOf @a - describe ("GenValid " ++ name) $ - describe ("genValid :: Gen " ++ name) $ - it ("only generates valid \'" ++ name ++ "\'s") $ - genValidGeneratesValid @a - --- | A @Spec@ that specifies that @genInvalid@ only generates invalid data. --- --- Note that it is not a good idea to use this function if invalid values are broken in such a way that 'Show' or even 'isValid' is broken. --- --- Example usage: --- --- > genInvalidSpec @Rational -genInvalidSpec :: - forall a. (Typeable a, Show a, GenInvalid a) - => Spec -genInvalidSpec = - parallel $ do - let name = nameOf @a - describe ("GenInvalid " ++ name) $ - describe ("genInvalid :: Gen " ++ name) $ - it ("only generates invalid \'" ++ name ++ "\'s") $ - genInvalidGeneratesInvalid @a + parallel $ do + let name = nameOf @a + describe ("GenValid " ++ name) $ + describe ("genValid :: Gen " ++ name) $ + it ("only generates valid \'" ++ name ++ "\'s") $ + genValidGeneratesValid @a -- | @genValid@ only generates valid data -- @@ -94,17 +54,7 @@ -- prop> genValidGeneratesValid @(Maybe Int) -- prop> genValidGeneratesValid @[Int] genValidGeneratesValid :: - forall a. (Show a, GenValid a) - => Property + forall a. + (Show a, GenValid a) => + Property genValidGeneratesValid = genGeneratesValid @a genValid - --- | @genValid@ only generates invalid data --- --- prop> genInvalidGeneratesInvalid @Rational --- prop> genInvalidGeneratesInvalid @Rational --- prop> genInvalidGeneratesInvalid @(Maybe Rational) --- prop> genInvalidGeneratesInvalid @[Rational] -genInvalidGeneratesInvalid :: - forall a. (Show a, GenInvalid a) - => Property -genInvalidGeneratesInvalid = genGeneratesInvalid @a genInvalid diff --git a/src/Test/Validity/Monad.hs b/src/Test/Validity/Monad.hs --- a/src/Test/Validity/Monad.hs +++ b/src/Test/Validity/Monad.hs @@ -1,29 +1,27 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} -- | Monad properties -- -- You will need @TypeApplications@ to use these. module Test.Validity.Monad - ( monadSpecOnValid - , monadSpec - , monadSpecOnArbitrary - , monadSpecOnGens - ) where - -import Data.Data + ( monadSpec, + monadSpecOnArbitrary, + monadSpecOnGens, + ) +where import Control.Monad (ap) +import Data.Data import Data.GenValidity -import Test.QuickCheck.Gen (unGen) -import Test.QuickCheck.Random (mkQCGen) - +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 @@ -44,50 +42,41 @@ {-# ANN module "HLint: ignore Reduce duplication" #-} returnTypeStr :: - forall (m :: * -> *). (Typeable m) - => String + forall (m :: Type -> Type). + (Typeable m) => + String returnTypeStr = unwords ["return", "::", "a", "->", nameOf @m, "a"] bindTypeStr :: - forall (m :: * -> *). (Typeable m) - => String + forall (m :: Type -> Type). + (Typeable m) => + String bindTypeStr = - unwords - [ "(>>=)" - , "::" - , nameOf @m - , "a" - , "->" - , "(b" - , "->" - , nameOf @m - , "a)" - , "->" - , nameOf @m - , "b" - ] + unwords + [ "(>>=)", + "::", + nameOf @m, + "a", + "->", + "(b", + "->", + nameOf @m, + "a)", + "->", + nameOf @m, + "b" + ] -- | Standard test spec for properties of Monad instances for values generated with GenValid instances -- -- Example usage: -- --- > monadSpecOnValid @[] -monadSpecOnValid :: - forall (f :: * -> *). - (Eq (f Int), Show (f Int), Monad f, Typeable f, GenValid (f Int)) - => Spec -monadSpecOnValid = monadSpecWithInts @f genValid - --- | Standard test spec for properties of Monad instances for values generated with GenUnchecked instances --- --- Example usage: --- -- > monadSpec @[] monadSpec :: - forall (f :: * -> *). - (Eq (f Int), Show (f Int), Monad f, Typeable f, GenUnchecked (f Int)) - => Spec -monadSpec = monadSpecWithInts @f genUnchecked + forall (f :: Type -> Type). + (Eq (f Int), Show (f Int), Monad f, Typeable f, GenValid (f Int)) => + Spec +monadSpec = monadSpecWithInts @f genValid -- | Standard test spec for properties of Monad instances for values generated with Arbitrary instances -- @@ -95,35 +84,40 @@ -- -- > monadSpecOnArbitrary @[] monadSpecOnArbitrary :: - forall (f :: * -> *). - (Eq (f Int), Show (f Int), Monad f, Typeable f, Arbitrary (f Int)) - => Spec + forall (f :: Type -> Type). + (Eq (f Int), Show (f Int), Monad f, Typeable f, Arbitrary (f Int)) => + Spec monadSpecOnArbitrary = monadSpecWithInts @f arbitrary monadSpecWithInts :: - forall (f :: * -> *). (Eq (f Int), Show (f Int), Monad f, Typeable f) - => Gen (f Int) - -> Spec + forall (f :: Type -> Type). + (Eq (f Int), Show (f Int), Monad f, Typeable f) => + Gen (f Int) -> + Spec monadSpecWithInts gen = - monadSpecOnGens - @f - @Int - genUnchecked - "int" - gen - (unwords [nameOf @f, "of ints"]) - gen - (unwords [nameOf @f, "of ints"]) - ((+) <$> genUnchecked) - "increments" - (do s <- genListLength - pure $ \b -> unGen gen (mkQCGen b) s) - "perturbations using the int" - (do s <- genListLength - pure $ \b -> unGen gen (mkQCGen $ 2 * b) s) - "perturbations using the double the int" - (pure <$> ((+) <$> genUnchecked)) - (unwords [nameOf @f, "of additions"]) + monadSpecOnGens + @f + @Int + genValid + "int" + gen + (unwords [nameOf @f, "of ints"]) + gen + (unwords [nameOf @f, "of ints"]) + ((+) <$> genValid) + "increments" + ( do + s <- genListLength + pure $ \b -> unGen gen (mkQCGen b) s + ) + "perturbations using the int" + ( do + s <- genListLength + pure $ \b -> unGen gen (mkQCGen $ 2 * b) s + ) + "perturbations using the double the int" + (pure <$> ((+) <$> genValid)) + (unwords [nameOf @f, "of additions"]) -- | Standard test spec for properties of Monad instances for values generated by given generators (and names for those generator). -- @@ -147,107 +141,113 @@ -- > (pure $ pure (+ 1)) -- > "increment in list" monadSpecOnGens :: - forall (f :: * -> *) (a :: *) (b :: *) (c :: *). - ( Show a - , Eq a - , Show (f a) - , Show (f b) - , Show (f c) - , Eq (f a) - , Eq (f b) - , Eq (f c) - , Monad f - , Typeable f - , Typeable a - , Typeable b - , Typeable c - ) - => Gen a - -> String - -> Gen (f a) - -> String - -> Gen (f b) - -> String - -> Gen (a -> b) - -> String - -> Gen (a -> f b) - -> String - -> Gen (b -> f c) - -> String - -> Gen (f (a -> b)) - -> String - -> Spec + forall (f :: Type -> Type) (a :: Type) (b :: Type) (c :: Type). + ( Show a, + Show (f a), + Show (f b), + Show (f c), + Eq (f a), + Eq (f b), + Eq (f c), + Monad f, + Typeable f, + Typeable a, + Typeable b, + Typeable c + ) => + Gen a -> + String -> + Gen (f a) -> + String -> + Gen (f b) -> + String -> + Gen (a -> b) -> + String -> + Gen (a -> f b) -> + String -> + Gen (b -> f c) -> + String -> + Gen (f (a -> b)) -> + String -> + Spec monadSpecOnGens gena genaname gen genname genb genbname geng gengname genbf genbfname gencf gencfname genfab genfabname = - parallel $ + parallel $ describe ("Monad " ++ nameOf @f) $ do - describe (unwords [returnTypeStr @f, "and", bindTypeStr @f]) $ do - it - (unwords - [ "satisfy the first Monad law: 'return a >>= k = k a' for" - , genDescr @a genaname - , "and" - , genDescr @(a -> f b) genbfname - ]) $ - equivalentOnGens2 - (\a (Anon k) -> return a >>= k) - (\a (Anon k) -> k a) - ((,) <$> gena <*> (Anon <$> genbf)) - shrinkNothing - it - (unwords - [ "satisfy the second Monad law: 'm >>= return = m' for" - , genDescr @(f a) genname - ]) $ - equivalentOnGen (\m -> m >>= return) (\m -> m) gen shrinkNothing - describe (bindTypeStr @f) $ - it - (unwords - [ "satisfies the third Monad law: 'm >>= (x -> k x >>= h) = (m >>= k) >>= h' for" - , genDescr @(f a) genname - , genDescr @(a -> f b) genbfname - , "and" - , genDescr @(b -> f c) gencfname - ]) $ - equivalentOnGens3 - (\m (Anon k) (Anon h) -> m >>= (\x -> k x >>= h)) - (\m (Anon k) (Anon h) -> (m >>= k) >>= h) - ((,,) <$> gen <*> (Anon <$> genbf) <*> (Anon <$> gencf)) - shrinkNothing - describe (unwords ["relation with Applicative", nameOf @f]) $ do - it - (unwords - ["satisfies 'pure = return' for", genDescr @(f a) genname]) $ - equivalentOnGen (pure @f) (return @f) gena shrinkNothing - it - (unwords - [ "satisfies '(<*>) = ap' for" - , genDescr @(f (a -> b)) genfabname - , "and" - , genDescr @(f a) genname - ]) $ - equivalentOnGens2 - (\(Anon a) b -> a <*> b) - (\(Anon a) b -> ap a b) - ((,) <$> (Anon <$> genfab) <*> gen) - shrinkNothing - it - (unwords - [ "satisfies '(>>) = (*>)' for" - , genDescr @(f a) genname - , "and" - , genDescr @(f b) genbname - ]) $ - equivalentOnGens2 (>>) (*>) ((,) <$> gen <*> genb) shrinkNothing - describe (unwords ["relation with Functor", nameOf @f]) $ - it - (unwords - [ "satisfies 'fmap f xs = xs >>= return . f' for" - , genDescr @(a -> b) gengname - , "and" - , genDescr @(f a) genname - ]) $ - equivalentOnGens2 - (\(Anon f) xs -> fmap f xs) - (\(Anon f) xs -> xs >>= (return . f)) - ((,) <$> (Anon <$> geng) <*> gen) - shrinkNothing + describe (unwords [returnTypeStr @f, "and", bindTypeStr @f]) $ do + it + ( unwords + [ "satisfy the first Monad law: 'return a >>= k = k a' for", + genDescr @a genaname, + "and", + genDescr @(a -> f b) genbfname + ] + ) + $ equivalentOnGens2 + (\a (Anon k) -> return a >>= k) + (\a (Anon k) -> k a) + ((,) <$> gena <*> (Anon <$> genbf)) + shrinkNothing + it + ( unwords + [ "satisfy the second Monad law: 'm >>= return = m' for", + genDescr @(f a) genname + ] + ) + $ equivalentOnGen (\m -> m >>= return) (\m -> m) gen shrinkNothing + describe (bindTypeStr @f) $ + it + ( unwords + [ "satisfies the third Monad law: 'm >>= (x -> k x >>= h) = (m >>= k) >>= h' for", + genDescr @(f a) genname, + genDescr @(a -> f b) genbfname, + "and", + genDescr @(b -> f c) gencfname + ] + ) + $ equivalentOnGens3 + (\m (Anon k) (Anon h) -> m >>= (\x -> k x >>= h)) + (\m (Anon k) (Anon h) -> (m >>= k) >>= h) + ((,,) <$> gen <*> (Anon <$> genbf) <*> (Anon <$> gencf)) + shrinkNothing + describe (unwords ["relation with Applicative", nameOf @f]) $ do + it + ( unwords + ["satisfies 'pure = return' for", genDescr @(f a) genname] + ) + $ equivalentOnGen (pure @f) (return @f) gena shrinkNothing + it + ( unwords + [ "satisfies '(<*>) = ap' for", + genDescr @(f (a -> b)) genfabname, + "and", + genDescr @(f a) genname + ] + ) + $ equivalentOnGens2 + (\(Anon a) b -> a <*> b) + (\(Anon a) b -> ap a b) + ((,) <$> (Anon <$> genfab) <*> gen) + shrinkNothing + it + ( unwords + [ "satisfies '(>>) = (*>)' for", + genDescr @(f a) genname, + "and", + genDescr @(f b) genbname + ] + ) + $ equivalentOnGens2 (>>) (*>) ((,) <$> gen <*> genb) shrinkNothing + describe (unwords ["relation with Functor", nameOf @f]) $ + it + ( unwords + [ "satisfies 'fmap f xs = xs >>= return . f' for", + genDescr @(a -> b) gengname, + "and", + genDescr @(f a) genname + ] + ) + $ equivalentOnGens2 + (\(Anon f) xs -> fmap f xs) + (\(Anon f) xs -> xs >>= (return . f)) + ((,) <$> (Anon <$> geng) <*> gen) + shrinkNothing diff --git a/src/Test/Validity/Monoid.hs b/src/Test/Validity/Monoid.hs --- a/src/Test/Validity/Monoid.hs +++ b/src/Test/Validity/Monoid.hs @@ -1,44 +1,45 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} -- | Monoid properties -- -- You will need @TypeApplications@ to use these. module Test.Validity.Monoid - ( monoidSpecOnValid - , monoidSpec - , monoidSpecOnArbitrary - , monoidSpecOnGen - ) where + ( 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 + forall a. + Typeable a => + String memptyTypeStr = unwords ["mempty", "::", nameOf @a] mappendTypeStr :: - forall a. Typeable a - => String + forall a. + Typeable a => + String mappendTypeStr = unwords ["mappend", "::", an, "->", an, "->", an] where an = nameOf @a mconcatTypeStr :: - forall a. Typeable a - => String + forall a. + Typeable a => + String mconcatTypeStr = unwords ["mconcat", "::", "[" ++ an ++ "]", "->", an] where an = nameOf @a @@ -49,19 +50,21 @@ -- -- > monoidSpecOnValid @[Double] monoidSpecOnValid :: - forall a. (Show a, Eq a, Monoid a, Typeable a, GenValid a) - => Spec + forall a. + (Show a, Eq a, Monoid a, Typeable a, GenValid a) => + Spec monoidSpecOnValid = monoidSpecOnGen @a genValid "valid" shrinkValid --- | Standard test spec for properties of 'Monoid' instances for unchecked values +-- | 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, GenUnchecked a) - => Spec -monoidSpec = monoidSpecOnGen @a genUnchecked "unchecked" shrinkUnchecked + forall a. + (Show a, Eq a, Monoid a, Typeable a, GenValid a) => + Spec +monoidSpec = monoidSpecOnGen @a genValid "valid" shrinkValid -- | Standard test spec for properties of 'Monoid' instances for arbitrary values -- @@ -69,8 +72,9 @@ -- -- > monoidSpecOnArbitrary @[Int] monoidSpecOnArbitrary :: - forall a. (Show a, Eq a, Monoid a, Typeable a, Arbitrary a) - => Spec + forall a. + (Show a, Eq a, Monoid a, Typeable a, Arbitrary a) => + Spec monoidSpecOnArbitrary = monoidSpecOnGen @a arbitrary "arbitrary" shrink -- | Standard test spec for properties of Monoid instances for values generated by a given generator (and name for that generator). @@ -79,45 +83,49 @@ -- -- > monoidSpecOnGen (pure "a") "singleton list of 'a'" monoidSpecOnGen :: - forall a. (Show a, Eq a, Monoid a, Typeable a) - => Gen a - -> String - -> (a -> [a]) - -> Spec + forall a. + (Show a, Eq a, Monoid a, Typeable a) => + Gen a -> + String -> + (a -> [a]) -> + Spec monoidSpecOnGen gen genname s = - parallel $ do - let name = nameOf @a - memptystr = memptyTypeStr @a - mappendstr = mappendTypeStr @a - mconcatstr = mconcatTypeStr @a - gen3 = (,,) <$> gen <*> gen <*> gen - s3 (a, b, c) = (,,) <$> s a <*> s b <*> s c - genl = genListOf gen - sl = shrinkList s - describe ("Monoid " ++ name) $ do - let mem = mempty @a - mapp = mappend @a - mcon = mconcat @a - describe memptystr $ - it - (unwords - [ "is the identity for" - , mappendstr - , "for" - , genDescr @a genname - ]) $ - identityOnGen mapp mem gen s - describe mappendstr $ - it - (unwords - [ "is an associative operation for" - , genDescr @(a, a, a) genname - ]) $ - associativeOnGens mapp gen3 s3 - describe mconcatstr $ - it - (unwords - [ "is equivalent to its default implementation for" - , genDescr @[a] genname - ]) $ - equivalentOnGen mcon (foldr mapp mem) genl sl + parallel $ do + let name = nameOf @a + memptystr = memptyTypeStr @a + mappendstr = mappendTypeStr @a + mconcatstr = mconcatTypeStr @a + gen3 = (,,) <$> gen <*> gen <*> gen + s3 (a, b, c) = (,,) <$> s a <*> s b <*> s c + genl = genListOf gen + sl = shrinkList s + describe ("Monoid " ++ name) $ do + let mem = mempty @a + mapp = mappend @a + mcon = mconcat @a + describe memptystr $ + it + ( unwords + [ "is the identity for", + mappendstr, + "for", + genDescr @a genname + ] + ) + $ identityOnGen mapp mem gen s + describe mappendstr $ + it + ( unwords + [ "is an associative operation for", + genDescr @(a, a, a) genname + ] + ) + $ associativeOnGens mapp gen3 s3 + describe mconcatstr $ + it + ( unwords + [ "is equivalent to its default implementation for", + genDescr @[a] genname + ] + ) + $ equivalentOnGen mcon (foldr mapp mem) genl sl diff --git a/src/Test/Validity/Ord.hs b/src/Test/Validity/Ord.hs --- a/src/Test/Validity/Ord.hs +++ b/src/Test/Validity/Ord.hs @@ -1,26 +1,22 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} -- | Ord properties -- -- You will need @TypeApplications@ to use these. module Test.Validity.Ord - ( ordSpecOnGen - , ordSpecOnValid - , ordSpecOnInvalid - , ordSpec - , ordSpecOnArbitrary - ) where + ( ordSpec, + ordSpecOnGen, + ordSpecOnArbitrary, + ) +where import Data.Data - import Data.GenValidity - import Test.Hspec import Test.QuickCheck - import Test.Validity.Functions import Test.Validity.Relations import Test.Validity.Utils @@ -34,54 +30,39 @@ {-# ANN module "HLint: ignore Use >" #-} leTypeStr :: - forall a. Typeable a - => String + forall a. + Typeable a => + String leTypeStr = binRelStr @a "<=" geTypeStr :: - forall a. Typeable a - => String + forall a. + Typeable a => + String geTypeStr = binRelStr @a ">=" ltTypeStr :: - forall a. Typeable a - => String + forall a. + Typeable a => + String ltTypeStr = binRelStr @a "<" gtTypeStr :: - forall a. Typeable a - => String + forall a. + Typeable a => + String gtTypeStr = binRelStr @a ">" -- | Standard test spec for properties of Ord instances for valid values -- -- Example usage: -- --- > ordSpecOnValid @Double -ordSpecOnValid :: - forall a. (Show a, Ord a, Typeable a, GenValid a) - => Spec -ordSpecOnValid = ordSpecOnGen @a genValid "valid" shrinkValid - --- | Standard test spec for properties of Ord instances for invalid values --- --- Example usage: --- --- > ordSpecOnInvalid @Double -ordSpecOnInvalid :: - forall a. (Show a, Ord a, Typeable a, GenInvalid a) - => Spec -ordSpecOnInvalid = ordSpecOnGen @a genInvalid "invalid" shrinkInvalid - --- | Standard test spec for properties of Ord instances for unchecked values --- --- Example usage: --- -- > ordSpec @Int ordSpec :: - forall a. (Show a, Ord a, Typeable a, GenUnchecked a) - => Spec -ordSpec = ordSpecOnGen @a genUnchecked "unchecked" shrinkUnchecked + 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 -- @@ -89,8 +70,9 @@ -- -- > ordSpecOnArbitrary @Int ordSpecOnArbitrary :: - forall a. (Show a, Ord a, Typeable a, Arbitrary a) - => Spec + 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). @@ -99,67 +81,70 @@ -- -- > ordSpecOnGen ((* 2) <$> genValid @Int) "even" ordSpecOnGen :: - forall a. (Show a, Eq a, Ord a, Typeable a) - => Gen a - -> String - -> (a -> [a]) - -> Spec + 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 + 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/RelativeValidity.hs b/src/Test/Validity/RelativeValidity.hs deleted file mode 100644 --- a/src/Test/Validity/RelativeValidity.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Tests for RelativeValidity instances --- --- You will need @TypeApplications@ to use these. -module Test.Validity.RelativeValidity - ( relativeValiditySpec - , relativeValidityImpliesValidA - , relativeValidityImpliesValidB - ) where - -import Data.Data - -import Data.GenRelativeValidity -import Data.GenValidity - -import Test.Hspec -import Test.QuickCheck - -import Test.Validity.Property.Utils -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 @MyDataFor @MyOtherData -relativeValiditySpec :: - forall a b. - ( Typeable a - , Typeable b - , Show a - , Show b - , Validity a - , Validity b - , GenUnchecked a - , GenUnchecked b - , RelativeValidity a b - ) - => Spec -relativeValiditySpec = - parallel $ do - let nameOne = nameOf @a - nameTwo = nameOf @b - describe ("RelativeValidity " ++ nameOne ++ " " ++ nameTwo) $ - describe - ("isValidFor :: " ++ nameOne ++ " -> " ++ nameTwo ++ " -> Bool") $ do - it ("implies isValid " ++ nameOne ++ " for any " ++ nameTwo) $ - relativeValidityImpliesValidA @a @b - it ("implies isValid " ++ nameTwo ++ " for any " ++ nameOne) $ - relativeValidityImpliesValidB @a @b - --- | @isValidFor a b@ implies @isValid a@ for all @b@ -relativeValidityImpliesValidA :: - forall a b. - ( Show a - , Show b - , Validity a - , GenUnchecked a - , GenUnchecked b - , RelativeValidity a b - ) - => Property -relativeValidityImpliesValidA = - forAllUnchecked $ \(a :: a) -> - forAllUnchecked $ \(b :: b) -> (a `isValidFor` b) ===> isValid a - --- | @isValidFor a b@ implies @isValid b@ for all @a@ -relativeValidityImpliesValidB :: - forall a b. - ( Show a - , Show b - , Validity b - , GenUnchecked a - , GenUnchecked b - , RelativeValidity a b - ) - => Property -relativeValidityImpliesValidB = - forAllUnchecked $ \(a :: a) -> - forAllUnchecked $ \(b :: b) -> (a `isValidFor` b) ===> isValid b diff --git a/src/Test/Validity/Show.hs b/src/Test/Validity/Show.hs --- a/src/Test/Validity/Show.hs +++ b/src/Test/Validity/Show.hs @@ -5,47 +5,32 @@ -- | 'Show' and 'Read' properties module Test.Validity.Show - ( showReadSpecOnValid - , showReadSpec - , showReadSpecOnArbitrary - , showReadSpecOnGen - , showReadRoundTripOnValid - , showReadRoundTrip - , showReadRoundTripOnArbitrary - , showReadRoundTripOnGen - ) where - -import Data.GenValidity + ( showReadSpec, + showReadSpecOnArbitrary, + showReadSpecOnGen, + showReadRoundTrip, + showReadRoundTripOnArbitrary, + showReadRoundTripOnGen, + ) +where import Data.Data - -import Text.Read - +import 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: -- --- > showReadSpecOnValid @Double -showReadSpecOnValid :: - forall a. (Show a, Eq a, Read a, Typeable a, GenValid a) - => Spec -showReadSpecOnValid = showReadSpecOnGen @a genValid "valid" shrinkValid - --- | Standard test spec for properties of Show and Read instances for unchecked values --- --- Example usage: --- -- > showReadSpec @Int showReadSpec :: - forall a. (Show a, Eq a, Read a, Typeable a, GenUnchecked a) - => Spec -showReadSpec = showReadSpecOnGen @a genUnchecked "unchecked" shrinkUnchecked - + forall a. + (Show a, Eq a, Read a, Typeable a, GenValid a) => + Spec +showReadSpec = showReadSpecOnGen @a genValid "valid" shrinkValid -- | Standard test spec for properties of Show and Read instances for arbitrary values -- @@ -53,8 +38,9 @@ -- -- > showReadSpecOnArbitrary @Double showReadSpecOnArbitrary :: - forall a. (Show a, Eq a, Read a, Typeable a, Arbitrary a) - => Spec + forall a. + (Show a, Eq a, Read a, Typeable a, Arbitrary a) => + Spec showReadSpecOnArbitrary = showReadSpecOnGen @a arbitrary "arbitrary" shrink -- | Standard test spec for properties of Show and Read instances for values generated by a custom generator @@ -63,47 +49,41 @@ -- -- > showReadSpecOnGen ((* 2) <$> genValid @Int) "even" (const []) showReadSpecOnGen :: - forall a. (Show a, Eq a, Read a, Typeable a) - => Gen a - -> String - -> (a -> [a]) - -> Spec + forall a. + (Show a, Eq a, Read a, Typeable a) => + Gen a -> + String -> + (a -> [a]) -> + Spec showReadSpecOnGen gen n s = - describe (unwords ["Show", nameOf @a, "and Read", nameOf @a]) $ + describe (unwords ["Show", nameOf @a, "and Read", nameOf @a]) $ it (unwords ["are implemented such that read . show == id for", n, "values"]) $ - showReadRoundTripOnGen gen s - --- | --- --- prop> showReadRoundTripOnValid @Rational -showReadRoundTripOnValid :: - forall a. (Show a, Eq a, Read a, GenValid a) - => Property -showReadRoundTripOnValid = - showReadRoundTripOnGen (genValid :: Gen a) shrinkValid + showReadRoundTripOnGen gen s -- | -- -- prop> showReadRoundTrip @Int showReadRoundTrip :: - forall a. (Show a, Eq a, Read a, GenUnchecked a) - => Property + forall a. + (Show a, Eq a, Read a, GenValid a) => + Property showReadRoundTrip = - showReadRoundTripOnGen (genUnchecked :: Gen a) shrinkUnchecked + showReadRoundTripOnGen (genValid :: Gen a) shrinkValid -- | -- -- prop> showReadRoundTripOnArbitrary @Double showReadRoundTripOnArbitrary :: - forall a. (Show a, Eq a, Read a, Arbitrary a) - => Property + forall a. + (Show a, Eq a, Read a, Arbitrary a) => + Property showReadRoundTripOnArbitrary = - showReadRoundTripOnGen (arbitrary :: Gen a) shrink + showReadRoundTripOnGen (arbitrary :: Gen a) shrink -- | -- --- prop> showReadRoundTripOnGen (abs <$> genUnchecked :: Gen Int) (const []) +-- prop> showReadRoundTripOnGen (abs <$> genValid :: Gen Int) (const []) showReadRoundTripOnGen :: - (Show a, Eq a, Read a) => Gen a -> (a -> [a]) -> Property + (Show a, Eq a, Read a) => Gen a -> (a -> [a]) -> Property showReadRoundTripOnGen gen s = - forAllShrink gen s $ \v -> readMaybe (show v) `shouldBe` Just v + forAllShrink gen s $ \v -> readMaybe (show v) `shouldBe` Just v diff --git a/src/Test/Validity/Shrinking.hs b/src/Test/Validity/Shrinking.hs --- a/src/Test/Validity/Shrinking.hs +++ b/src/Test/Validity/Shrinking.hs @@ -1,143 +1,89 @@ -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | Tests for Shrinking functions -- -- You will need @TypeApplications@ to use these. module Test.Validity.Shrinking - ( shrinkValiditySpec - , shrinkValidSpec - , shrinkValidSpecWithLimit - , shrinkInvalidSpec - , shrinkValidPreservesValidOnGenValid - , shrinkValidPreservesValidOnGenValidWithLimit - , shrinkInvalidPreservesInvalidOnGenInvalid - , shrinkPreservesValidOnGenValid - , shrinkPreservesInvalidOnGenInvalid - , shrinkValidPreservesValid - , shrinkInvalidPreservesInvalid - , shrinkingStaysValid - , shrinkingStaysInvalid - , shrinkingPreserves - , shrinkUncheckedDoesNotShrinkToItself - , shrinkUncheckedDoesNotShrinkToItselfWithLimit - , shrinkValidDoesNotShrinkToItself - , shrinkValidDoesNotShrinkToItselfWithLimit - , shrinkInvalidDoesNotShrinkToItself - , shrinkInvalidDoesNotShrinkToItselfWithLimit - ) where + ( shrinkValidSpec, + shrinkValidSpecWithLimit, + shrinkValidPreservesValidOnGenValid, + shrinkValidPreservesValidOnGenValidWithLimit, + shrinkPreservesValidOnGenValid, + shrinkValidPreservesValid, + shrinkingStaysValid, + shrinkingPreserves, + shrinkValidDoesNotShrinkToItself, + shrinkValidDoesNotShrinkToItselfWithLimit, + ) +where +import Control.Monad import Data.Data - import Data.GenValidity - -import Control.Monad - import Test.Hspec import Test.QuickCheck - import Test.Validity.Shrinking.Property import Test.Validity.Utils -shrinkValiditySpec :: - forall a. (Show a, Eq a, Typeable a, GenValid a, GenInvalid a) - => Spec -shrinkValiditySpec = do - shrinkValidSpec @a - shrinkInvalidSpec @a - shrinkValidSpec :: - forall a. (Show a, Eq a, Typeable a, GenValid a) - => Spec + forall a. + (Show a, Eq a, Typeable a, GenValid a) => + Spec shrinkValidSpec = - describe ("shrinkValid :: " ++ nameOf @(a -> [a])) $ do - it "preserves validity" $ - forAll (genValid @a) $ \a -> forM_ (shrinkValid a) shouldBeValid - it "never shrinks to itself for valid values" $ - shrinkValidDoesNotShrinkToItself @a + describe ("shrinkValid :: " ++ nameOf @(a -> [a])) $ do + it "preserves validity" $ + forAll (genValid @a) $ \a -> forM_ (shrinkValid a) shouldBeValid + it "never shrinks to itself for valid values" $ + shrinkValidDoesNotShrinkToItself @a shrinkValidSpecWithLimit :: - forall a. (Show a, Eq a, Typeable a, GenUnchecked a, GenValid a) - => Int - -> Spec + forall a. + (Show a, Eq a, Typeable a, GenValid a) => + Int -> + Spec shrinkValidSpecWithLimit l = - describe ("shrinkValid :: " ++ nameOf @(a -> [a])) $ do - it (unwords ["preserves validity for the first", show l, "elements"]) $ - forAll (genValid @a) $ \a -> - forM_ (take l $ shrinkValid a) shouldBeValid - it - (unwords - [ "never shrinks to itself for valid values for the first" - , show l - , "elements" - ]) $ - shrinkValidDoesNotShrinkToItselfWithLimit @a l - -shrinkInvalidSpec :: - forall a. (Show a, Typeable a, GenInvalid a) - => Spec -shrinkInvalidSpec = - describe ("shrinkInvalid :: " ++ nameOf @(a -> [a])) $ do - it "preserves invalidity" $ - forAll (genInvalid @a) $ \a -> - forM_ (shrinkInvalid a) shouldBeInvalid + describe ("shrinkValid :: " ++ nameOf @(a -> [a])) $ do + it (unwords ["preserves validity for the first", show l, "elements"]) $ + forAll (genValid @a) $ \a -> + forM_ (take l $ shrinkValid a) shouldBeValid + it + ( unwords + [ "never shrinks to itself for valid values for the first", + show l, + "elements" + ] + ) + $ shrinkValidDoesNotShrinkToItselfWithLimit @a l shrinkValidPreservesValidOnGenValid :: - forall a. (Show a, GenValid a) - => Property + forall a. + (Show a, GenValid a) => + Property shrinkValidPreservesValidOnGenValid = - shrinkingStaysValid @a genValid shrinkValid + shrinkingStaysValid @a genValid shrinkValid shrinkValidPreservesValidOnGenValidWithLimit :: - forall a. (Show a, GenValid a) - => Int - -> Property + forall a. + (Show a, GenValid a) => + Int -> + Property shrinkValidPreservesValidOnGenValidWithLimit = - shrinkingStaysValidWithLimit @a genValid shrinkValid - -shrinkInvalidPreservesInvalidOnGenInvalid :: - forall a. (Show a, GenInvalid a) - => Property -shrinkInvalidPreservesInvalidOnGenInvalid = - shrinkingStaysInvalid @a genInvalid shrinkInvalid - -shrinkUncheckedDoesNotShrinkToItself :: - forall a. (Show a, Eq a, GenUnchecked a) - => Property -shrinkUncheckedDoesNotShrinkToItself = - shrinkDoesNotShrinkToItself @a shrinkUnchecked + shrinkingStaysValidWithLimit @a genValid shrinkValid shrinkValidDoesNotShrinkToItself :: - forall a. (Show a, Eq a, GenValid a) - => Property + forall a. + (Show a, Eq a, GenValid a) => + Property shrinkValidDoesNotShrinkToItself = - shrinkDoesNotShrinkToItselfOnValid @a shrinkValid - -shrinkInvalidDoesNotShrinkToItself :: - forall a. (Show a, Eq a, GenInvalid a) - => Property -shrinkInvalidDoesNotShrinkToItself = - shrinkDoesNotShrinkToItselfOnInvalid @a shrinkInvalid - -shrinkInvalidDoesNotShrinkToItselfWithLimit :: - forall a. (Show a, Eq a, GenUnchecked a, GenInvalid a) - => Int - -> Property -shrinkInvalidDoesNotShrinkToItselfWithLimit = - shrinkDoesNotShrinkToItselfWithLimit @a shrinkInvalid + shrinkDoesNotShrinkToItself @a shrinkValid shrinkValidDoesNotShrinkToItselfWithLimit :: - forall a. (Show a, Eq a, GenUnchecked a, GenValid a) - => Int - -> Property + forall a. + (Show a, Eq a, GenValid a) => + Int -> + Property shrinkValidDoesNotShrinkToItselfWithLimit = - shrinkDoesNotShrinkToItselfWithLimit @a shrinkValid - -shrinkUncheckedDoesNotShrinkToItselfWithLimit :: - forall a. (Show a, Eq a, GenUnchecked a) - => Int - -> Property -shrinkUncheckedDoesNotShrinkToItselfWithLimit = - shrinkDoesNotShrinkToItselfWithLimit @a shrinkUnchecked + shrinkDoesNotShrinkToItselfOnValidWithLimit @a shrinkValid diff --git a/src/Test/Validity/Utils.hs b/src/Test/Validity/Utils.hs --- a/src/Test/Validity/Utils.hs +++ b/src/Test/Validity/Utils.hs @@ -1,41 +1,38 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -- | Utilities for defining your own validity 'Spec's -- -- You will need @TypeApplications@ to use these. module Test.Validity.Utils - ( nameOf - , genDescr - , binRelStr - , shouldFail - , failsBecause - , Anon(..) - , shouldBeValid - , shouldBeInvalid - ) where + ( nameOf, + genDescr, + binRelStr, + shouldFail, + failsBecause, + Anon (..), + shouldBeValid, + shouldBeInvalid, + ) +where -import Control.Monad.Trans.Writer (mapWriterT) 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 nameOf :: - forall a. Typeable a - => String + forall a. + Typeable a => + String nameOf = let s = show $ typeRep (Proxy @a) in if ' ' `elem` s @@ -43,27 +40,29 @@ else s genDescr :: - forall a. Typeable a - => String - -> String + forall a. + Typeable a => + String -> + String genDescr genname = unwords ["\"" ++ genname, "::", nameOf @a ++ "\""] binRelStr :: - forall a. Typeable a - => String - -> String + forall a. + Typeable a => + String -> + String binRelStr op = unwords ["(" ++ op ++ ")", "::", name, "->", name, "->", "Bool"] where name = nameOf @a -newtype Anon a = - Anon a +newtype Anon a + = Anon a instance Show (Anon a) where - show _ = "Anonymous" + show _ = "Anonymous" instance Functor Anon where - fmap f (Anon a) = Anon (f a) + 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. @@ -80,56 +79,36 @@ where go :: SpecTree () -> SpecTree () go sp = - Leaf - Item - { itemRequirement = s - , itemLocation = Nothing -#if MIN_VERSION_hspec_core(2,6,0) - , itemIsFocused = False -#endif -#if MIN_VERSION_hspec_core(2,5,0) - , itemIsParallelizable = Nothing -#else - , itemIsParallelizable = False -#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 - } -#if MIN_VERSION_hspec_core(2,4,0) -#if MIN_VERSION_hspec_core(2,5,0) -produceResult :: Bool -> Test.Hspec.Core.Spec.Result -produceResult succesful = Result - { resultInfo = "" - , resultStatus = - if succesful - then Success - else Failure Nothing $ Reason "Should have failed but didn't." - } -#else -produceResult :: Bool -> Either a Test.Hspec.Core.Spec.Result -produceResult succesful = - Right $ - if succesful - then Success - else Failure Nothing $ Reason "Should have failed but didn't." -#endif -#else + Leaf + Item + { itemRequirement = s, + itemLocation = Nothing, + itemIsFocused = False, + itemIsParallelizable = Nothing, + itemExample = + \_ _ _ -> do + let conf = + defaultConfig {configFormatter = Just silent} + r <- hspecWithResult conf $ fromSpecList [sp] + let succesful = + summaryExamples r > 0 && summaryFailures r > 0 + pure $ produceResult succesful + } + produceResult :: Bool -> Test.Hspec.Core.Spec.Result produceResult succesful = - if succesful - then Success - else Fail Nothing "Should have failed but didn't." -#endif + Result + { resultInfo = "", + resultStatus = + if succesful + then Success + else Failure Nothing $ 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 - } + mapResult $ \res -> + res + { reason = unwords ["Should have failed:", reason res], + expect = not $ expect res + } diff --git a/test/Test/Validity/ApplicativeSpec.hs b/test/Test/Validity/ApplicativeSpec.hs --- a/test/Test/Validity/ApplicativeSpec.hs +++ b/test/Test/Validity/ApplicativeSpec.hs @@ -2,47 +2,44 @@ module Test.Validity.ApplicativeSpec where -import Test.Hspec - import Data.GenValidity +import Test.Hspec import Test.Validity.Applicative spec :: Spec spec = do - applicativeSpecOnValid @[] - applicativeSpecOnValid @Maybe - applicativeSpec @(Either Int) - applicativeSpec @[] - applicativeSpec @Maybe - applicativeSpecOnArbitrary @[] - applicativeSpecOnArbitrary @Maybe - applicativeSpecOnGens - @[] - @Int - (pure 4) - "four" - (genListOf $ pure 5) - "list of fives" - (pure []) - "purely empty list" - ((+) <$> genValid) - "increments" - (pure <$> ((+) <$> genValid)) - "increments in a list" - (pure <$> ((*) <$> genValid)) - "scalings in a list" - applicativeSpecOnGens - @Maybe - @String - (pure "ABC") - "ABC" - (Just <$> pure "ABC") - "Just an ABC" - (pure Nothing) - "purely Nothing" - ((++) <$> genValid) - "prepends" - (pure <$> ((++) <$> genValid)) - "prepends in a Just" - (pure <$> (flip (++) <$> genValid)) - "appends in a Just" + 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 --- a/test/Test/Validity/ArbitrarySpec.hs +++ b/test/Test/Validity/ArbitrarySpec.hs @@ -3,7 +3,6 @@ module Test.Validity.ArbitrarySpec where import Test.Hspec - import Test.Validity.Arbitrary spec :: Spec diff --git a/test/Test/Validity/EqSpec.hs b/test/Test/Validity/EqSpec.hs --- a/test/Test/Validity/EqSpec.hs +++ b/test/Test/Validity/EqSpec.hs @@ -1,34 +1,34 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeApplications #-} --- | Standard 'Spec's for 'Eq' instances. --- --- You will need @TypeApplications@ to use these. module Test.Validity.EqSpec where -import Test.Hspec - import Data.GenValidity +import GHC.Generics (Generic) +import Test.Hspec import Test.Validity.Eq import Test.Validity.Utils spec :: Spec spec = do - eqSpecOnValid @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 + 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) +newtype EqFuncMismatch + = EqFuncMismatch () + deriving (Show, Generic) +instance Validity EqFuncMismatch + instance Eq EqFuncMismatch where - (==) _ _ = True - (/=) _ _ = True + (==) _ _ = True + (/=) _ _ = True -instance GenUnchecked EqFuncMismatch where - genUnchecked = EqFuncMismatch <$> genUnchecked - shrinkUnchecked _ = [] +instance GenValid EqFuncMismatch where + genValid = EqFuncMismatch <$> genValid + shrinkValid _ = [] diff --git a/test/Test/Validity/FunctorSpec.hs b/test/Test/Validity/FunctorSpec.hs --- a/test/Test/Validity/FunctorSpec.hs +++ b/test/Test/Validity/FunctorSpec.hs @@ -1,54 +1,55 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeApplications #-} module Test.Validity.FunctorSpec where -import Test.Hspec - 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) - functorSpecOnValid @[] - functorSpecOnValid @Maybe - functorSpecOnArbitrary @[] - functorSpecOnArbitrary @Maybe - functorSpecOnGens - @[] - @Int - (pure 4) - "four" - (genListOf $ pure 5) - "list of fives" - ((+) <$> genValid) - "increments" - ((*) <$> genValid) - "scalings" - functorSpecOnGens - @Maybe - @String - (pure "ABC") - "ABC" - (Just <$> pure "ABC") - "Just an ABC" - ((++) <$> genValid) - "prepends" - (flip (++) <$> genValid) - "appends" + 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) +newtype Fcks a + = Fcks Int + deriving (Show, Eq, Generic) -instance GenUnchecked (Fcks a) where - genUnchecked = Fcks <$> genUnchecked - shrinkUnchecked (Fcks i) = Fcks <$> shrinkUnchecked i +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 + fmap _ (Fcks i) = Fcks $ i * 2 diff --git a/test/Test/Validity/GenValiditySpec.hs b/test/Test/Validity/GenValiditySpec.hs --- a/test/Test/Validity/GenValiditySpec.hs +++ b/test/Test/Validity/GenValiditySpec.hs @@ -3,11 +3,9 @@ module Test.Validity.GenValiditySpec where import Test.Hspec - import Test.Validity.GenValidity spec :: Spec spec = do - genValiditySpec @Rational - genValidSpec @Rational - genInvalidSpec @Rational + genValidSpec @Rational + genValidSpec @Rational diff --git a/test/Test/Validity/MonadSpec.hs b/test/Test/Validity/MonadSpec.hs --- a/test/Test/Validity/MonadSpec.hs +++ b/test/Test/Validity/MonadSpec.hs @@ -2,53 +2,50 @@ module Test.Validity.MonadSpec where -import Test.Hspec - 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) - monadSpecOnValid @[] - monadSpecOnValid @Maybe - monadSpecOnArbitrary @[] - monadSpecOnArbitrary @Maybe - monadSpecOnGens - @[] - @Int - (pure 4) - "four" - (genListOf $ pure 5) - "list of fives" - (genListOf $ pure 6) - "list of sixes" - ((*) <$> genValid) - "factorisations" - (pure $ \a -> [a]) - "singletonisation" - (pure $ \a -> [a]) - "singletonisation" - (pure $ pure (+ 1)) - "increment in list" - monadSpecOnGens - @Maybe - @String - (pure "ABC") - "ABC" - (Just <$> pure "ABC") - "Just an ABC" - (Just <$> pure "CDE") - "Just an ABC" - (flip (++) <$> genValid) - "appends" - (pure $ \a -> Just a) - "justisation" - (pure $ \a -> Just a) - "justisation" - (pure $ pure (++ "a")) - "append 'a' in Just" + monadSpec @[] + monadSpec @Maybe + monadSpec @(Either Int) + monadSpecOnArbitrary @[] + monadSpecOnArbitrary @Maybe + monadSpecOnGens + @[] + @Int + (pure 4) + "four" + (genListOf $ pure 5) + "list of fives" + (genListOf $ pure 6) + "list of sixes" + ((*) <$> genValid) + "factorisations" + (pure $ \a -> [a]) + "singletonisation" + (pure $ \a -> [a]) + "singletonisation" + (pure $ pure (+ 1)) + "increment in list" + monadSpecOnGens + @Maybe + @String + (pure "ABC") + "ABC" + (Just <$> pure "ABC") + "Just an ABC" + (Just <$> pure "CDE") + "Just an ABC" + (flip (++) <$> genValid) + "appends" + (pure $ \a -> Just a) + "justisation" + (pure $ \a -> Just a) + "justisation" + (pure $ pure (++ "a")) + "append 'a' in Just" diff --git a/test/Test/Validity/MonoidSpec.hs b/test/Test/Validity/MonoidSpec.hs --- a/test/Test/Validity/MonoidSpec.hs +++ b/test/Test/Validity/MonoidSpec.hs @@ -3,12 +3,11 @@ 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 []) + 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 --- a/test/Test/Validity/OrdSpec.hs +++ b/test/Test/Validity/OrdSpec.hs @@ -2,16 +2,15 @@ module Test.Validity.OrdSpec where -import Test.Hspec - import Data.GenValidity +import Test.Hspec import Test.Validity.Ord import Test.Validity.Utils spec :: Spec spec = do - ordSpecOnValid @Rational - failsBecause "NaN >= NaN is False" $ ordSpec @Double - ordSpec @Int - ordSpecOnArbitrary @Int - ordSpecOnGen ((* 2) <$> genValid @Int) "even" (const []) + 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/ShowSpec.hs b/test/Test/Validity/ShowSpec.hs --- a/test/Test/Validity/ShowSpec.hs +++ b/test/Test/Validity/ShowSpec.hs @@ -1,32 +1,32 @@ +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TypeApplications #-} --- | Standard 'Spec's for 'Show' and 'Read' instances. --- --- You will need @TypeApplications@ to use these. module Test.Validity.ShowSpec where -import Test.Hspec - import Data.GenValidity +import GHC.Generics (Generic) +import Test.Hspec import Test.Validity.Show import Test.Validity.Utils spec :: Spec spec = do - showReadSpecOnValid @Rational - showReadSpec @Int - showReadSpecOnArbitrary @Rational - showReadSpecOnGen ((* 2) <$> genValid @Int) "even" (const []) - failsBecause "show and read don't have the correct semantics" $ - showReadSpec @ShowFuncMismatch + 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) +data ShowFuncMismatch + = ShowFuncMismatch + deriving (Eq, Read, Generic) +instance Validity ShowFuncMismatch + instance Show ShowFuncMismatch where - show ShowFuncMismatch = "wrong" + show ShowFuncMismatch = "wrong" -instance GenUnchecked ShowFuncMismatch where - genUnchecked = pure ShowFuncMismatch - shrinkUnchecked _ = [] +instance GenValid ShowFuncMismatch where + genValid = pure ShowFuncMismatch + shrinkValid _ = [] diff --git a/test/Test/Validity/ShrinkingSpec.hs b/test/Test/Validity/ShrinkingSpec.hs --- a/test/Test/Validity/ShrinkingSpec.hs +++ b/test/Test/Validity/ShrinkingSpec.hs @@ -2,30 +2,24 @@ module Test.Validity.ShrinkingSpec where -import Test.Hspec - import Data.Int import Data.Ratio - +import Test.Hspec import Test.Validity.Shrinking spec :: Spec spec = do - shrinkValiditySpec @(Ratio Int8) + shrinkValidSpec @(Ratio Int8) shrinkValidSpec @Int - shrinkInvalidSpec @(Ratio Int8) - describe "shrinkUncheckedPreservesValidOnGenValid" $ do + describe "shrinkValidPreservesValidOnGenValid" $ do it "Ordering" $ shrinkValidPreservesValidOnGenValid @Ordering it "[Ordering]" $ shrinkValidPreservesValidOnGenValid @[Ordering] describe "shrinkValidPreservesValidOnGenValid" $ do it "Ordering" $ shrinkValidPreservesValidOnGenValid @Ordering it "[Ordering]" $ shrinkValidPreservesValidOnGenValid @[Ordering] - describe "shrinkInvalidPreservesInvalidOnGenInvalid" $ do - it "Ordering" $ shrinkInvalidPreservesInvalidOnGenInvalid @(Ratio Int8) - it "[Ordering]" $ shrinkInvalidPreservesInvalidOnGenInvalid @[Ratio Int8] - describe "shrinkUncheckedDoesNotShrinkToItself" $ do - it "Int" $ shrinkUncheckedDoesNotShrinkToItself @Int - it "[Int]" $ shrinkUncheckedDoesNotShrinkToItself @[Int] + describe "shrinkValidDoesNotShrinkToItself" $ do + it "Int" $ shrinkValidDoesNotShrinkToItself @Int + it "[Int]" $ shrinkValidDoesNotShrinkToItself @[Int] describe "shrinkValidDoesNotShrinkToItself" $ do it "Ordering" $ shrinkValidDoesNotShrinkToItself @Ordering it "[Ordering]" $ shrinkValidDoesNotShrinkToItself @[Ordering]