genvalidity-hspec 0.2.0.5 → 1.0.0.4

raw patch · 48 files changed

Files

CHANGELOG.md +77/−0
LICENSE +1/−1
Setup.hs +0/−2
genvalidity-hspec.cabal +86/−57
src/Test/Validity.hs +230/−175
src/Test/Validity/Applicative.hs +296/−0
src/Test/Validity/Arbitrary.hs +36/−50
src/Test/Validity/Eq.hs +122/−39
src/Test/Validity/Functions.hs +0/−103
src/Test/Validity/Functions/CanFail.hs +0/−223
src/Test/Validity/Functions/Equivalence.hs +0/−295
src/Test/Validity/Functions/Idempotence.hs +0/−50
src/Test/Validity/Functions/Inverse.hs +0/−185
src/Test/Validity/Functions/Validity.hs +0/−122
src/Test/Validity/Functor.hs +167/−0
src/Test/Validity/GenRelativeValidity.hs +0/−85
src/Test/Validity/GenValidity.hs +49/−66
src/Test/Validity/Monad.hs +253/−0
src/Test/Validity/Monoid.hs +131/−0
src/Test/Validity/Operations.hs +0/−42
src/Test/Validity/Operations/Associativity.hs +0/−44
src/Test/Validity/Operations/Commutativity.hs +0/−44
src/Test/Validity/Operations/Identity.hs +0/−148
src/Test/Validity/Ord.hs +141/−37
src/Test/Validity/Relations.hs +0/−41
src/Test/Validity/Relations/Antisymmetry.hs +0/−72
src/Test/Validity/Relations/Reflexivity.hs +0/−58
src/Test/Validity/Relations/Symmetry.hs +0/−61
src/Test/Validity/Relations/Transitivity.hs +0/−62
src/Test/Validity/RelativeValidity.hs +0/−77
src/Test/Validity/Show.hs +89/−0
src/Test/Validity/Shrinking.hs +90/−0
src/Test/Validity/Types.hs +0/−25
src/Test/Validity/Utils.hs +119/−14
test/DocTest.hs +0/−4
test/Spec.hs +1/−0
test/Test/Validity/ApplicativeSpec.hs +45/−0
test/Test/Validity/ArbitrarySpec.hs +9/−0
test/Test/Validity/EqSpec.hs +34/−0
test/Test/Validity/FunctorSpec.hs +55/−0
test/Test/Validity/GenRelativeValiditySpec.hs +7/−0
test/Test/Validity/GenValiditySpec.hs +11/−0
test/Test/Validity/MonadSpec.hs +51/−0
test/Test/Validity/MonoidSpec.hs +13/−0
test/Test/Validity/OrdSpec.hs +16/−0
test/Test/Validity/RelativeValiditySpec.hs +7/−0
test/Test/Validity/ShowSpec.hs +32/−0
test/Test/Validity/ShrinkingSpec.hs +25/−0

+ CHANGELOG.md view

@@ -0,0 +1,77 @@+# Changelog++## [1.0.0.4] - 2022-10-04++### Changed++* Compatibility with `hspec >= 2.11.10`.++## [1.0.0.3] - 2022-10-04++### Changed++* Compatibility with `hspec-core >= 2.11`.++## [1.0.0.2] - 2022-09-20++Same as 1.0.0.1, but with the right commit.++## [1.0.0.1] - 2022-09-02++### Changed++* Compatibility with `hspec-core >= 2.10`++## [1.0.0.0] - 2021-11-20++### Changed++* Compatibility with `validity >= 0.12.0.0`+* Compatibility with `genvalidity >= 1.0.0.0`+* Renamed every combinator that ends in `OnValid` (or similar) to not have that suffix anymore.++### Removed++* Every combinator that relates to unchecked or invalid values.+* Everything related to `RelativeValidity`.+++## [0.7.0.3] - 2020-02-10++### Changed++* Removed doctests+* Improved the cabal file+* Fixed the `monadSpec` to not generate the list length using `genUnchecked`++## [0.7.0.2] - 2019-09-23++* Removed nonsense shrinking from `genValidSpec` and `genInvalidSpec`.++## [0.7.0.1] - 2019-09-23++* Removed nonsense shrinking from `arbitraryGeneratesOnlyValid`, `genValidGeneratesValid` and `genInvalidGeneratesInvalid`.++## [0.7.0.0] - 2019-03-06++### Changed++* Fixed compatibility with genvalidity >=0.8++## [0.6.2.3] - 2019-02-28++### Changed++* Clearer docs++## [0.6.2.2] - 2019-01-09++### Changed++* Fixed a forward incompatibility with hspec 2.6.x.++## [0.3.0.1] - 2018-10-07++### Changed++* Compatibility with validity >=0.9, genvalidity >=0.7 and genvalidity-property >=0.3

LICENSE view

@@ -1,6 +1,6 @@ The MIT License (MIT) -Copyright (c) 2016 Tom Sydney Kerckhove+Copyright (c) 2016-2021 Tom Sydney Kerckhove  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal

− Setup.hs

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

genvalidity-hspec.cabal view

@@ -1,64 +1,93 @@-name:                genvalidity-hspec-version:             0.2.0.5-synopsis:            Standard spec's for GenValidity instances-description:         Please see README.md-homepage:            https://github.com/NorfairKing/validity#readme-license:             MIT-license-file:        LICENSE-author:              Tom Sydney Kerckhove-maintainer:          syd.kerckhove@gmail.com-copyright:           Copyright: (c) 2016 Tom Sydney Kerckhove-category:            Testing-build-type:          Simple--- extra-source-files:-cabal-version:       >=1.10+cabal-version: 1.12 +-- This file has been generated from package.yaml by hpack version 0.36.1.+--+-- see: https://github.com/sol/hpack++name:           genvalidity-hspec+version:        1.0.0.4+synopsis:       Standard spec's for GenValidity instances+description:    Note: There are companion packages for this library:+                .+                * <https://hackage.haskell.org/package/genvalidity-hspec-aeson genvalidity-hspec-aeson>+                .+                * <https://hackage.haskell.org/package/genvalidity-hspec-binary genvalidity-hspec-binary>+                .+                * <https://hackage.haskell.org/package/genvalidity-hspec-cereal genvalidity-hspec-cereal>+                .+                * <https://hackage.haskell.org/package/genvalidity-hspec-hashable genvalidity-hspec-hashable>+category:       Testing+homepage:       https://github.com/NorfairKing/validity#readme+bug-reports:    https://github.com/NorfairKing/validity/issues+author:         Tom Sydney Kerckhove+maintainer:     syd@cs-syd.eu+copyright:      Copyright: (c) 2016-2021 Tom Sydney Kerckhove+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    LICENSE+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/NorfairKing/validity+ library-  hs-source-dirs:      src   exposed-modules:       Test.Validity-    , Test.Validity.Arbitrary-    , Test.Validity.Eq-    , Test.Validity.Ord-    , Test.Validity.Functions-    , Test.Validity.Functions.CanFail-    , Test.Validity.Functions.Equivalence-    , Test.Validity.Functions.Idempotence-    , Test.Validity.Functions.Inverse-    , Test.Validity.Functions.Validity-    , Test.Validity.GenValidity-    , Test.Validity.GenRelativeValidity-    , Test.Validity.Operations-    , Test.Validity.Operations.Identity-    , Test.Validity.Operations.Associativity-    , Test.Validity.Operations.Commutativity-    , Test.Validity.Relations-    , Test.Validity.Relations.Antisymmetry-    , Test.Validity.Relations.Reflexivity-    , Test.Validity.Relations.Symmetry-    , Test.Validity.Relations.Transitivity-    , Test.Validity.RelativeValidity-    , Test.Validity.Types-  other-modules:+      Test.Validity.Applicative+      Test.Validity.Arbitrary+      Test.Validity.Eq+      Test.Validity.Functor+      Test.Validity.GenValidity+      Test.Validity.Monad+      Test.Validity.Monoid+      Test.Validity.Ord+      Test.Validity.Show+      Test.Validity.Shrinking       Test.Validity.Utils-  build-depends:       base                               < 5-                     , validity                 >= 0.3 && < 0.4-                     , genvalidity-                     , QuickCheck-                     , hspec                    >= 2.2 && < 2.3-  default-language:    Haskell2010-+  other-modules:+      Paths_genvalidity_hspec+  hs-source-dirs:+      src+  ghc-options: -Wall -fwarn-redundant-constraints+  build-depends:+      QuickCheck+    , base >=4.9 && <5+    , genvalidity >=1.0+    , genvalidity-property >=0.5+    , hspec+    , hspec-core >=2.5.0+    , transformers+    , validity >=0.5+  default-language: Haskell2010 -test-suite genvalidity-hspec-doctests-  default-language:   Haskell2010-  hs-source-dirs:     test-  type:               exitcode-stdio-1.0-  ghc-options:        -threaded-  main-is:            DocTest.hs-  build-depends:      base-    , doctest               >= 0.11      && < 0.12+test-suite genvalidity-hspec-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Test.Validity.ApplicativeSpec+      Test.Validity.ArbitrarySpec+      Test.Validity.EqSpec+      Test.Validity.FunctorSpec+      Test.Validity.GenRelativeValiditySpec+      Test.Validity.GenValiditySpec+      Test.Validity.MonadSpec+      Test.Validity.MonoidSpec+      Test.Validity.OrdSpec+      Test.Validity.RelativeValiditySpec+      Test.Validity.ShowSpec+      Test.Validity.ShrinkingSpec+      Paths_genvalidity_hspec+  hs-source-dirs:+      test/+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+      QuickCheck+    , base >=4.9 && <5+    , genvalidity     , genvalidity-hspec--source-repository head-  type:     git-  location: https://github.com/NorfairKing/validity+    , hspec+    , hspec-core >=2.5.0+  default-language: Haskell2010

src/Test/Validity.hs view

@@ -1,213 +1,268 @@ {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | To use the 'Spec' functions in this module, you will need @TypeApplications@.+--+--+-- The most interesting functions in this module for most uses are:+--+-- * 'genValidSpec'+-- * 'eqSpec'+-- * 'ordSpec'+-- * 'producesValidsOnValids'+-- * 'forAllValid'+-- * 'shouldBeValid' module Test.Validity-    ( module Data.GenValidity-    , Proxy(Proxy)+  ( -- * Writing properties -      -- * Tests for Arbitrary instances involving Validity-    , arbitrarySpec-    , arbitraryGeneratesOnlyValid-    , shrinkProducesOnlyValids+    -- ** Cheap generation with shrinking+    forAllValid, -      -- * Tests for GenValidity instances-    , genValiditySpec-    , genValidityValidGeneratesValid-    , genGeneratesValid-    , genValidityInvalidGeneratesInvalid-    , genGeneratesInvalid+    -- ** Cheap assertions+    shouldBeValid,+    shouldBeInvalid, -      -- * Tests for RelativeValidity instances-    , relativeValiditySpec-    , relativeValidityImpliesValidA-    , relativeValidityImpliesValidB+    -- * Tests for GenValidity instances+    genValidSpec,+    genValidGeneratesValid,+    genGeneratesValid,+    shrinkValidSpec,+    shrinkValidSpecWithLimit,+    shrinkValidPreservesValidOnGenValid,+    shrinkPreservesValidOnGenValid,+    shrinkValidPreservesValid,+    shrinkingStaysValid,+    shrinkingPreserves, -      -- * Tests for GenRelativeValidity instances-    , genRelativeValiditySpec-    , genRelativeValidityValidGeneratesValid-    , genRelativeValidityInvalidGeneratesInvalid+    -- * Tests for Arbitrary instances involving Validity+    arbitrarySpec,+    arbitraryGeneratesOnlyValid, +    -- * Standard tests involving functions -      -- * Standard tests involving functions+    -- ** Standard tests involving validity+    producesValidsOnGen,+    producesValid,+    producesValidsOnArbitrary,+    producesValidsOnGens2,+    producesValid2,+    producesValidsOnArbitrary2,+    producesValidsOnGens3,+    producesValid3,+    producesValidsOnArbitrary3, -      -- ** Standard tests involving validity-    , producesValidsOnGen-    , producesValidsOnValids-    , producesValid-    , producesValidsOnArbitrary-    , producesValidsOnGens2-    , producesValidsOnValids2-    , producesValid2-    , producesValidsOnArbitrary2-    , producesValidsOnGens3-    , producesValidsOnValids3-    , producesValid3-    , producesValidsOnArbitrary3+    -- ** Standard tests involving functions that can fail+    CanFail (..),+    succeedsOnGen,+    succeeds,+    succeedsOnArbitrary,+    succeedsOnGens2,+    succeeds2,+    succeedsOnArbitrary2,+    failsOnGen,+    failsOnGens2,+    validIfSucceedsOnGen,+    validIfSucceedsOnArbitrary,+    validIfSucceeds,+    validIfSucceedsOnGens2,+    validIfSucceeds2,+    validIfSucceedsOnArbitrary2,+    validIfSucceedsOnGens3,+    validIfSucceeds3,+    validIfSucceedsOnArbitrary3, -      -- ** Standard tests involving functions that can fail-    , CanFail(..)+    -- ** Standard tests involving equivalence of functions -    , succeedsOnGen-    , succeedsOnValid-    , succeeds-    , succeedsOnArbitrary+    -- *** Simple functions -    , succeedsOnGens2-    , succeedsOnValids2-    , succeeds2-    , succeedsOnArbitrary2+    -- **** One argument+    equivalentOnGen,+    equivalent,+    equivalentOnArbitrary, -    , failsOnGen-    , failsOnInvalid+    -- **** Two arguments+    equivalentOnGens2,+    equivalent2,+    equivalentOnArbitrary2, -    , failsOnGens2-    , failsOnInvalid2+    -- **** Three arguments+    equivalentOnGens3,+    equivalent3,+    equivalentOnArbitrary3, -    , validIfSucceedsOnGen-    , validIfSucceedsOnValid-    , validIfSucceedsOnArbitrary-    , validIfSucceeds+    -- *** First function can fail -    , validIfSucceedsOnGens2-    , validIfSucceedsOnValids2-    , validIfSucceeds2-    , validIfSucceedsOnArbitrary2+    -- **** One argument+    equivalentWhenFirstSucceedsOnGen,+    equivalentWhenFirstSucceeds,+    equivalentWhenFirstSucceedsOnArbitrary, -      -- ** Standard tests involving equivalence of functions-    , equivalentOnGen-    , equivalentOnValid-    , equivalent-    , equivalentOnGens2-    , equivalentOnValids2-    , equivalent2-    , equivalentWhenFirstSucceedsOnGen-    , equivalentWhenFirstSucceedsOnValid-    , equivalentWhenFirstSucceeds-    , equivalentWhenFirstSucceedsOnGens2-    , equivalentWhenFirstSucceedsOnValids2-    , equivalentWhenFirstSucceeds2-    , equivalentWhenSecondSucceedsOnGen-    , equivalentWhenSecondSucceedsOnValid-    , equivalentWhenSecondSucceeds-    , equivalentWhenSecondSucceedsOnGens2-    , equivalentWhenSecondSucceedsOnValids2-    , equivalentWhenSecondSucceeds2-    , equivalentWhenSucceedOnGen-    , equivalentWhenSucceedOnValid-    , equivalentWhenSucceed-    , equivalentWhenSucceedOnGens2-    , equivalentWhenSucceedOnValids2-    , equivalentWhenSucceed2+    -- **** Two arguments+    equivalentWhenFirstSucceedsOnGens2,+    equivalentWhenFirstSucceeds2,+    equivalentWhenFirstSucceedsOnArbitrary2, -      -- ** Standard tests involving inverse functions-    , inverseFunctionsOnGen-    , inverseFunctionsOnValid-    , inverseFunctions-    , inverseFunctionsOnArbitrary-    , inverseFunctionsIfFirstSucceedsOnGen-    , inverseFunctionsIfFirstSucceedsOnValid-    , inverseFunctionsIfFirstSucceeds-    , inverseFunctionsIfFirstSucceedsOnArbitrary-    , inverseFunctionsIfSecondSucceedsOnGen-    , inverseFunctionsIfSecondSucceedsOnValid-    , inverseFunctionsIfSecondSucceeds-    , inverseFunctionsIfSecondSucceedsOnArbitrary-    , inverseFunctionsIfSucceedOnGen-    , inverseFunctionsIfSucceedOnValid-    , inverseFunctionsIfSucceed-    , inverseFunctionsIfSucceedOnArbitrary+    -- *** Second function can fail -      -- ** Properties involving idempotence-    , idempotentOnGen-    , idempotentOnValid-    , idempotent-    , idempotentOnArbitrary+    -- **** One argument+    equivalentWhenSecondSucceedsOnGen,+    equivalentWhenSecondSucceeds,+    equivalentWhenSecondSucceedsOnArbitrary, +    -- **** Two arguments+    equivalentWhenSecondSucceedsOnGens2,+    equivalentWhenSecondSucceeds2,+    equivalentWhenSecondSucceedsOnArbitrary2, -      -- * Properties of relations+    -- *** Both functions can fail -      -- ** Reflexivity-    , reflexiveOnElem-    , reflexivityOnGen-    , reflexivityOnValid-    , reflexivity-    , reflexivityOnArbitrary+    -- **** One argument+    equivalentWhenSucceedOnGen,+    equivalentWhenSucceed,+    equivalentWhenSucceedOnArbitrary, -      -- ** Transitivity-    , transitiveOnElems-    , transitivityOnGens-    , transitivityOnValid-    , transitivity-    , transitivityOnArbitrary+    -- **** Two arguments+    equivalentWhenSucceedOnGens2,+    equivalentWhenSucceed2,+    equivalentWhenSucceedOnArbitrary2, -      -- ** Antisymmetry-    , antisymmetricOnElemsWithEquality-    , antisymmetryOnGensWithEquality-    , antisymmetryOnGensEq-    , antisymmetryOnValid-    , antisymmetry-    , antisymmetryOnArbitrary+    -- ** Standard tests involving inverse functions+    inverseFunctionsOnGen,+    inverseFunctions,+    inverseFunctionsOnArbitrary,+    inverseFunctionsIfFirstSucceedsOnGen,+    inverseFunctionsIfFirstSucceeds,+    inverseFunctionsIfFirstSucceedsOnArbitrary,+    inverseFunctionsIfSecondSucceedsOnGen,+    inverseFunctionsIfSecondSucceeds,+    inverseFunctionsIfSecondSucceedsOnArbitrary,+    inverseFunctionsIfSucceedOnGen,+    inverseFunctionsIfSucceed,+    inverseFunctionsIfSucceedOnArbitrary, -      -- ** Symmetry-    , symmetricOnElems-    , symmetryOnGens-    , symmetryOnValid-    , symmetry-    , symmetryOnArbitrary+    -- ** Properties involving idempotence+    idempotentOnGen,+    idempotent,+    idempotentOnArbitrary, +    -- * Properties of relations -      -- * Properties of operations+    -- ** Reflexivity+    reflexiveOnElem,+    reflexivityOnGen,+    reflexivity,+    reflexivityOnArbitrary, -      -- ** Identity element+    -- ** Transitivity+    transitiveOnElems,+    transitivityOnGens,+    transitivity,+    transitivityOnArbitrary, -      -- *** Left Identity-    , leftIdentityOnElemWithEquality-    , leftIdentityOnGenWithEquality-    , leftIdentityOnGen-    , leftIdentityOnValid-    , leftIdentity+    -- ** Antisymmetry+    antisymmetricOnElemsWithEquality,+    antisymmetryOnGensWithEquality,+    antisymmetryOnGens,+    antisymmetry,+    antisymmetryOnArbitrary, -      -- *** Right Identity-    , rightIdentityOnElemWithEquality-    , rightIdentityOnGenWithEquality-    , rightIdentityOnGen-    , rightIdentityOnValid-    , rightIdentity+    -- ** Antireflexivity+    antireflexiveOnElem,+    antireflexivityOnGen,+    antireflexivity,+    antireflexivityOnArbitrary, -      -- *** Identity-    , identityOnGen-    , identityOnValid-    , identity+    -- ** Symmetry+    symmetricOnElems,+    symmetryOnGens,+    symmetry,+    symmetryOnArbitrary, -      -- ** Associativity-    , associativeOnGens-    , associativeOnValids-    , associative-    , associativeOnArbitrary+    -- * Properties of operations -      -- ** Commutativity-    , commutativeOnGens-    , commutativeOnValids-    , commutative-    , commutativeOnArbitrary+    -- ** Identity element +    -- *** Left Identity+    leftIdentityOnElemWithEquality,+    leftIdentityOnGenWithEquality,+    leftIdentityOnGen,+    leftIdentity,+    leftIdentityOnArbitrary, -      -- * Eq properties-    , eqSpec+    -- *** Right Identity+    rightIdentityOnElemWithEquality,+    rightIdentityOnGenWithEquality,+    rightIdentityOnGen,+    rightIdentity,+    rightIdentityOnArbitrary, -      -- * Ord properties-    , ordSpec-    ) where+    -- *** Identity+    identityOnGen,+    identity,+    identityOnArbitrary, -import           Data.GenValidity-import           Data.Data+    -- ** Associativity+    associativeOnGens,+    associative,+    associativeOnArbitrary, -import           Test.Validity.Arbitrary-import           Test.Validity.Eq-import           Test.Validity.Functions-import           Test.Validity.GenRelativeValidity-import           Test.Validity.GenValidity-import           Test.Validity.Operations-import           Test.Validity.Ord-import           Test.Validity.Relations-import           Test.Validity.RelativeValidity-import           Test.Validity.Types+    -- ** Commutativity+    commutativeOnGens,+    commutative,+    commutativeOnArbitrary,++    -- * Show and Read properties+    showReadSpec,+    showReadSpecOnArbitrary,+    showReadSpecOnGen,++    -- * Eq properties+    eqSpec,+    eqSpecOnArbitrary,+    eqSpecOnGen,++    -- * Ord properties+    ordSpecOnGen,+    ordSpec,+    ordSpecOnArbitrary,++    -- * Monoid properties+    monoidSpec,+    monoidSpecOnArbitrary,+    monoidSpecOnGen,++    -- * Functor properties+    functorSpec,+    functorSpecOnArbitrary,+    functorSpecOnGens,++    -- * Applicative properties+    applicativeSpec,+    applicativeSpecOnArbitrary,+    applicativeSpecOnGens,++    -- * Monad properties+    monadSpec,+    monadSpecOnArbitrary,+    monadSpecOnGens,++    -- * Re-exports+    module Data.GenValidity,+  )+where++import Data.GenValidity+import Test.Validity.Applicative+import Test.Validity.Arbitrary+import Test.Validity.Eq+import Test.Validity.Functions+import Test.Validity.Functor+import Test.Validity.GenValidity+import Test.Validity.Monad+import Test.Validity.Monoid+import Test.Validity.Operations+import Test.Validity.Ord+import Test.Validity.Property+import Test.Validity.Show+import Test.Validity.Shrinking+import Test.Validity.Utils

+ src/Test/Validity/Applicative.hs view

@@ -0,0 +1,296 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Applicative properties+--+-- You will need @TypeApplications@ to use these.+module Test.Validity.Applicative+  ( applicativeSpec,+    applicativeSpecOnArbitrary,+    applicativeSpecOnGens,+  )+where++import Data.Data+import Data.GenValidity+import Data.Kind+import GHC.Stack+import Test.Hspec+import Test.QuickCheck+import Test.Validity.Functions+import Test.Validity.Utils++{-# ANN module "HLint: ignore Avoid lambda" #-}++pureTypeStr ::+  forall (f :: Type -> Type).+  (Typeable f) =>+  String+pureTypeStr = unwords ["pure", "::", "a", "->", nameOf @f, "a"]++seqTypeStr ::+  forall (f :: Type -> Type).+  (Typeable f) =>+  String+seqTypeStr =+  unwords+    [ "(<*>)",+      "::",+      nameOf @f,+      "(a",+      "->",+      "b)",+      "->",+      nameOf @f,+      "a",+      "->",+      nameOf @f,+      "b"+    ]++seqrTypeStr ::+  forall (f :: Type -> Type).+  (Typeable f) =>+  String+seqrTypeStr =+  unwords+    [ "(*>)",+      "::",+      nameOf @f,+      "a",+      "->",+      nameOf @f,+      "b",+      "->",+      nameOf @f,+      "b"+    ]++seqlTypeStr ::+  forall (f :: Type -> Type).+  (Typeable f) =>+  String+seqlTypeStr =+  unwords+    [ "(<*)",+      "::",+      nameOf @f,+      "a",+      "->",+      nameOf @f,+      "b",+      "->",+      nameOf @f,+      "a"+    ]++-- | Standard test spec for properties of Applicative instances for values generated with GenValid instances+--+-- Example usage:+--+-- > applicativeSpecOnArbitrary @[]+applicativeSpec ::+  forall (f :: Type -> Type).+  ( HasCallStack,+    Eq (f Int),+    Show (f Int),+    Applicative f,+    Typeable f,+    GenValid (f Int)+  ) =>+  Spec+applicativeSpec = withFrozenCallStack $ applicativeSpecWithInts @f genValid++-- | Standard test spec for properties of Applicative instances for values generated with Arbitrary instances+--+-- Example usage:+--+-- > applicativeSpecOnArbitrary @[]+applicativeSpecOnArbitrary ::+  forall (f :: Type -> Type).+  ( HasCallStack,+    Eq (f Int),+    Show (f Int),+    Applicative f,+    Typeable f,+    Arbitrary (f Int)+  ) =>+  Spec+applicativeSpecOnArbitrary = withFrozenCallStack $ applicativeSpecWithInts @f arbitrary++applicativeSpecWithInts ::+  forall (f :: Type -> Type).+  (HasCallStack, Show (f Int), Eq (f Int), Applicative f, Typeable f) =>+  Gen (f Int) ->+  Spec+applicativeSpecWithInts gen =+  withFrozenCallStack $+    applicativeSpecOnGens+      @f+      @Int+      genValid+      "int"+      gen+      (unwords [nameOf @f, "of ints"])+      gen+      (unwords [nameOf @f, "of ints"])+      ((+) <$> genValid)+      "increments"+      (pure <$> ((+) <$> genValid))+      (unwords [nameOf @f, "of increments"])+      (pure <$> ((*) <$> genValid))+      (unwords [nameOf @f, "of scalings"])++-- | Standard test spec for properties of Applicative instances for values generated by given generators (and names for those generator).+--+-- Unless you are building a specific regression test, you probably want to use the other 'applicativeSpec' functions.+--+-- Example usage:+--+-- > applicativeSpecOnGens+-- >     @Maybe+-- >     @String+-- >     (pure "ABC")+-- >     "ABC"+-- >     (Just <$> pure "ABC")+-- >     "Just an ABC"+-- >     (pure Nothing)+-- >     "purely Nothing"+-- >     ((++) <$> genValid)+-- >     "prepends"+-- >     (pure <$> ((++) <$> genValid))+-- >     "prepends in a Just"+-- >     (pure <$> (flip (++) <$> genValid))+-- >     "appends in a Just"+applicativeSpecOnGens ::+  forall (f :: Type -> Type) (a :: Type) (b :: Type) (c :: Type).+  ( HasCallStack,+    Show a,+    Show (f a),+    Eq (f a),+    Show (f b),+    Eq (f b),+    Show (f c),+    Eq (f c),+    Applicative f,+    Typeable f,+    Typeable a,+    Typeable b,+    Typeable c+  ) =>+  Gen a ->+  String ->+  Gen (f a) ->+  String ->+  Gen (f b) ->+  String ->+  Gen (a -> b) ->+  String ->+  Gen (f (a -> b)) ->+  String ->+  Gen (f (b -> c)) ->+  String ->+  Spec+applicativeSpecOnGens gena genaname gen genname genb genbname genfa genfaname genffa genffaname genffb genffbname =+  withFrozenCallStack $+    parallel $+      describe ("Applicative " ++ nameOf @f) $ do+        describe (unwords [pureTypeStr @f, "and", seqTypeStr @f]) $ do+          it+            ( unwords+                [ "satisfy the identity law: 'pure id <*> v = v' for",+                  genDescr @(f a) genname+                ]+            )+            $ equivalentOnGen (pure id <*>) id gen shrinkNothing+          it+            ( unwords+                [ "satisfy the composition law: 'pure (.) <*> u <*> v <*> w = u <*> (v <*> w)' for",+                  genDescr @(f (b -> c)) genffbname,+                  "composed with",+                  genDescr @(f (a -> b)) genffaname,+                  "and applied to",+                  genDescr @(f a) genname+                ]+            )+            $ equivalentOnGens3+              ( \(Anon u) (Anon v) w ->+                  pure (.)+                    <*> (u :: f (b -> c))+                    <*> (v :: f (a -> b))+                    <*> (w :: f a) ::+                    f c+              )+              (\(Anon u) (Anon v) w -> u <*> (v <*> w) :: f c)+              ((,,) <$> (Anon <$> genffb) <*> (Anon <$> genffa) <*> gen)+              shrinkNothing+          it+            ( unwords+                [ "satisfy the homomorphism law: 'pure f <*> pure x = pure (f x)' for",+                  genDescr @(a -> b) genfaname,+                  "sequenced with",+                  genDescr @a genaname+                ]+            )+            $ equivalentOnGens2+              (\(Anon f) x -> pure f <*> pure x :: f b)+              (\(Anon f) x -> pure $ f x :: f b)+              ((,) <$> (Anon <$> genfa) <*> gena)+              shrinkNothing+          it+            ( unwords+                [ "satisfy the interchange law: 'u <*> pure y = pure ($ y) <*> u' for",+                  genDescr @(f (a -> b)) genffaname,+                  "sequenced with",+                  genDescr @a genaname+                ]+            )+            $ equivalentOnGens2+              (\(Anon u) y -> u <*> pure y :: f b)+              (\(Anon u) y -> pure ($ y) <*> u :: f b)+              ((,) <$> (Anon <$> genffa) <*> gena)+              shrinkNothing+          it+            ( unwords+                [ "satisfy the law about the functor instance: fmap f x = pure f <*> x for",+                  genDescr @(a -> b) genfaname,+                  "mapped over",+                  genDescr @(f a) genname+                ]+            )+            $ equivalentOnGens2+              (\(Anon f) x -> fmap f x)+              (\(Anon f) x -> pure f <*> x)+              ((,) <$> (Anon <$> genfa) <*> gen)+              shrinkNothing+        describe (seqrTypeStr @f)+          $ it+            ( unwords+                [ "is equivalent to its default implementation 'u Type> v = pure (const id) <*> u <*> v' for",+                  genDescr @(f a) genname,+                  "in front of",+                  genDescr @b genbname+                ]+            )+          $ equivalentOnGens2+            (\u v -> u *> v)+            (\u v -> pure (const id) <*> u <*> v)+            ((,) <$> gen <*> genb)+            shrinkNothing+        describe (seqlTypeStr @f)+          $ it+            ( unwords+                [ "is equivalent to its default implementation 'u <* v = pure const <*> u <*> v' for",+                  genDescr @b genbname,+                  "behind",+                  genDescr @(f a) genname+                ]+            )+          $ equivalentOnGens2+            (\u v -> u <* v)+            (\u v -> pure const <*> u <*> v)+            ((,) <$> gen <*> genb)+            shrinkNothing

src/Test/Validity/Arbitrary.hs view

@@ -1,60 +1,46 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Arbitrary-    ( -- * Tests for Arbitrary instances involving Validity-      arbitrarySpec-    , arbitraryGeneratesOnlyValid-    , shrinkProducesOnlyValids-    ) where--import           Data.Data-import           Data.Proxy--import           Data.GenValidity+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} -import           Test.Hspec-import           Test.QuickCheck+-- | Tests for Arbitrary instances involving Validity+--+-- You will need @TypeApplications@ to use these.+module Test.Validity.Arbitrary+  ( arbitrarySpec,+    arbitraryGeneratesOnlyValid,+  )+where -import           Test.Validity.Utils-import           Test.Validity.GenValidity+import Data.Data+import Data.GenValidity+import Test.Hspec+import Test.QuickCheck+import Test.Validity.GenValidity+import Test.Validity.Utils  -- | A @Spec@ that specifies that @arbitrary@ only generates data that--- satisfy @isValid@ and that @shrink@ only produces data that satisfy--- @isValid@.+-- satisfy @isValid@ -- -- Example usage: ----- > arbitrarySpec (Proxy :: Proxy MyData)-arbitrarySpec-    :: (Typeable a, Show a, Validity a, Arbitrary a)-    => Proxy a-    -> Spec-arbitrarySpec proxy = do-    let name = nameOf proxy-    describe ("Arbitrary " ++ name) $ do-        it ("is instantiated such that 'arbitrary' only generates valid \'"-            ++ name-            ++ "\'s.") $-            arbitraryGeneratesOnlyValid proxy--        it ("is instantiated such that 'shrink' only produces valid \'"-            ++ name-            ++ "\'s.") $-            forAll arbitrary $ \a ->-                shrink (a `asProxyTypeOf` proxy) `shouldSatisfy` all isValid+-- > arbitrarySpec @Int+arbitrarySpec ::+  forall a.+  (Typeable a, Show a, Validity a, Arbitrary a) =>+  Spec+arbitrarySpec = do+  let name = nameOf @a+  describe ("Arbitrary " ++ name) $+    describe ("arbitrary :: Gen " ++ name) $+      it "only generates valid values" $+        arbitraryGeneratesOnlyValid @a  -- | @arbitrary@ only generates valid data-arbitraryGeneratesOnlyValid-    :: forall a. (Show a, Validity a, Arbitrary a)-    => Proxy a-    -> Property-arbitraryGeneratesOnlyValid _ =-    genGeneratesValid (arbitrary :: Gen a)---- | @shrink@, applied to valid data only produces valid data-shrinkProducesOnlyValids-    :: forall a. (Show a, Validity a, Arbitrary a)-    => Proxy a-    -> Property-shrinkProducesOnlyValids _ =-    genGeneratesValid (shrink <$> arbitrary :: Gen [a])+--+-- prop> arbitraryGeneratesOnlyValid @Int+arbitraryGeneratesOnlyValid ::+  forall a.+  (Show a, Validity a, Arbitrary a) =>+  Property+arbitraryGeneratesOnlyValid = genGeneratesValid @a arbitrary

src/Test/Validity/Eq.hs view

@@ -1,47 +1,130 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Eq-    ( -- * Eq properties-      eqSpec-    ) where--import           Data.Data-import           Data.Proxy+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} -import           Data.GenValidity+-- | Eq properties+--+-- You will need @TypeApplications@ to use these.+module Test.Validity.Eq+  ( eqSpec,+    eqSpecOnArbitrary,+    eqSpecOnGen,+  )+where -import           Test.Hspec+import Data.Data+import Data.GenValidity+import Test.Hspec+import Test.QuickCheck+import Test.Validity.Functions+import Test.Validity.Relations+import Test.Validity.Utils -import           Test.Validity.Relations-import           Test.Validity.Utils+eqTypeStr ::+  forall a.+  (Typeable a) =>+  String+eqTypeStr = binRelStr @a "==" -eqSpec-    :: (Show a, Eq a, Typeable a, GenValidity a)-    => Proxy a-    -> Spec-eqSpec proxy = do-    let name = nameOf proxy-        funeqstr = unwords-          [ "(==) ::"-          , name-          , "->"-          , name-          , "-> Bool"-          ]-        eq a b = a `asProxyTypeOf` proxy == b-    describe ("Eq " ++ name) $ do-        it ("is instantated such that "-            ++ funeqstr-            ++ " is reflexive") $-            reflexivity eq+neqTypeStr ::+  forall a.+  (Typeable a) =>+  String+neqTypeStr = binRelStr @a "/=" -        it ("is instantated such that "-            ++ funeqstr-            ++ " is symmetric") $-            symmetry eq+-- | Standard test spec for properties of Eq instances for valid values+--+-- Example usage:+--+-- > eqSpec @Int+eqSpec ::+  forall a.+  (Show a, Eq a, Typeable a, GenValid a) =>+  Spec+eqSpec = eqSpecOnGen @a genValid "valid" shrinkValid -        it ("is instantated such that "-            ++ funeqstr-            ++ " is transitive") $-            transitivity eq+-- | Standard test spec for properties of Eq instances for arbitrary values+--+-- Example usage:+--+-- > eqSpecOnArbitrary @Int+eqSpecOnArbitrary ::+  forall a.+  (Show a, Eq a, Typeable a, Arbitrary a) =>+  Spec+eqSpecOnArbitrary = eqSpecOnGen @a arbitrary "arbitrary" shrink +-- | Standard test spec for properties of Eq instances for values generated by a given generator (and name for that generator).+--+-- Example usage:+--+-- > eqSpecOnGen ((* 2) <$> genValid @Int) "even"+eqSpecOnGen ::+  forall a.+  (Show a, Eq a, Typeable a) =>+  Gen a ->+  String ->+  (a -> [a]) ->+  Spec+eqSpecOnGen gen genname s =+  parallel $ do+    let name = nameOf @a+        funeqstr = eqTypeStr @a+        funneqstr = neqTypeStr @a+        gen2 = (,) <$> gen <*> gen+        gen3 = (,,) <$> gen <*> gen <*> gen+        s2 = shrinkT2 s+    describe ("Eq " ++ name) $ do+      let eq = (==) @a+          neq = (/=) @a+      describe funeqstr $ do+        it+          ( unwords+              [ "is reflexive for",+                "\"" ++ genname,+                name ++ "\"" ++ "s"+              ]+          )+          $ reflexivityOnGen eq gen s+        it+          ( unwords+              [ "is symmetric for",+                "\"" ++ genname,+                name ++ "\"" ++ "s"+              ]+          )+          $ symmetryOnGens eq gen2 s+        it+          ( unwords+              [ "is transitive for",+                "\"" ++ genname,+                name ++ "\"" ++ "s"+              ]+          )+          $ transitivityOnGens eq gen3 s+        it+          ( unwords+              [ "is equivalent to (\\a b -> not $ a /= b) for",+                "\"" ++ genname,+                name ++ "\"" ++ "s"+              ]+          )+          $ equivalentOnGens2 eq (\a b -> not $ a `neq` b) gen2 s2+      describe funneqstr $ do+        it+          ( unwords+              [ "is antireflexive for",+                "\"" ++ genname,+                name ++ "\"" ++ "s"+              ]+          )+          $ antireflexivityOnGen neq gen s+        it+          ( unwords+              [ "is equivalent to (\\a b -> not $ a == b) for",+                "\"" ++ genname,+                name ++ "\"" ++ "s"+              ]+          )+          $ equivalentOnGens2 neq (\a b -> not $ a `eq` b) gen2 s2

− src/Test/Validity/Functions.hs

@@ -1,103 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Functions-    ( -- * Validity tests involving functions--      -- ** Standard tests involving validity-      producesValidsOnGen-    , producesValidsOnValids-    , producesValid-    , producesValidsOnArbitrary-    , producesValidsOnGens2-    , producesValidsOnValids2-    , producesValid2-    , producesValidsOnArbitrary2-    , producesValidsOnGens3-    , producesValidsOnValids3-    , producesValid3-    , producesValidsOnArbitrary3--      -- ** Standard tests involving functions that can fail-    , succeedsOnGen-    , succeedsOnValid-    , succeeds-    , succeedsOnArbitrary--    , succeedsOnGens2-    , succeedsOnValids2-    , succeeds2-    , succeedsOnArbitrary2--    , failsOnGen-    , failsOnInvalid--    , failsOnGens2-    , failsOnInvalid2--    , validIfSucceedsOnGen-    , validIfSucceedsOnValid-    , validIfSucceedsOnArbitrary-    , validIfSucceeds--    , validIfSucceedsOnGens2-    , validIfSucceedsOnValids2-    , validIfSucceeds2-    , validIfSucceedsOnArbitrary2--      -- ** Standard tests involving equivalence of functions-    , equivalentOnGen-    , equivalentOnValid-    , equivalent-    , equivalentOnGens2-    , equivalentOnValids2-    , equivalent2-    , equivalentWhenFirstSucceedsOnGen-    , equivalentWhenFirstSucceedsOnValid-    , equivalentWhenFirstSucceeds-    , equivalentWhenFirstSucceedsOnGens2-    , equivalentWhenFirstSucceedsOnValids2-    , equivalentWhenFirstSucceeds2-    , equivalentWhenSecondSucceedsOnGen-    , equivalentWhenSecondSucceedsOnValid-    , equivalentWhenSecondSucceeds-    , equivalentWhenSecondSucceedsOnGens2-    , equivalentWhenSecondSucceedsOnValids2-    , equivalentWhenSecondSucceeds2-    , equivalentWhenSucceedOnGen-    , equivalentWhenSucceedOnValid-    , equivalentWhenSucceed-    , equivalentWhenSucceedOnGens2-    , equivalentWhenSucceedOnValids2-    , equivalentWhenSucceed2--      -- ** Standard tests involving inverse functions-    , inverseFunctionsOnGen-    , inverseFunctionsOnValid-    , inverseFunctions-    , inverseFunctionsOnArbitrary-    , inverseFunctionsIfFirstSucceedsOnGen-    , inverseFunctionsIfFirstSucceedsOnValid-    , inverseFunctionsIfFirstSucceeds-    , inverseFunctionsIfFirstSucceedsOnArbitrary-    , inverseFunctionsIfSecondSucceedsOnGen-    , inverseFunctionsIfSecondSucceedsOnValid-    , inverseFunctionsIfSecondSucceeds-    , inverseFunctionsIfSecondSucceedsOnArbitrary-    , inverseFunctionsIfSucceedOnGen-    , inverseFunctionsIfSucceedOnValid-    , inverseFunctionsIfSucceed-    , inverseFunctionsIfSucceedOnArbitrary--      -- ** Properties involving idempotence-    , idempotentOnGen-    , idempotentOnValid-    , idempotent-    , idempotentOnArbitrary-    ) where--import           Test.Validity.Functions.CanFail-import           Test.Validity.Functions.Equivalence-import           Test.Validity.Functions.Idempotence-import           Test.Validity.Functions.Inverse-import           Test.Validity.Functions.Validity-

− src/Test/Validity/Functions/CanFail.hs

@@ -1,223 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Functions.CanFail-    ( -- ** Standard tests involving functions that can fail-      succeedsOnGen-    , succeedsOnValid-    , succeeds-    , succeedsOnArbitrary--    , succeedsOnGens2-    , succeedsOnValids2-    , succeeds2-    , succeedsOnArbitrary2--    , failsOnGen-    , failsOnInvalid--    , failsOnGens2-    , failsOnInvalid2--    , validIfSucceedsOnGen-    , validIfSucceedsOnValid-    , validIfSucceedsOnArbitrary-    , validIfSucceeds--    , validIfSucceedsOnGens2-    , validIfSucceedsOnValids2-    , validIfSucceeds2-    , validIfSucceedsOnArbitrary2-    ) where--import           Data.GenValidity--import           Test.Hspec-import           Test.QuickCheck--import           Test.Validity.Types---- | The function succeeds if the input is generated by the given generator-succeedsOnGen-    :: (Show a, Show b, Show (f b), CanFail f)-    => (a -> f b)-    -> Gen a-    -> Property-succeedsOnGen func gen-    = forAll gen $ \a -> func a `shouldNotSatisfy` hasFailed---- | The function succeeds if the input is generated by @genValid@-succeedsOnValid-    :: (Show a, Show b, Show (f b), GenValidity a, CanFail f)-    => (a -> f b)-    -> Property-succeedsOnValid = (`succeedsOnGen` genValid)---- | The function succeeds if the input is generated by @genUnchecked@-succeeds-    :: (Show a, Show b, Show (f b), GenValidity a, CanFail f)-    => (a -> f b)-    -> Property-succeeds = (`succeedsOnGen` genUnchecked)---- | The function succeeds if the input is generated by @arbitrary@-succeedsOnArbitrary-    :: (Show a, Show b, Show (f b), Arbitrary a, CanFail f)-    => (a -> f b)-    -> Property-succeedsOnArbitrary = (`succeedsOnGen` arbitrary)---- | The function fails if the input is generated by the given generator-failsOnGen-    :: (Show a, Show b, Show (f b), CanFail f)-    => (a -> f b)-    -> Gen a-    -> Property-failsOnGen func gen-    = forAll gen $ \a -> func a `shouldSatisfy` hasFailed---- | The function fails if the input is generated by @genInvalid@-failsOnInvalid-    :: (Show a, Show b, Show (f b), GenValidity a, CanFail f)-    => (a -> f b)-    -> Property-failsOnInvalid = (`failsOnGen` genInvalid)---- | The function produces output that satisfies @isValid@ if it is given input--- that is generated by the given generator.-validIfSucceedsOnGen-    :: (Show a, Show b, Show (f b), Validity b, CanFail f)-    => (a -> f b)-    -> Gen a-    -> Property-validIfSucceedsOnGen func gen-    = forAll gen $ \a ->-        case resultIfSucceeded (func a) of-            Nothing  -> return () -- Can happen-            Just res -> res `shouldSatisfy` isValid---- | The function produces output that satisfies @isValid@ if it is given input--- that is generated by @arbitrary@.-validIfSucceedsOnValid-    :: (Show a, Show b, Show (f b), GenValidity a, Validity b, CanFail f)-    => (a -> f b)-    -> Property-validIfSucceedsOnValid = (`validIfSucceedsOnGen` genValid)----- | The function produces output that satisfies @isValid@ if it is given input--- that is generated by @arbitrary@.-validIfSucceedsOnArbitrary-    :: (Show a, Show b, Show (f b), Arbitrary a, Validity b, CanFail f)-    => (a -> f b)-    -> Property-validIfSucceedsOnArbitrary = (`validIfSucceedsOnGen` arbitrary)---- | The function produces output that satisfies @isValid@ if it is given input--- that is generated by @genUnchecked@.-validIfSucceeds-    :: (Show a, Show b, Show (f b), GenValidity a, Validity b, CanFail f)-    => (a -> f b)-    -> Property-validIfSucceeds = (`validIfSucceedsOnGen` genUnchecked)---succeedsOnGens2-    :: (Show a, Show b, Show c, Show (f c),-        CanFail f)-    => (a -> b -> f c)-    -> Gen (a, b)-    -> Property-succeedsOnGens2 func gen =-    forAll gen $ \(a, b) ->-        func a b `shouldNotSatisfy` hasFailed---succeedsOnValids2-    :: (Show a, Show b, Show c, Show (f c),-        GenValidity a, GenValidity b,-        CanFail f)-    => (a -> b -> f c)-    -> Property-succeedsOnValids2 func-    = succeedsOnGens2 func genValid--succeeds2-    :: (Show a, Show b, Show c, Show (f c),-        GenValidity a, GenValidity b,-        CanFail f)-    => (a -> b -> f c)-    -> Property-succeeds2 func-    = succeedsOnGens2 func genUnchecked--succeedsOnArbitrary2-    :: (Show a, Show b, Show c, Show (f c),-        Arbitrary a, Arbitrary b,-        CanFail f)-    => (a -> b -> f c)-    -> Property-succeedsOnArbitrary2 func-    = succeedsOnGens2 func arbitrary---failsOnGens2-    :: (Show a, Show b, Show c, Show (f c),-        CanFail f)-    => (a -> b -> f c)-    -> Gen a -> Gen b-    -> Property-failsOnGens2 func genA genB =-    forAll genA $ \a ->-        forAll genB $ \b ->-            func a b `shouldSatisfy` hasFailed---failsOnInvalid2-    :: (Show a, Show b, Show c, Show (f c),-        GenValidity a, GenValidity b,-        CanFail f)-    => (a -> b -> f c)-    -> Property-failsOnInvalid2 func-    =    failsOnGens2 func genInvalid genUnchecked-    .&&. failsOnGens2 func genUnchecked genInvalid---validIfSucceedsOnGens2-    :: (Show a, Show b, Show c, Show (f c),-        Validity c, CanFail f)-    => (a -> b -> f c)-    -> Gen (a, b)-    -> Property-validIfSucceedsOnGens2 func gen =-    forAll gen $ \(a, b) ->-        case resultIfSucceeded (func a b) of-            Nothing  -> return () -- Can happen-            Just res -> res `shouldSatisfy` isValid--validIfSucceedsOnValids2-    :: (Show a, Show b, Show c, Show (f c),-        GenValidity a, GenValidity b,-        Validity c, CanFail f)-    => (a -> b -> f c)-    -> Property-validIfSucceedsOnValids2 func-    = validIfSucceedsOnGens2 func genValid--validIfSucceeds2-    :: (Show a, Show b, Show c, Show (f c),-        GenValidity a, GenValidity b,-        Validity c, CanFail f)-    => (a -> b -> f c)-    -> Property-validIfSucceeds2 func-    = validIfSucceedsOnGens2 func genUnchecked--validIfSucceedsOnArbitrary2-    :: (Show a, Show b, Show c, Show (f c),-        Arbitrary a, Arbitrary b,-        Validity c, CanFail f)-    => (a -> b -> f c)-    -> Property-validIfSucceedsOnArbitrary2 func-    = validIfSucceedsOnGens2 func arbitrary

− src/Test/Validity/Functions/Equivalence.hs

@@ -1,295 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Functions.Equivalence-    ( -- ** Standard tests involving equivalence of functions-      equivalentOnGen-    , equivalentOnValid-    , equivalent-    , equivalentOnGens2-    , equivalentOnValids2-    , equivalent2-    , equivalentWhenFirstSucceedsOnGen-    , equivalentWhenFirstSucceedsOnValid-    , equivalentWhenFirstSucceeds-    , equivalentWhenFirstSucceedsOnGens2-    , equivalentWhenFirstSucceedsOnValids2-    , equivalentWhenFirstSucceeds2-    , equivalentWhenSecondSucceedsOnGen-    , equivalentWhenSecondSucceedsOnValid-    , equivalentWhenSecondSucceeds-    , equivalentWhenSecondSucceedsOnGens2-    , equivalentWhenSecondSucceedsOnValids2-    , equivalentWhenSecondSucceeds2-    , equivalentWhenSucceedOnGen-    , equivalentWhenSucceedOnValid-    , equivalentWhenSucceed-    , equivalentWhenSucceedOnGens2-    , equivalentWhenSucceedOnValids2-    , equivalentWhenSucceed2-    ) where--import           Data.GenValidity--import           Test.Hspec-import           Test.QuickCheck--import           Test.Validity.Types--equivalentOnGen-    :: (Show a, Eq a, Show b, Eq b)-    => (a -> b)-    -> (a -> b)-    -> Gen a-    -> Property-equivalentOnGen f g gen =-    forAll gen $ \a ->-        f a `shouldBe` g a--equivalentOnValid-    :: (Show a, Eq a, GenValidity a, Show b, Eq b)-    => (a -> b)-    -> (a -> b)-    -> Property-equivalentOnValid f g-    = equivalentOnGen f g genValid--equivalent-    :: (Show a, Eq a, GenValidity a, Show b, Eq b)-    => (a -> b)-    -> (a -> b)-    -> Property-equivalent f g-    = equivalentOnGen f g genUnchecked--equivalentOnGens2-    :: (Show a, Eq a,-        Show b, Eq b,-        Show c, Eq c)-    => (a -> b -> c)-    -> (a -> b -> c)-    -> Gen (a, b)-    -> Property-equivalentOnGens2 f g gen =-    forAll gen $ \(a, b) ->-        f a b `shouldBe` g a b--equivalentOnValids2-    :: (Show a, Eq a, GenValidity a,-        Show b, Eq b, GenValidity b,-        Show c, Eq c)-    => (a -> b -> c)-    -> (a -> b -> c)-    -> Property-equivalentOnValids2 f g-    = equivalentOnGens2 f g genValid--equivalent2-    :: (Show a, Eq a, GenValidity a,-        Show b, Eq b, GenValidity b,-        Show c, Eq c)-    => (a -> b -> c)-    -> (a -> b -> c)-    -> Property-equivalent2 f g-    = equivalentOnGens2 f g genUnchecked--equivalentWhenFirstSucceedsOnGen-    :: (Show a, Eq a, Show b, Eq b, CanFail f)-    => (a -> f b)-    -> (a -> b)-    -> Gen a-    -> Property-equivalentWhenFirstSucceedsOnGen f g gen =-    forAll gen $ \a ->-        case resultIfSucceeded (f a) of-            Nothing -> return () -- fine-            Just r  -> r `shouldBe` g a--equivalentWhenFirstSucceedsOnValid-    :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f)-    => (a -> f b)-    -> (a -> b)-    -> Property-equivalentWhenFirstSucceedsOnValid f g-    = equivalentWhenFirstSucceedsOnGen f g genValid--equivalentWhenFirstSucceeds-    :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f)-    => (a -> f b)-    -> (a -> b)-    -> Property-equivalentWhenFirstSucceeds f g-    = equivalentWhenFirstSucceedsOnGen f g genUnchecked--equivalentWhenFirstSucceedsOnGens2-    :: (Show a, Eq a,-        Show b, Eq b,-        Show c, Eq c,-        CanFail f)-    => (a -> b -> f c)-    -> (a -> b -> c)-    -> Gen (a, b)-    -> Property-equivalentWhenFirstSucceedsOnGens2 f g gen =-    forAll gen $ \(a, b) ->-        case resultIfSucceeded (f a b) of-            Nothing -> return () -- fine-            Just rs -> rs `shouldBe` g a b--equivalentWhenFirstSucceedsOnValids2-    :: (Show a, Eq a, GenValidity a,-        Show b, Eq b, GenValidity b,-        Show c, Eq c,-        CanFail f)-    => (a -> b -> f c)-    -> (a -> b -> c)-    -> Property-equivalentWhenFirstSucceedsOnValids2 f g-    = equivalentWhenFirstSucceedsOnGens2 f g genValid--equivalentWhenFirstSucceeds2-    :: (Show a, Eq a, GenValidity a,-        Show b, Eq b, GenValidity b,-        Show c, Eq c,-        CanFail f)-    => (a -> b -> f c)-    -> (a -> b -> c)-    -> Property-equivalentWhenFirstSucceeds2 f g-    = equivalentWhenFirstSucceedsOnGens2 f g genUnchecked--equivalentWhenSecondSucceedsOnGen-    :: (Show a, Eq a, Show b, Eq b, CanFail f)-    => (a -> b)-    -> (a -> f b)-    -> Gen a-    -> Property-equivalentWhenSecondSucceedsOnGen f g gen =-    forAll gen $ \a ->-        case resultIfSucceeded (g a) of-            Nothing -> return () -- fine-            Just r  -> r `shouldBe` f a--equivalentWhenSecondSucceedsOnValid-    :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f)-    => (a -> b)-    -> (a -> f b)-    -> Property-equivalentWhenSecondSucceedsOnValid f g-    = equivalentWhenSecondSucceedsOnGen f g genValid--equivalentWhenSecondSucceeds-    :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f)-    => (a -> b)-    -> (a -> f b)-    -> Property-equivalentWhenSecondSucceeds f g-    = equivalentWhenSecondSucceedsOnGen f g genUnchecked--equivalentWhenSecondSucceedsOnGens2-    :: (Show a, Eq a,-        Show b, Eq b,-        Show c, Eq c,-        CanFail f)-    => (a -> b -> c)-    -> (a -> b -> f c)-    -> Gen (a, b)-    -> Property-equivalentWhenSecondSucceedsOnGens2 f g gen =-    forAll gen $ \(a, b) ->-        case resultIfSucceeded (g a b) of-            Nothing -> return () -- fine-            Just rs -> rs `shouldBe` f a b--equivalentWhenSecondSucceedsOnValids2-    :: (Show a, Eq a, GenValidity a,-         Show b, Eq b, GenValidity b,-         Show c, Eq c,-         CanFail f)-    => (a -> b -> c)-    -> (a -> b -> f c)-    -> Property-equivalentWhenSecondSucceedsOnValids2 f g-    = equivalentWhenSecondSucceedsOnGens2 f g genValid--equivalentWhenSecondSucceeds2-    :: (Show a, Eq a, GenValidity a,-        Show b, Eq b, GenValidity b,-        Show c, Eq c,-        CanFail f)-    => (a -> b -> c)-    -> (a -> b -> f c)-    -> Property-equivalentWhenSecondSucceeds2 f g-    = equivalentWhenSecondSucceedsOnGens2 f g genUnchecked--equivalentWhenSucceedOnGen-    :: (Show a, Eq a, Show b, Eq b, CanFail f)-    => (a -> f b)-    -> (a -> f b)-    -> Gen a-    -> Property-equivalentWhenSucceedOnGen f g gen =-    forAll gen $ \a ->-        case do fa <- resultIfSucceeded $ f a-                ga <- resultIfSucceeded $ g a-                return (fa, ga)-            of-            Nothing -> return () -- fine-            Just (fa, ga)  -> fa `shouldBe` ga--equivalentWhenSucceedOnValid-    :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f)-    => (a -> f b)-    -> (a -> f b)-    -> Property-equivalentWhenSucceedOnValid f g-    = equivalentWhenSucceedOnGen f g genValid--equivalentWhenSucceed-    :: (Show a, Eq a, GenValidity a, Show b, Eq b, CanFail f)-    => (a -> f b)-    -> (a -> f b)-    -> Property-equivalentWhenSucceed f g-    = equivalentWhenSucceedOnGen f g genUnchecked--equivalentWhenSucceedOnGens2-    :: (Show a, Eq a,-        Show b, Eq b,-        Show c, Eq c,-        CanFail f)-    => (a -> b -> f c)-    -> (a -> b -> f c)-    -> Gen (a, b)-    -> Property-equivalentWhenSucceedOnGens2 f g gen =-    forAll gen $ \(a, b) ->-        case do fab <- resultIfSucceeded $ f a b-                gab <- resultIfSucceeded $ g a b-                return (fab, gab)-                of-            Nothing -> return () -- fine-            Just (fab, gab) -> fab `shouldBe` gab--equivalentWhenSucceedOnValids2-    :: (Show a, Eq a, GenValidity a,-        Show b, Eq b, GenValidity b,-        Show c, Eq c,-        CanFail f)-    => (a -> b -> f c)-    -> (a -> b -> f c)-    -> Property-equivalentWhenSucceedOnValids2 f g-    = equivalentWhenSucceedOnGens2 f g genValid--equivalentWhenSucceed2-    :: (Show a, Eq a, GenValidity a,-        Show b, Eq b, GenValidity b,-        Show c, Eq c,-        CanFail f)-    => (a -> b -> f c)-    -> (a -> b -> f c)-    -> Property-equivalentWhenSucceed2 f g-    = equivalentWhenSucceedOnGens2 f g genUnchecked

− src/Test/Validity/Functions/Idempotence.hs

@@ -1,50 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Functions.Idempotence-    ( -- ** Standard tests involving validity-      idempotentOnGen-    , idempotentOnValid-    , idempotent-    , idempotentOnArbitrary-    ) where--import           Data.GenValidity--import           Test.Hspec-import           Test.QuickCheck--idempotentOnGen-    :: (Show a, Eq a)-    => (a -> a)-    -> Gen a-    -> Property-idempotentOnGen f gen-    = forAll gen $ \a ->-        f (f a) `shouldBe` f a--idempotentOnValid-    :: (Show a, Eq a, GenValidity a)-    => (a -> a)-    -> Property-idempotentOnValid func = idempotentOnGen func genValid--idempotent-    :: (Show a, Eq a, GenValidity a)-    => (a -> a)-    -> Property-idempotent func = idempotentOnGen func genUnchecked---- |------ 'id' is idempotent for any type:------ prop> idempotentOnArbitrary (id :: Int -> Int)------ 'const', given any input, is idempotent for any type as well:------ prop> \int -> idempotentOnArbitrary (const int :: Int -> Int)-idempotentOnArbitrary-    :: (Show a, Eq a, Arbitrary a)-    => (a -> a)-    -> Property-idempotentOnArbitrary func = idempotentOnGen func arbitrary

− src/Test/Validity/Functions/Inverse.hs

@@ -1,185 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Functions.Inverse-    ( -- ** Standard tests involving inverse functions-      inverseFunctionsOnGen-    , inverseFunctionsOnValid-    , inverseFunctions-    , inverseFunctionsOnArbitrary-    , inverseFunctionsIfFirstSucceedsOnGen-    , inverseFunctionsIfFirstSucceedsOnValid-    , inverseFunctionsIfFirstSucceeds-    , inverseFunctionsIfFirstSucceedsOnArbitrary-    , inverseFunctionsIfSecondSucceedsOnGen-    , inverseFunctionsIfSecondSucceedsOnValid-    , inverseFunctionsIfSecondSucceeds-    , inverseFunctionsIfSecondSucceedsOnArbitrary-    , inverseFunctionsIfSucceedOnGen-    , inverseFunctionsIfSucceedOnValid-    , inverseFunctionsIfSucceed-    , inverseFunctionsIfSucceedOnArbitrary-    ) where--import           Data.GenValidity--import           Test.Hspec-import           Test.QuickCheck--import           Test.Validity.Types--inverseFunctionsOnGen-    :: (Show a, Eq a)-    => (a -> b)-    -> (b -> a)-    -> Gen a-    -> Property-inverseFunctionsOnGen f g gen =-    forAll gen $ \a ->-      g (f a) `shouldBe` a---inverseFunctionsOnValid-    :: (Show a, Eq a, GenValidity a)-    => (a -> b)-    -> (b -> a)-    -> Property-inverseFunctionsOnValid f g-    = inverseFunctionsOnGen f g genValid---inverseFunctions-    :: (Show a, Eq a, GenValidity a)-    => (a -> b)-    -> (b -> a)-    -> Property-inverseFunctions f g-    = inverseFunctionsOnGen f g genUnchecked---- |--- 'id' is its own inverse function for every type:--- prop> inverseFunctionsOnArbitrary id (id :: Int -> Int)-inverseFunctionsOnArbitrary-    :: (Show a, Eq a, Arbitrary a)-    => (a -> b)-    -> (b -> a)-    -> Property-inverseFunctionsOnArbitrary f g-    = inverseFunctionsOnGen f g arbitrary---inverseFunctionsIfFirstSucceedsOnGen-    :: (Show a, Eq a, CanFail f)-    => (a -> f b)-    -> (b -> a)-    -> Gen a-    -> Property-inverseFunctionsIfFirstSucceedsOnGen f g gen =-    forAll gen $ \a ->-      case resultIfSucceeded (f a) of-          Nothing -> return () -- fine-          Just b  -> g b `shouldBe` a---inverseFunctionsIfFirstSucceedsOnValid-    :: (Show a, Eq a, GenValidity a, CanFail f)-    => (a -> f b)-    -> (b -> a)-    -> Property-inverseFunctionsIfFirstSucceedsOnValid f g-    = inverseFunctionsIfFirstSucceedsOnGen f g genValid---inverseFunctionsIfFirstSucceeds-    :: (Show a, Eq a, GenValidity a, CanFail f)-    => (a -> f b)-    -> (b -> a)-    -> Property-inverseFunctionsIfFirstSucceeds f g-    = inverseFunctionsIfFirstSucceedsOnGen f g genUnchecked--inverseFunctionsIfFirstSucceedsOnArbitrary-    :: (Show a, Eq a, Arbitrary a, CanFail f)-    => (a -> f b)-    -> (b -> a)-    -> Property-inverseFunctionsIfFirstSucceedsOnArbitrary f g-    = inverseFunctionsIfFirstSucceedsOnGen f g arbitrary---inverseFunctionsIfSecondSucceedsOnGen-    :: (Show a, Eq a, CanFail f)-    => (a -> b)-    -> (b -> f a)-    -> Gen a-    -> Property-inverseFunctionsIfSecondSucceedsOnGen f g gen =-    forAll gen $ \a ->-      case resultIfSucceeded (g (f a)) of-          Nothing -> return () -- fine-          Just r  -> r `shouldBe` a---inverseFunctionsIfSecondSucceedsOnValid-    :: (Show a, Eq a, GenValidity a, CanFail f)-    => (a -> b)-    -> (b -> f a)-    -> Property-inverseFunctionsIfSecondSucceedsOnValid f g-    = inverseFunctionsIfSecondSucceedsOnGen f g genValid---inverseFunctionsIfSecondSucceeds-    :: (Show a, Eq a, GenValidity a, CanFail f)-    => (a -> b)-    -> (b -> f a)-    -> Property-inverseFunctionsIfSecondSucceeds f g-    = inverseFunctionsIfSecondSucceedsOnGen f g genUnchecked--inverseFunctionsIfSecondSucceedsOnArbitrary-    :: (Show a, Eq a, Arbitrary a, CanFail f)-    => (a -> b)-    -> (b -> f a)-    -> Property-inverseFunctionsIfSecondSucceedsOnArbitrary f g-    = inverseFunctionsIfSecondSucceedsOnGen f g arbitrary---inverseFunctionsIfSucceedOnGen-    :: (Show a, Eq a, CanFail f, CanFail g)-    => (a -> f b)-    -> (b -> g a)-    -> Gen a-    -> Property-inverseFunctionsIfSucceedOnGen f g gen =-    forAll gen $ \a ->-      case do fa <- resultIfSucceeded $ f a-              resultIfSucceeded $ g fa-          of-          Nothing -> return () -- fine-          Just r  -> r `shouldBe` a---inverseFunctionsIfSucceedOnValid-    :: (Show a, Eq a, GenValidity a, CanFail f, CanFail g)-    => (a -> f b)-    -> (b -> g a)-    -> Property-inverseFunctionsIfSucceedOnValid f g-    = inverseFunctionsIfSucceedOnGen f g genValid--inverseFunctionsIfSucceed-    :: (Show a, Eq a, GenValidity a, CanFail f, CanFail g)-    => (a -> f b)-    -> (b -> g a)-    -> Property-inverseFunctionsIfSucceed f g-    = inverseFunctionsIfSucceedOnGen f g genUnchecked--inverseFunctionsIfSucceedOnArbitrary-    :: (Show a, Eq a, Arbitrary a, CanFail f, CanFail g)-    => (a -> f b)-    -> (b -> g a)-    -> Property-inverseFunctionsIfSucceedOnArbitrary f g-    = inverseFunctionsIfSucceedOnGen f g arbitrary

− src/Test/Validity/Functions/Validity.hs

@@ -1,122 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Functions.Validity-    ( -- ** Standard tests involving validity-      producesValidsOnGen-    , producesValidsOnValids-    , producesValid-    , producesValidsOnArbitrary-    , producesValidsOnGens2-    , producesValidsOnValids2-    , producesValid2-    , producesValidsOnArbitrary2-    , producesValidsOnGens3-    , producesValidsOnValids3-    , producesValid3-    , producesValidsOnArbitrary3-    ) where--import           Data.GenValidity--import           Test.Hspec-import           Test.QuickCheck---- | The function produces valid output when the input is generated as--- specified by the given generator.-producesValidsOnGen-    :: (Show a, Show b, Validity b)-    => (a -> b)-    -> Gen a-    -> Property-producesValidsOnGen func gen-    = forAll gen $ \a -> func a `shouldSatisfy` isValid---- | The function produces valid output when the input is generated by--- @arbitrary@-producesValidsOnArbitrary-    :: (Show a, Show b, Arbitrary a, Validity b)-    => (a -> b)-    -> Property-producesValidsOnArbitrary = (`producesValidsOnGen` arbitrary)---- | The function produces valid output when the input is generated by--- @genUnchecked@-producesValid-    :: (Show a, Show b, GenValidity a, Validity b)-    => (a -> b)-    -> Property-producesValid = (`producesValidsOnGen` genUnchecked)---- | The function produces valid output when the input is generated by--- @genValid@-producesValidsOnValids-    :: (Show a, Show b, GenValidity a, Validity b)-    => (a -> b)-    -> Property-producesValidsOnValids = (`producesValidsOnGen` genValid)--producesValidsOnGens2-    :: (Show a, Show b, Show c, Validity c)-    => (a -> b -> c)-    -> Gen (a, b)-    -> Property-producesValidsOnGens2 func gen-    = forAll gen $ \(a, b) ->-        func a b `shouldSatisfy` isValid--producesValidsOnValids2-    :: (Show a, Show b, Show c, GenValidity a, GenValidity b, Validity c)-    => (a -> b -> c)-    -> Property-producesValidsOnValids2 func-    = producesValidsOnGens2 func genValid--producesValidsOnArbitrary2-    :: (Show a, Show b, Show c, Arbitrary a, Arbitrary b, Validity c)-    => (a -> b -> c)-    -> Property-producesValidsOnArbitrary2 func-    = producesValidsOnGens2 func arbitrary--producesValid2-    :: (Show a, Show b, Show c, GenValidity a, GenValidity b, Validity c)-    => (a -> b -> c)-    -> Property-producesValid2 func-    = producesValidsOnGens2 func genUnchecked--producesValidsOnGens3-    :: (Show a, Show b, Show c, Show d, Validity d)-    => (a -> b -> c -> d)-    -> Gen (a, b, c)-    -> Property-producesValidsOnGens3 func gen-    = forAll gen $ \(a, b, c) ->-        func a b c `shouldSatisfy` isValid--producesValid3-    :: (Show a, Show b, Show c, Show d,-        GenValidity a, GenValidity b, GenValidity c,-        Validity d)-    => (a -> b -> c -> d)-    -> Property-producesValid3 func-    = producesValidsOnGens3 func genUnchecked--producesValidsOnValids3-    :: (Show a, Show b, Show c, Show d,-        GenValidity a, GenValidity b, GenValidity c,-        Validity d)-    => (a -> b -> c -> d)-    -> Property-producesValidsOnValids3 func-    = producesValidsOnGens3 func genValid--producesValidsOnArbitrary3-    :: (Show a, Show b, Show c, Show d,-        Arbitrary a, Arbitrary b, Arbitrary c,-        Validity d)-    => (a -> b -> c -> d)-    -> Property-producesValidsOnArbitrary3 func-    = producesValidsOnGens3 func arbitrary

+ src/Test/Validity/Functor.hs view

@@ -0,0 +1,167 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Functor properties+--+-- You will need @TypeApplications@ to use these.+module Test.Validity.Functor+  ( functorSpec,+    functorSpecOnArbitrary,+    functorSpecOnGens,+  )+where++import Data.Data+import Data.GenValidity+import Data.Kind+import Test.Hspec+import Test.QuickCheck+import Test.Validity.Functions+import Test.Validity.Utils++{-# ANN module "HLint: ignore Functor law" #-}++fmapTypeStr ::+  forall (f :: Type -> Type).+  (Typeable f) =>+  String+fmapTypeStr =+  unwords+    [ "fmap",+      "::",+      "(a",+      "->",+      "b)",+      "->",+      nameOf @f,+      "a",+      "->",+      nameOf @f,+      "b"+    ]++flTypeStr ::+  forall (f :: Type -> Type).+  (Typeable f) =>+  String+flTypeStr =+  unwords ["(<$)", "::", "a", "->", nameOf @f, "b", "->", nameOf @f, "a"]++-- | Standard test spec for properties of Functor instances for values generated with GenValid instances+--+-- Example usage:+--+-- > functorSpecOnArbitrary @[]+functorSpec ::+  forall (f :: Type -> Type).+  (Eq (f Int), Show (f Int), Functor f, Typeable f, GenValid (f Int)) =>+  Spec+functorSpec = functorSpecWithInts @f genValid++-- | Standard test spec for properties of Functor instances for values generated with Arbitrary instances+--+-- Example usage:+--+-- > functorSpecOnArbitrary @[]+functorSpecOnArbitrary ::+  forall (f :: Type -> Type).+  (Eq (f Int), Show (f Int), Functor f, Typeable f, Arbitrary (f Int)) =>+  Spec+functorSpecOnArbitrary = functorSpecWithInts @f arbitrary++functorSpecWithInts ::+  forall (f :: Type -> Type).+  (Eq (f Int), Show (f Int), Functor f, Typeable f) =>+  Gen (f Int) ->+  Spec+functorSpecWithInts gen =+  functorSpecOnGens+    @f+    @Int+    genValid+    "int"+    gen+    (unwords [nameOf @f, "of ints"])+    ((+) <$> genValid)+    "increments"+    ((*) <$> genValid)+    "scalings"++-- | Standard test spec for properties of Functor instances for values generated by given generators (and names for those generator).+--+-- Example usage:+--+-- > functorSpecOnGens+-- >     @[]+-- >     @Int+-- >     (pure 4) "four"+-- >     (genListOf $ pure 5) "list of fives"+-- >     ((+) <$> genValid) "additions"+-- >     ((*) <$> genValid) "multiplications"+functorSpecOnGens ::+  forall (f :: Type -> Type) (a :: Type) (b :: Type) (c :: Type).+  ( Show a,+    Show (f a),+    Show (f c),+    Eq (f a),+    Eq (f c),+    Functor f,+    Typeable f,+    Typeable a,+    Typeable b,+    Typeable c+  ) =>+  Gen a ->+  String ->+  Gen (f a) ->+  String ->+  Gen (b -> c) ->+  String ->+  Gen (a -> b) ->+  String ->+  Spec+functorSpecOnGens gena genaname gen genname genf genfname geng gengname =+  parallel $+    describe ("Functor " ++ nameOf @f) $ do+      describe (fmapTypeStr @f) $ do+        it+          ( unwords+              [ "satisfies the first Fuctor law: 'fmap id == id' for",+                genDescr @(f a) genname+              ]+          )+          $ equivalentOnGen (fmap @f id) (id @(f a)) gen shrinkNothing+        it+          ( unwords+              [ "satisfieds the second Functor law: 'fmap (f . g) == fmap f . fmap g' for",+                genDescr @(f a) genname,+                "'s",+                "given to",+                genDescr @(b -> c) genfname,+                "and",+                genDescr @(a -> b) gengname+              ]+          )+          $ forAll (Anon <$> genf)+          $ \(Anon f) ->+            forAll (Anon <$> geng) $ \(Anon g) ->+              equivalentOnGen+                (fmap (f . g))+                (fmap f . fmap g)+                gen+                shrinkNothing+      describe (flTypeStr @f)+        $ it+          ( unwords+              [ "is equivalent to its default implementation for",+                genDescr @a genaname,+                "and",+                genDescr @(f a) genname+              ]+          )+        $ forAll gena+        $ \a ->+          equivalentOnGen (a <$) (fmap $ const a) gen shrinkNothing

− src/Test/Validity/GenRelativeValidity.hs

@@ -1,85 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.GenRelativeValidity-    ( -- * Tests for GenRelativeValidity instances-      genRelativeValiditySpec-    , genRelativeValidityValidGeneratesValid-    , genRelativeValidityInvalidGeneratesInvalid-    ) where--import           Data.Data-import           Data.Proxy--import           Data.GenRelativeValidity-import           Data.GenValidity--import           Test.Hspec-import           Test.QuickCheck--import           Test.Validity.Utils---- | A @Spec@ that specifies that @genValidFor@ and @genInvalidFor@ work as--- intended.------ In general it is a good idea to add this spec to your test suite if you--- write a custom implementation of @genValidFor@ or @genInvalidFor@.------ Example usage:------ > relativeGenValiditySpec (proxy :: MyDataFor) (proxy :: MyOtherData)-genRelativeValiditySpec-    :: (Typeable a, Typeable b,-        Show a, Show b,-        GenValidity a, GenValidity b,-        RelativeValidity a b,-        GenRelativeValidity a b)-    => Proxy a-    -> Proxy b-    -> Spec-genRelativeValiditySpec one two = do-    let nameOne = nameOf one-    let nameTwo = nameOf two-    describe ("GenRelativeValidity " ++ nameOne ++ " " ++ nameTwo) $ do-        describe ("genValidFor   :: " ++ nameTwo ++ " -> Gen " ++ nameOne) $-            it ("only generates valid \'"-                ++ nameOne-                ++ "\'s for the "-                ++ nameTwo) $-                genRelativeValidityValidGeneratesValid one two--        describe ("genInvalidFor :: " ++ nameTwo ++ " -> Gen " ++ nameOne) $-            it ("only generates invalid \'"-                ++ nameOne-                ++ "\'s for the "-                ++ nameTwo) $-                genRelativeValidityInvalidGeneratesInvalid one two---- | @genValidFor b@ only generates values that satisfy @isValidFor b@-genRelativeValidityValidGeneratesValid-    :: (Show a, Show b,-        GenValidity a, GenValidity b,-        RelativeValidity a b,-        GenRelativeValidity a b)-    => Proxy a-    -> Proxy b-    -> Property-genRelativeValidityValidGeneratesValid one two =-    forAll genValid $ \b ->-        forAll (genValidFor b) $ \a ->-            (a `asProxyTypeOf` one)-                `shouldSatisfy` (`isValidFor` (b `asProxyTypeOf` two))---- | @genInvalidFor b@ only generates values that do not satisfy @isValidFor b@-genRelativeValidityInvalidGeneratesInvalid-    :: (Show a, Show b,-        GenValidity a, GenValidity b,-        RelativeValidity a b,-        GenRelativeValidity a b)-    => Proxy a-    -> Proxy b-    -> Property-genRelativeValidityInvalidGeneratesInvalid one two =-    forAll genUnchecked $ \b ->-        forAll (genInvalidFor b) $ \a ->-            (a `asProxyTypeOf` one)-                `shouldNotSatisfy` (`isValidFor` (b `asProxyTypeOf` two))

src/Test/Validity/GenValidity.hs view

@@ -1,77 +1,60 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.GenValidity-    ( -- * Tests for GenValidity instances-      genValiditySpec-    , genValidityValidGeneratesValid-    , genGeneratesValid-    , genValidityInvalidGeneratesInvalid-    , genGeneratesInvalid-    ) where--import           Data.Data--import           Data.GenValidity+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} -import           Test.Hspec-import           Test.QuickCheck+-- | Tests for GenValidity instances+--+-- You will need @TypeApplications@ to use these.+module Test.Validity.GenValidity+  ( genValidSpec,+    genValidGeneratesValid,+    genGeneratesValid,+    genGeneratesInvalid,+  )+where -import           Test.Validity.Utils+import Data.Data+import Data.GenValidity+import Test.Hspec+import Test.QuickCheck+import Test.Validity.GenValidity.Property+import Test.Validity.Utils --- | A @Spec@ that specifies that @genValid@ only generates valid data and that--- @genInvalid@ only generates invalid data.+-- | A @Spec@ that specifies that @genValid@ only generates valid data. -- -- In general it is a good idea to add this spec to your test suite if you--- write a custom implementation of @genValid@ or @genInvalid@.+-- write a custom implementation of @genValid@. -- -- Example usage: ----- > genValiditySpec (Proxy :: Proxy MyData)-genValiditySpec-    :: (Typeable a, Show a, GenValidity a)-    => Proxy a-    -> Spec-genValiditySpec proxy = do-    let name = nameOf proxy-    describe ("GenValidity " ++ name) $ do-        describe ("genValid   :: Gen " ++ name) $-            it ("only generates valid \'" ++ name ++ "\'s") $-                genValidityValidGeneratesValid proxy--        describe ("genInvalid :: Gen " ++ name) $-            it ("only generates invalid \'" ++ name ++ "\'s") $-                genValidityInvalidGeneratesInvalid proxy+-- > genValidSpec @Int+genValidSpec ::+  forall a.+  (Typeable a, Show a, GenValid a) =>+  Spec+genValidSpec =+  parallel $ do+    let name = nameOf @a+    describe ("GenValid " ++ name) $+      describe ("genValid   :: Gen " ++ name) $+        it ("only generates valid \'" ++ name ++ "\'s") $+          genValidGeneratesValid @a  -- | @genValid@ only generates valid data-genValidityValidGeneratesValid-    :: forall a. (Show a, GenValidity a)-    => Proxy a-    -> Property-genValidityValidGeneratesValid _ =-    genGeneratesValid (genValid :: Gen a)---- | The given generator generates only valid data points-genGeneratesValid-    :: (Show a, Validity a)-    => Gen a-    -> Property-genGeneratesValid gen =-    forAll gen (`shouldSatisfy` isValid)----- | @genValid@ only generates invalid data-genValidityInvalidGeneratesInvalid-    :: forall a. (Show a, GenValidity a)-    => Proxy a-    -> Property-genValidityInvalidGeneratesInvalid _ =-    genGeneratesInvalid (genInvalid :: Gen a)---- | The given generator generates only invalid data points-genGeneratesInvalid-    :: (Show a, Validity a)-    => Gen a-    -> Property-genGeneratesInvalid gen =-    forAll gen (`shouldNotSatisfy` isValid)-+--+-- prop> genValidGeneratesValid @()+-- prop> genValidGeneratesValid @Bool+-- prop> genValidGeneratesValid @Ordering+-- prop> genValidGeneratesValid @Char+-- prop> genValidGeneratesValid @Int+-- prop> genValidGeneratesValid @Float+-- prop> genValidGeneratesValid @Double+-- prop> genValidGeneratesValid @Integer+-- prop> genValidGeneratesValid @(Maybe Int)+-- prop> genValidGeneratesValid @[Int]+genValidGeneratesValid ::+  forall a.+  (Show a, GenValid a) =>+  Property+genValidGeneratesValid = genGeneratesValid @a genValid

+ src/Test/Validity/Monad.hs view

@@ -0,0 +1,253 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Monad properties+--+-- You will need @TypeApplications@ to use these.+module Test.Validity.Monad+  ( monadSpec,+    monadSpecOnArbitrary,+    monadSpecOnGens,+  )+where++import Control.Monad (ap)+import Data.Data+import Data.GenValidity+import Data.Kind (Type)+import Test.Hspec+import Test.QuickCheck+import Test.QuickCheck.Gen (unGen)+import Test.QuickCheck.Random (mkQCGen)+import Test.Validity.Functions+import Test.Validity.Utils++{-# ANN module "HLint: ignore Use fmap" #-}++{-# ANN module "HLint: ignore Use <$>" #-}++{-# ANN module "HLint: ignore Use >=>" #-}++{-# ANN module "HLint: ignore Use id" #-}++{-# ANN module "HLint: ignore Monad law, left identity" #-}++{-# ANN module "HLint: ignore Monad law, right identity" #-}++{-# ANN module "HLint: ignore Avoid lambda" #-}++{-# ANN module "HLint: ignore Reduce duplication" #-}++returnTypeStr ::+  forall (m :: Type -> Type).+  (Typeable m) =>+  String+returnTypeStr = unwords ["return", "::", "a", "->", nameOf @m, "a"]++bindTypeStr ::+  forall (m :: Type -> Type).+  (Typeable m) =>+  String+bindTypeStr =+  unwords+    [ "(>>=)",+      "::",+      nameOf @m,+      "a",+      "->",+      "(b",+      "->",+      nameOf @m,+      "a)",+      "->",+      nameOf @m,+      "b"+    ]++-- | Standard test spec for properties of Monad instances for values generated with GenValid instances+--+-- Example usage:+--+-- > monadSpec @[]+monadSpec ::+  forall (f :: Type -> Type).+  (Eq (f Int), Show (f Int), Monad f, Typeable f, GenValid (f Int)) =>+  Spec+monadSpec = monadSpecWithInts @f genValid++-- | Standard test spec for properties of Monad instances for values generated with Arbitrary instances+--+-- Example usage:+--+-- > monadSpecOnArbitrary @[]+monadSpecOnArbitrary ::+  forall (f :: Type -> Type).+  (Eq (f Int), Show (f Int), Monad f, Typeable f, Arbitrary (f Int)) =>+  Spec+monadSpecOnArbitrary = monadSpecWithInts @f arbitrary++monadSpecWithInts ::+  forall (f :: Type -> Type).+  (Eq (f Int), Show (f Int), Monad f, Typeable f) =>+  Gen (f Int) ->+  Spec+monadSpecWithInts gen =+  monadSpecOnGens+    @f+    @Int+    genValid+    "int"+    gen+    (unwords [nameOf @f, "of ints"])+    gen+    (unwords [nameOf @f, "of ints"])+    ((+) <$> genValid)+    "increments"+    ( do+        s <- genListLength+        pure $ \b -> unGen gen (mkQCGen b) s+    )+    "perturbations using the int"+    ( do+        s <- genListLength+        pure $ \b -> unGen gen (mkQCGen $ 2 * b) s+    )+    "perturbations using the double the int"+    (pure <$> ((+) <$> genValid))+    (unwords [nameOf @f, "of additions"])++-- | Standard test spec for properties of Monad instances for values generated by given generators (and names for those generator).+--+-- Example usage:+--+-- > monadSpecOnGens+-- >     @[]+-- >     @Int+-- >     (pure 4)+-- >     "four"+-- >     (genListOf $ pure 5)+-- >     "list of fives"+-- >     (genListOf $ pure 6)+-- >     "list of sixes"+-- >     ((*) <$> genValid)+-- >     "factorisations"+-- >     (pure $ \a -> [a])+-- >     "singletonisation"+-- >     (pure $ \a -> [a])+-- >     "singletonisation"+-- >     (pure $ pure (+ 1))+-- >     "increment in list"+monadSpecOnGens ::+  forall (f :: Type -> Type) (a :: Type) (b :: Type) (c :: Type).+  ( Show a,+    Show (f a),+    Show (f b),+    Show (f c),+    Eq (f a),+    Eq (f b),+    Eq (f c),+    Monad f,+    Typeable f,+    Typeable a,+    Typeable b,+    Typeable c+  ) =>+  Gen a ->+  String ->+  Gen (f a) ->+  String ->+  Gen (f b) ->+  String ->+  Gen (a -> b) ->+  String ->+  Gen (a -> f b) ->+  String ->+  Gen (b -> f c) ->+  String ->+  Gen (f (a -> b)) ->+  String ->+  Spec+monadSpecOnGens gena genaname gen genname genb genbname geng gengname genbf genbfname gencf gencfname genfab genfabname =+  parallel $+    describe ("Monad " ++ nameOf @f) $ do+      describe (unwords [returnTypeStr @f, "and", bindTypeStr @f]) $ do+        it+          ( unwords+              [ "satisfy the first Monad law: 'return a >>= k = k a' for",+                genDescr @a genaname,+                "and",+                genDescr @(a -> f b) genbfname+              ]+          )+          $ equivalentOnGens2+            (\a (Anon k) -> return a >>= k)+            (\a (Anon k) -> k a)+            ((,) <$> gena <*> (Anon <$> genbf))+            shrinkNothing+        it+          ( unwords+              [ "satisfy the second Monad law: 'm >>= return = m' for",+                genDescr @(f a) genname+              ]+          )+          $ equivalentOnGen (\m -> m >>= return) (\m -> m) gen shrinkNothing+      describe (bindTypeStr @f)+        $ it+          ( unwords+              [ "satisfies the third Monad law: 'm >>= (x -> k x >>= h) = (m >>= k) >>= h' for",+                genDescr @(f a) genname,+                genDescr @(a -> f b) genbfname,+                "and",+                genDescr @(b -> f c) gencfname+              ]+          )+        $ equivalentOnGens3+          (\m (Anon k) (Anon h) -> m >>= (\x -> k x >>= h))+          (\m (Anon k) (Anon h) -> (m >>= k) >>= h)+          ((,,) <$> gen <*> (Anon <$> genbf) <*> (Anon <$> gencf))+          shrinkNothing+      describe (unwords ["relation with Applicative", nameOf @f]) $ do+        it+          ( unwords+              ["satisfies 'pure = return' for", genDescr @(f a) genname]+          )+          $ equivalentOnGen (pure @f) (return @f) gena shrinkNothing+        it+          ( unwords+              [ "satisfies '(<*>) = ap' for",+                genDescr @(f (a -> b)) genfabname,+                "and",+                genDescr @(f a) genname+              ]+          )+          $ equivalentOnGens2+            (\(Anon a) b -> a <*> b)+            (\(Anon a) b -> ap a b)+            ((,) <$> (Anon <$> genfab) <*> gen)+            shrinkNothing+        it+          ( unwords+              [ "satisfies '(>>) = (*>)' for",+                genDescr @(f a) genname,+                "and",+                genDescr @(f b) genbname+              ]+          )+          $ equivalentOnGens2 (>>) (*>) ((,) <$> gen <*> genb) shrinkNothing+      describe (unwords ["relation with Functor", nameOf @f])+        $ it+          ( unwords+              [ "satisfies 'fmap f xs = xs >>= return . f' for",+                genDescr @(a -> b) gengname,+                "and",+                genDescr @(f a) genname+              ]+          )+        $ equivalentOnGens2+          (\(Anon f) xs -> fmap f xs)+          (\(Anon f) xs -> xs >>= (return . f))+          ((,) <$> (Anon <$> geng) <*> gen)+          shrinkNothing

+ src/Test/Validity/Monoid.hs view

@@ -0,0 +1,131 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Monoid properties+--+-- You will need @TypeApplications@ to use these.+module Test.Validity.Monoid+  ( monoidSpecOnValid,+    monoidSpec,+    monoidSpecOnArbitrary,+    monoidSpecOnGen,+  )+where++import Data.Data+import Data.GenValidity+import Test.Hspec+import Test.QuickCheck+import Test.Validity.Functions+import Test.Validity.Operations+import Test.Validity.Utils++memptyTypeStr ::+  forall a.+  (Typeable a) =>+  String+memptyTypeStr = unwords ["mempty", "::", nameOf @a]++mappendTypeStr ::+  forall a.+  (Typeable a) =>+  String+mappendTypeStr = unwords ["mappend", "::", an, "->", an, "->", an]+  where+    an = nameOf @a++mconcatTypeStr ::+  forall a.+  (Typeable a) =>+  String+mconcatTypeStr = unwords ["mconcat", "::", "[" ++ an ++ "]", "->", an]+  where+    an = nameOf @a++-- | Standard test spec for properties of 'Monoid' instances for valid values+--+-- Example usage:+--+-- > monoidSpecOnValid @[Double]+monoidSpecOnValid ::+  forall a.+  (Show a, Eq a, Monoid a, Typeable a, GenValid a) =>+  Spec+monoidSpecOnValid = monoidSpecOnGen @a genValid "valid" shrinkValid++-- | Standard test spec for properties of 'Monoid' instances for valid values+--+-- Example usage:+--+-- > monoidSpec @[Int]+monoidSpec ::+  forall a.+  (Show a, Eq a, Monoid a, Typeable a, GenValid a) =>+  Spec+monoidSpec = monoidSpecOnGen @a genValid "valid" shrinkValid++-- | Standard test spec for properties of 'Monoid' instances for arbitrary values+--+-- Example usage:+--+-- > monoidSpecOnArbitrary @[Int]+monoidSpecOnArbitrary ::+  forall a.+  (Show a, Eq a, Monoid a, Typeable a, Arbitrary a) =>+  Spec+monoidSpecOnArbitrary = monoidSpecOnGen @a arbitrary "arbitrary" shrink++-- | Standard test spec for properties of Monoid instances for values generated by a given generator (and name for that generator).+--+-- Example usage:+--+-- > monoidSpecOnGen (pure "a") "singleton list of 'a'"+monoidSpecOnGen ::+  forall a.+  (Show a, Eq a, Monoid a, Typeable a) =>+  Gen a ->+  String ->+  (a -> [a]) ->+  Spec+monoidSpecOnGen gen genname s =+  parallel $ do+    let name = nameOf @a+        memptystr = memptyTypeStr @a+        mappendstr = mappendTypeStr @a+        mconcatstr = mconcatTypeStr @a+        gen3 = (,,) <$> gen <*> gen <*> gen+        s3 (a, b, c) = (,,) <$> s a <*> s b <*> s c+        genl = genListOf gen+        sl = shrinkList s+    describe ("Monoid " ++ name) $ do+      let mem = mempty @a+          mapp = mappend @a+          mcon = mconcat @a+      describe memptystr+        $ it+          ( unwords+              [ "is the identity for",+                mappendstr,+                "for",+                genDescr @a genname+              ]+          )+        $ identityOnGen mapp mem gen s+      describe mappendstr+        $ it+          ( unwords+              [ "is an associative operation for",+                genDescr @(a, a, a) genname+              ]+          )+        $ associativeOnGens mapp gen3 s3+      describe mconcatstr+        $ it+          ( unwords+              [ "is equivalent to its default implementation for",+                genDescr @[a] genname+              ]+          )+        $ equivalentOnGen mcon (foldr mapp mem) genl sl

− src/Test/Validity/Operations.hs

@@ -1,42 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Operations-    ( -- * Properties of operations--    -- ** Identity element--    -- *** Left identity-      leftIdentityOnElemWithEquality-    , leftIdentityOnGenWithEquality-    , leftIdentityOnGen-    , leftIdentityOnValid-    , leftIdentity--    -- *** Right identity-    , rightIdentityOnElemWithEquality-    , rightIdentityOnGenWithEquality-    , rightIdentityOnGen-    , rightIdentityOnValid-    , rightIdentity--    -- *** Identity-    , identityOnGen-    , identityOnValid-    , identity--    -- ** Associativity-    , associativeOnGens-    , associativeOnValids-    , associative-    , associativeOnArbitrary--    -- ** Commutativity-    , commutativeOnGens-    , commutativeOnValids-    , commutative-    , commutativeOnArbitrary-    ) where--import           Test.Validity.Operations.Identity-import           Test.Validity.Operations.Associativity-import           Test.Validity.Operations.Commutativity

− src/Test/Validity/Operations/Associativity.hs

@@ -1,44 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Operations.Associativity-    ( -- ** Associativity-      associativeOnGens-    , associativeOnValids-    , associative-    , associativeOnArbitrary-    ) where--import           Data.GenValidity--import           Test.Hspec-import           Test.QuickCheck--associativeOnGens-    :: (Show a, Eq a)-    => (a -> a -> a)-    -> Gen (a, a, a)-    -> Property-associativeOnGens op gen =-    forAll gen $ \(a, b, c) ->-        ((a `op` b) `op` c) `shouldBe` (a `op` (b `op` c))--associativeOnValids-    :: (Show a, Eq a, GenValidity a)-    => (a -> a -> a)-    -> Property-associativeOnValids op-    = associativeOnGens op genValid--associative-    :: (Show a, Eq a, GenValidity a)-    => (a -> a -> a)-    -> Property-associative op-    = associativeOnGens op genUnchecked--associativeOnArbitrary-    :: (Show a, Eq a, Arbitrary a)-    => (a -> a -> a)-    -> Property-associativeOnArbitrary op-    = associativeOnGens op arbitrary

− src/Test/Validity/Operations/Commutativity.hs

@@ -1,44 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Operations.Commutativity-    ( -- ** Commutativity-      commutativeOnGens-    , commutativeOnValids-    , commutative-    , commutativeOnArbitrary-    ) where--import           Data.GenValidity--import           Test.Hspec-import           Test.QuickCheck--commutativeOnGens-    :: (Show a, Eq a)-    => (a -> a -> a)-    -> Gen (a, a)-    -> Property-commutativeOnGens op gen =-    forAll gen $ \(a, b) ->-        (a `op` b) `shouldBe` (b `op` a)--commutativeOnValids-    :: (Show a, Eq a, GenValidity a)-    => (a -> a -> a)-    -> Property-commutativeOnValids op-    = commutativeOnGens op genValid--commutative-    :: (Show a, Eq a, GenValidity a)-    => (a -> a -> a)-    -> Property-commutative op-    = commutativeOnGens op genUnchecked--commutativeOnArbitrary-    :: (Show a, Eq a, Arbitrary a)-    => (a -> a -> a)-    -> Property-commutativeOnArbitrary op-    = commutativeOnGens op arbitrary

− src/Test/Validity/Operations/Identity.hs

@@ -1,148 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Operations.Identity-    ( -- *** Left identity-      leftIdentityOnElemWithEquality-    , leftIdentityOnGenWithEquality-    , leftIdentityOnGen-    , leftIdentityOnValid-    , leftIdentity--      -- *** Right identity-    , rightIdentityOnElemWithEquality-    , rightIdentityOnGenWithEquality-    , rightIdentityOnGen-    , rightIdentityOnValid-    , rightIdentity--    , identityOnGen-    , identityOnValid-    , identity-    ) where--import           Data.GenValidity--import           Test.QuickCheck---- |------ \[---   LeftIdentity(\star, \doteq, b)---   \quad\equiv\quad---   \forall a: (b \star a) \doteq a--- \]-leftIdentityOnElemWithEquality-    :: (b -> a -> a)    -- ^ A binary operation-    -> (a -> a -> Bool) -- ^ An equality-    -> b                -- ^ A candidate left-identity-    -> a                -- ^ An element-    -> Bool-leftIdentityOnElemWithEquality op eq b a = (b `op` a) `eq` a--leftIdentityOnGenWithEquality-    :: Show a-    => (b -> a -> a)    -- ^ A binary operation-    -> (a -> a -> Bool) -- ^ An equality-    -> b                -- ^ A candidate left-identity-    -> Gen a-    -> Property-leftIdentityOnGenWithEquality op eq b gen =-    forAll gen $ leftIdentityOnElemWithEquality op eq b--leftIdentityOnGen-    :: (Show a, Eq a)-    => (b -> a -> a) -- ^ A binary operation-    -> b             -- ^ A candidate left-identity-    -> Gen a-    -> Property-leftIdentityOnGen op = leftIdentityOnGenWithEquality op (==)--leftIdentityOnValid-    :: (Show a, Eq a, GenValidity a)-    => (b -> a -> a)-    -> b-    -> Property-leftIdentityOnValid op b-    = leftIdentityOnGen op b genValid--leftIdentity-    :: (Show a, Eq a, GenValidity a)-    => (b -> a -> a)-    -> b-    -> Property-leftIdentity op b-    = leftIdentityOnGen op b genUnchecked---- |------ \[---   RightIdentity(\star, \doteq, b)---   \quad\equiv\quad---   \forall a: (a \star b) \doteq a--- \]-rightIdentityOnElemWithEquality-    :: (a -> b -> a)    -- ^ A binary operation-    -> (a -> a -> Bool) -- ^ An equality-    -> b                -- ^ A candidate right-identity-    -> a                -- ^ An element-    -> Bool-rightIdentityOnElemWithEquality op eq b a = (a `op` b) `eq` a--rightIdentityOnGenWithEquality-    :: Show a-    => (a -> b -> a)    -- ^ A binary operation-    -> (a -> a -> Bool) -- ^ An equality-    -> b                -- ^ A candidate right-identity-    -> Gen a-    -> Property-rightIdentityOnGenWithEquality op eq b gen =-    forAll gen $ rightIdentityOnElemWithEquality op eq b--rightIdentityOnGen-    :: (Show a, Eq a)-    => (a -> b -> a)    -- ^ A binary operation-    -> b                -- ^ A candidate right-identity-    -> Gen a-    -> Property-rightIdentityOnGen op = rightIdentityOnGenWithEquality op (==)--rightIdentityOnValid-    :: (Show a, Eq a, GenValidity a)-    => (a -> b -> a)-    -> b-    -> Property-rightIdentityOnValid op b-    = rightIdentityOnGen op b genValid--rightIdentity-    :: (Show a, Eq a, GenValidity a)-    => (a -> b -> a)-    -> b-    -> Property-rightIdentity op b-    = rightIdentityOnGen op b genUnchecked--identityOnGen-    :: (Show a, Eq a)-    => (a -> a -> a)-    -> a-    -> Gen a-    -> Property-identityOnGen op e gen =-    leftIdentityOnGen op e gen .&&. rightIdentityOnGen op e gen--identityOnValid-    :: (Show a, Eq a, GenValidity a)-    => (a -> a -> a)-    -> a-    -> Property-identityOnValid op a-    = identityOnGen op a genValid--identity-    :: (Show a, Eq a, GenValidity a)-    => (a -> a -> a)-    -> a-    -> Property-identity op e-    = identityOnGen op e genUnchecked

src/Test/Validity/Ord.hs view

@@ -1,46 +1,150 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Ord properties+--+-- You will need @TypeApplications@ to use these. module Test.Validity.Ord-    ( -- * Ord properties-      ordSpec-    ) where+  ( ordSpec,+    ordSpecOnGen,+    ordSpecOnArbitrary,+  )+where -import           Data.Data-import           Data.Proxy+import Data.Data+import Data.GenValidity+import Test.Hspec+import Test.QuickCheck+import Test.Validity.Functions+import Test.Validity.Relations+import Test.Validity.Utils -import           Data.GenValidity+{-# ANN module "HLint: ignore Use <=" #-} -import           Test.Hspec+{-# ANN module "HLint: ignore Use >=" #-} -import           Test.Validity.Relations-import           Test.Validity.Utils+{-# ANN module "HLint: ignore Use <" #-} -ordSpec-    :: (Show a, Eq a, Ord a, Typeable a, GenValidity a)-    => Proxy a-    -> Spec-ordSpec proxy = do-    let name = nameOf proxy-        funlestr = unwords-          [ "(<=) ::"-          , name-          , "->"-          , name-          , "-> Ordering"-          ]-        cmp a b = a `asProxyTypeOf` proxy <= b-    describe ("Ord " ++ name) $ do-        it ("is instantated such that "-            ++ funlestr-            ++ " is reflexive") $-            reflexivity cmp+{-# ANN module "HLint: ignore Use >" #-} -        it ("is instantated such that "-            ++ funlestr-            ++ " is antisymmetric") $-            antisymmetry cmp+leTypeStr ::+  forall a.+  (Typeable a) =>+  String+leTypeStr = binRelStr @a "<=" -        it ("is instantated such that "-            ++ funlestr-            ++ " is transitive") $-            transitivity cmp+geTypeStr ::+  forall a.+  (Typeable a) =>+  String+geTypeStr = binRelStr @a ">="++ltTypeStr ::+  forall a.+  (Typeable a) =>+  String+ltTypeStr = binRelStr @a "<"++gtTypeStr ::+  forall a.+  (Typeable a) =>+  String+gtTypeStr = binRelStr @a ">"++-- | Standard test spec for properties of Ord instances for valid values+--+-- Example usage:+--+-- > ordSpec @Int+ordSpec ::+  forall a.+  (Show a, Ord a, Typeable a, GenValid a) =>+  Spec+ordSpec = ordSpecOnGen @a genValid "valid" shrinkValid++-- | Standard test spec for properties of Ord instances for arbitrary values+--+-- Example usage:+--+-- > ordSpecOnArbitrary @Int+ordSpecOnArbitrary ::+  forall a.+  (Show a, Ord a, Typeable a, Arbitrary a) =>+  Spec+ordSpecOnArbitrary = ordSpecOnGen @a arbitrary "arbitrary" shrink++-- | Standard test spec for properties of Ord instances for values generated by a given generator (and name for that generator).+--+-- Example usage:+--+-- > ordSpecOnGen ((* 2) <$> genValid @Int) "even"+ordSpecOnGen ::+  forall a.+  (Show a, Ord a, Typeable a) =>+  Gen a ->+  String ->+  (a -> [a]) ->+  Spec+ordSpecOnGen gen genname s =+  parallel $ do+    let name = nameOf @a+        funlestr = leTypeStr @a+        fungestr = geTypeStr @a+        funltstr = ltTypeStr @a+        fungtstr = gtTypeStr @a+        minmaxtstr = genDescr @(a -> a -> a)+        itProp s_ =+          it $+            unwords+              [ s_,+                "\"" ++ genname,+                name ++ "\"" ++ "'s"+              ]+        cmple = (<=) @a+        cmpge = (>=) @a+        cmplt = (<) @a+        cmpgt = (>) @a+        gen2 = (,) <$> gen <*> gen+        gen3 = (,,) <$> gen <*> gen <*> gen+        s2 = shrinkT2 s+    describe ("Ord " ++ name) $ do+      describe funlestr $ do+        itProp "is reflexive for" $+          reflexivityOnGen cmple gen s+        itProp "is antisymmetric for" $+          antisymmetryOnGens cmple gen2 s+        itProp "is transitive for" $+          transitivityOnGens cmple gen3 s+        itProp "is equivalent to (\\a b -> compare a b /= GT) for" $+          equivalentOnGens2 cmple (\a b -> compare a b /= GT) gen2 s2+      describe fungestr $ do+        itProp "is reflexive for" $+          reflexivityOnGen cmpge gen s+        itProp "is antisymmetric for" $+          antisymmetryOnGens cmpge gen2 s+        itProp "is transitive for" $+          transitivityOnGens cmpge gen3 s+        itProp "is equivalent to (\\a b -> compare a b /= LT) for" $+          equivalentOnGens2 cmpge (\a b -> compare a b /= LT) gen2 s2+      describe funltstr $ do+        itProp "is antireflexive for" $+          antireflexivityOnGen cmplt gen s+        itProp "is transitive for" $+          transitivityOnGens cmplt gen3 s+        itProp "is equivalent to (\\a b -> compare a b == LT) for" $+          equivalentOnGens2 cmplt (\a b -> compare a b == LT) gen2 s2+      describe fungtstr $ do+        itProp "is antireflexive for" $+          antireflexivityOnGen cmpgt gen s+        itProp "is transitive for" $+          transitivityOnGens cmpgt gen3 s+        itProp "is equivalent to (\\a b -> compare a b == GT) for" $+          equivalentOnGens2 cmpgt (\a b -> compare a b == GT) gen2 s2+      describe (minmaxtstr "min") $ do+        itProp "is equivalent to (\\a b -> if a <= b then a else b) for" $+          equivalentOnGens2 min (\a b -> if a <= b then a else b) gen2 s2+      describe (minmaxtstr "max") $ do+        itProp "is equivalent to (\\a b -> if a >= b then a else b) for" $+          equivalentOnGens2 max (\a b -> if a >= b then a else b) gen2 s2

− src/Test/Validity/Relations.hs

@@ -1,41 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Relations-    (-    -- * Properties of relations--    -- ** Reflexivity-      reflexiveOnElem-    , reflexivityOnGen-    , reflexivityOnValid-    , reflexivity-    , reflexivityOnArbitrary--    -- ** Transitivity-    , transitiveOnElems-    , transitivityOnGens-    , transitivityOnValid-    , transitivity-    , transitivityOnArbitrary--    -- ** Antisymmetry-    , antisymmetricOnElemsWithEquality-    , antisymmetryOnGensWithEquality-    , antisymmetryOnGensEq-    , antisymmetryOnValid-    , antisymmetry-    , antisymmetryOnArbitrary--    -- ** Symmetry-    , symmetricOnElems-    , symmetryOnGens-    , symmetryOnValid-    , symmetry-    , symmetryOnArbitrary-    ) where--import           Test.Validity.Relations.Reflexivity-import           Test.Validity.Relations.Antisymmetry-import           Test.Validity.Relations.Symmetry-import           Test.Validity.Relations.Transitivity-

− src/Test/Validity/Relations/Antisymmetry.hs

@@ -1,72 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Relations.Antisymmetry-    ( antisymmetricOnElemsWithEquality-    , antisymmetryOnGensWithEquality-    , antisymmetryOnGensEq-    , antisymmetryOnValid-    , antisymmetry-    , antisymmetryOnArbitrary-    ) where--import           Data.GenValidity--import           Test.QuickCheck--import           Test.Validity.Utils---- |------ \[---   Antisymmetric(\prec, \doteq)---   \quad\equiv\quad---   \forall a, b: ((a \prec b) \wedge (b \prec a)) \Rightarrow (a \doteq b)--- \]-antisymmetricOnElemsWithEquality-    :: (a -> a -> Bool) -- ^ A relation-    -> (a -> a -> Bool) -- ^ An equivalence relation-    -> a -> a           -- ^ Two elements-    -> Bool-antisymmetricOnElemsWithEquality func eq a b =-    (func a b && func b a) ===> (a `eq` b)--antisymmetryOnGensWithEquality-    :: Show a-    => (a -> a -> Bool)-    -> Gen (a, a)-    -> (a -> a -> Bool)-    -> Property-antisymmetryOnGensWithEquality func gen eq =-    forAll gen $ uncurry $ antisymmetricOnElemsWithEquality func eq--antisymmetryOnGensEq-    :: (Show a, Eq a)-    => (a -> a -> Bool)-    -> Gen (a, a)-    -> Property-antisymmetryOnGensEq func gen-    = antisymmetryOnGensWithEquality func gen (==)--antisymmetryOnValid-    :: (Show a, Eq a, GenValidity a)-    => (a -> a -> Bool)-    -> Property-antisymmetryOnValid func =-    antisymmetryOnGensEq func genValid--antisymmetry-    :: (Show a, Eq a, GenValidity a)-    => (a -> a -> Bool)-    -> Property-antisymmetry func =-    antisymmetryOnGensEq func genUnchecked---- |------ prop> antisymmetryOnArbitrary ((<=) :: Int -> Int -> Bool)-antisymmetryOnArbitrary-    :: (Show a, Eq a, Arbitrary a)-    => (a -> a -> Bool)-    -> Property-antisymmetryOnArbitrary func =-    antisymmetryOnGensEq func arbitrary

− src/Test/Validity/Relations/Reflexivity.hs

@@ -1,58 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Relations.Reflexivity-    ( reflexiveOnElem-    , reflexivityOnGen-    , reflexivityOnValid-    , reflexivity-    , reflexivityOnArbitrary-    ) where--import           Data.GenValidity--import           Test.QuickCheck---- |------ \[---   Reflexive(prec)---   \quad\equiv\quad---   \forall a: (a \prec a)--- \]-reflexiveOnElem-    :: (a -> a -> Bool) -- ^ A relation-    -> a                -- ^ An element-    -> Bool-reflexiveOnElem func a = func a a--reflexivityOnGen-    :: Show a-    => (a -> a -> Bool)-    -> Gen a-    -> Property-reflexivityOnGen func gen =-    forAll gen $ reflexiveOnElem func--reflexivityOnValid-    :: (Show a, GenValidity a)-    => (a -> a -> Bool)-    -> Property-reflexivityOnValid func-    = reflexivityOnGen func genValid--reflexivity-    :: (Show a, GenValidity a)-    => (a -> a -> Bool)-    -> Property-reflexivity func-    = reflexivityOnGen func genUnchecked---- |------ prop> reflexivityOnArbitrary ((==) :: Int -> Int -> Bool)-reflexivityOnArbitrary-    :: (Show a, Arbitrary a)-    => (a -> a -> Bool)-    -> Property-reflexivityOnArbitrary func-    = reflexivityOnGen func arbitrary

− src/Test/Validity/Relations/Symmetry.hs

@@ -1,61 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Relations.Symmetry-    ( symmetricOnElems-    , symmetryOnGens-    , symmetryOnValid-    , symmetry-    , symmetryOnArbitrary-    ) where--import           Data.GenValidity--import           Test.QuickCheck--import           Test.Validity.Utils---- |------ \[---   Symmetric(\prec)---   \quad\equiv\quad---   \forall a, b: (a \prec b) \Leftrightarrow (b \prec a)--- \]-symmetricOnElems-    :: (a -> a -> Bool) -- ^ A relation-    -> a -> a           -- ^ Two elements-    -> Bool-symmetricOnElems func a b = func a b <==> func b a--symmetryOnGens-    :: Show a-    => (a -> a -> Bool)-    -> Gen (a, a)-    -> Property-symmetryOnGens func gen =-    forAll gen $ uncurry $ symmetricOnElems func--symmetryOnValid-    :: (Show a, GenValidity a)-    => (a -> a -> Bool)-    -> Property-symmetryOnValid func =-    symmetryOnGens func genValid--symmetry-    :: (Show a, GenValidity a)-    => (a -> a -> Bool)-    -> Property-symmetry func =-    symmetryOnGens func genUnchecked----- |------ prop> symmetryOnArbitrary ((==) :: Int -> Int -> Bool)-symmetryOnArbitrary-    :: (Show a, Arbitrary a)-    => (a -> a -> Bool)-    -> Property-symmetryOnArbitrary func =-    symmetryOnGens func arbitrary

− src/Test/Validity/Relations/Transitivity.hs

@@ -1,62 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Relations.Transitivity-    ( transitiveOnElems-    , transitivityOnGens-    , transitivityOnValid-    , transitivity-    , transitivityOnArbitrary-    ) where--import           Data.GenValidity--import           Test.QuickCheck--import           Test.Validity.Utils---- |------ \[---   Transitive(\prec)---   \quad\equiv\quad---   \forall a, b, c: ((a \prec b) \wedge (b \prec c)) \Rightarrow (a \prec c)--- \]-transitiveOnElems-    :: (a -> a -> Bool) -- ^ A relation-    -> a -> a -> a      -- ^ Three elements-    -> Bool-transitiveOnElems func a b c = (func a b && func b c) ===> func a c--transitivityOnGens-    :: Show a-    => (a -> a -> Bool)-    -> Gen (a, a, a)-    -> Property-transitivityOnGens func gen =-    forAll gen $ \(a, b, c) -> transitiveOnElems func a b c--transitivityOnValid-    :: (Show a, GenValidity a)-    => (a -> a -> Bool)-    -> Property-transitivityOnValid func-    = transitivityOnGens func genValid---transitivity-    :: (Show a, GenValidity a)-    => (a -> a -> Bool)-    -> Property-transitivity func-    = transitivityOnGens func genUnchecked---- |------ prop> transitivityOnArbitrary ((==) :: Int -> Int -> Bool)-transitivityOnArbitrary-    :: (Show a, Arbitrary a)-    => (a -> a -> Bool)-    -> Property-transitivityOnArbitrary func-    = transitivityOnGens func arbitrary-

− src/Test/Validity/RelativeValidity.hs

@@ -1,77 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.RelativeValidity-    ( -- * Tests for RelativeValidity instances-      relativeValiditySpec-    , relativeValidityImpliesValidA-    , relativeValidityImpliesValidB-    ) where--import           Data.Data-import           Data.Proxy--import           Data.GenRelativeValidity-import           Data.GenValidity--import           Test.Hspec-import           Test.QuickCheck--import           Test.Validity.Utils---- | A @Spec@ that specifies that @isValidFor@ implies @isValid@------ In general it is a good idea to add this spec to your test suite if--- the @a@ and @b@ in @RelativeValidity a b@ also have a @Validity@ instance.------ Example usage:------ > relativeValiditySpec--- >     (Proxy :: Proxy MyDataFor)--- >     (Proxy :: Proxy MyOtherData)-relativeValiditySpec-    :: (Typeable a, Typeable b,-        Show a, Show b,-        GenValidity a, GenValidity b, GenRelativeValidity a b)-    => Proxy a-    -> Proxy b-    -> Spec-relativeValiditySpec one two = do-    let nameOne = nameOf one-        nameTwo = nameOf two-    describe ("RelativeValidity " ++ nameOne ++ " " ++ nameTwo) $-        describe ("isValidFor :: "-                  ++ nameOne-                  ++ " -> "-                  ++ nameTwo-                  ++ " -> Bool") $ do-            it ("implies isValid " ++ nameOne ++ " for any " ++ nameTwo) $-                relativeValidityImpliesValidA one two-            it ("implies isValid " ++ nameTwo ++ " for any " ++ nameOne) $-                relativeValidityImpliesValidB one two---- | @isValidFor a b@ implies @isValid a@ for all @b@-relativeValidityImpliesValidA-    :: (Show a, Show b,-        GenValidity a, GenValidity b, RelativeValidity a b)-    => Proxy a-    -> Proxy b-    -> Property-relativeValidityImpliesValidA one two =-    forAll genUnchecked $ \a ->-        forAll genUnchecked $ \b ->-            not ((a `asProxyTypeOf` one) `isValidFor` (b `asProxyTypeOf` two))-            || isValid a---- | @isValidFor a b@ implies @isValid b@ for all @a@-relativeValidityImpliesValidB-    :: (Show a, Show b,-        GenValidity a, GenValidity b, RelativeValidity a b)-    => Proxy a-    -> Proxy b-    -> Property-relativeValidityImpliesValidB one two =-    forAll genUnchecked $ \a ->-        forAll genUnchecked $ \b ->-            not ((a `asProxyTypeOf` one) `isValidFor` (b `asProxyTypeOf` two))-              || isValid b-

+ src/Test/Validity/Show.hs view

@@ -0,0 +1,89 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | 'Show' and 'Read' properties+module Test.Validity.Show+  ( showReadSpec,+    showReadSpecOnArbitrary,+    showReadSpecOnGen,+    showReadRoundTrip,+    showReadRoundTripOnArbitrary,+    showReadRoundTripOnGen,+  )+where++import Data.Data+import Data.GenValidity+import Test.Hspec+import Test.QuickCheck+import Test.Validity.Utils+import Text.Read++-- | Standard test spec for properties of Show and Read instances for valid values+--+-- Example usage:+--+-- > showReadSpec @Int+showReadSpec ::+  forall a.+  (Show a, Eq a, Read a, Typeable a, GenValid a) =>+  Spec+showReadSpec = showReadSpecOnGen @a genValid "valid" shrinkValid++-- | Standard test spec for properties of Show and Read instances for arbitrary values+--+-- Example usage:+--+-- > showReadSpecOnArbitrary @Double+showReadSpecOnArbitrary ::+  forall a.+  (Show a, Eq a, Read a, Typeable a, Arbitrary a) =>+  Spec+showReadSpecOnArbitrary = showReadSpecOnGen @a arbitrary "arbitrary" shrink++-- | Standard test spec for properties of Show and Read instances for values generated by a custom generator+--+-- Example usage:+--+-- > showReadSpecOnGen ((* 2) <$> genValid @Int) "even" (const [])+showReadSpecOnGen ::+  forall a.+  (Show a, Eq a, Read a, Typeable a) =>+  Gen a ->+  String ->+  (a -> [a]) ->+  Spec+showReadSpecOnGen gen n s =+  describe (unwords ["Show", nameOf @a, "and Read", nameOf @a]) $+    it (unwords ["are implemented such that read . show == id for", n, "values"]) $+      showReadRoundTripOnGen gen s++-- |+--+-- prop> showReadRoundTrip @Int+showReadRoundTrip ::+  forall a.+  (Show a, Eq a, Read a, GenValid a) =>+  Property+showReadRoundTrip =+  showReadRoundTripOnGen (genValid :: Gen a) shrinkValid++-- |+--+-- prop> showReadRoundTripOnArbitrary @Double+showReadRoundTripOnArbitrary ::+  forall a.+  (Show a, Eq a, Read a, Arbitrary a) =>+  Property+showReadRoundTripOnArbitrary =+  showReadRoundTripOnGen (arbitrary :: Gen a) shrink++-- |+--+-- prop> showReadRoundTripOnGen (abs <$> genValid :: Gen Int) (const [])+showReadRoundTripOnGen ::+  (Show a, Eq a, Read a) => Gen a -> (a -> [a]) -> Property+showReadRoundTripOnGen gen s =+  forAllShrink gen s $ \v -> readMaybe (show v) `shouldBe` Just v

+ src/Test/Validity/Shrinking.hs view

@@ -0,0 +1,90 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | Tests for Shrinking functions+--+-- You will need @TypeApplications@ to use these.+module Test.Validity.Shrinking+  ( shrinkValidSpec,+    shrinkValidSpecWithLimit,+    shrinkValidPreservesValidOnGenValid,+    shrinkValidPreservesValidOnGenValidWithLimit,+    shrinkPreservesValidOnGenValid,+    shrinkValidPreservesValid,+    shrinkingStaysValid,+    shrinkingPreserves,+    shrinkValidDoesNotShrinkToItself,+    shrinkValidDoesNotShrinkToItselfWithLimit,+  )+where++import Control.Monad+import Data.Data+import Data.GenValidity+import Test.Hspec+import Test.QuickCheck+import Test.Validity.Shrinking.Property+import Test.Validity.Utils++shrinkValidSpec ::+  forall a.+  (Show a, Eq a, Typeable a, GenValid a) =>+  Spec+shrinkValidSpec =+  describe ("shrinkValid :: " ++ nameOf @(a -> [a])) $ do+    it "preserves validity" $+      forAll (genValid @a) $+        \a -> forM_ (shrinkValid a) shouldBeValid+    it "never shrinks to itself for valid values" $+      shrinkValidDoesNotShrinkToItself @a++shrinkValidSpecWithLimit ::+  forall a.+  (Show a, Eq a, Typeable a, GenValid a) =>+  Int ->+  Spec+shrinkValidSpecWithLimit l =+  describe ("shrinkValid :: " ++ nameOf @(a -> [a])) $ do+    it (unwords ["preserves validity for the first", show l, "elements"]) $+      forAll (genValid @a) $ \a ->+        forM_ (take l $ shrinkValid a) shouldBeValid+    it+      ( unwords+          [ "never shrinks to itself for valid values for the first",+            show l,+            "elements"+          ]+      )+      $ shrinkValidDoesNotShrinkToItselfWithLimit @a l++shrinkValidPreservesValidOnGenValid ::+  forall a.+  (Show a, GenValid a) =>+  Property+shrinkValidPreservesValidOnGenValid =+  shrinkingStaysValid @a genValid shrinkValid++shrinkValidPreservesValidOnGenValidWithLimit ::+  forall a.+  (Show a, GenValid a) =>+  Int ->+  Property+shrinkValidPreservesValidOnGenValidWithLimit =+  shrinkingStaysValidWithLimit @a genValid shrinkValid++shrinkValidDoesNotShrinkToItself ::+  forall a.+  (Show a, Eq a, GenValid a) =>+  Property+shrinkValidDoesNotShrinkToItself =+  shrinkDoesNotShrinkToItself @a shrinkValid++shrinkValidDoesNotShrinkToItselfWithLimit ::+  forall a.+  (Show a, Eq a, GenValid a) =>+  Int ->+  Property+shrinkValidDoesNotShrinkToItselfWithLimit =+  shrinkDoesNotShrinkToItselfOnValidWithLimit @a shrinkValid

− src/Test/Validity/Types.hs

@@ -1,25 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}-module Test.Validity.Types-    ( CanFail(..)-    ) where---- | A class of types that are the result of functions that can fail-class CanFail f where-    hasFailed :: f a -> Bool-    resultIfSucceeded :: f a -> Maybe a--instance CanFail Maybe where-    hasFailed Nothing = True-    hasFailed _ = False--    resultIfSucceeded Nothing = Nothing-    resultIfSucceeded (Just r) = Just r--instance CanFail (Either e) where-    hasFailed (Left _) = True-    hasFailed _ = False--    resultIfSucceeded (Left _) = Nothing-    resultIfSucceeded (Right r) = Just r-

src/Test/Validity/Utils.hs view

@@ -1,20 +1,125 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-deprecations #-}++-- | Utilities for defining your own validity 'Spec's+--+-- You will need @TypeApplications@ to use these. module Test.Validity.Utils-    ( (<==>)-    , (===>)-    , nameOf-    ) where+  ( nameOf,+    genDescr,+    binRelStr,+    shouldFail,+    failsBecause,+    Anon (..),+    shouldBeValid,+    shouldBeInvalid,+  )+where -import           Data.Data+import Control.Arrow (second)+import Control.Monad.Trans.Writer (mapWriterT)+import Data.Data+import Test.Hspec+import Test.Hspec.Core.Formatters+import Test.Hspec.Core.Runner+import Test.Hspec.Core.Spec+import Test.QuickCheck.Property+import Test.Validity.Property.Utils -(===>) :: Bool -> Bool -> Bool-(===>) a b = not a || b+nameOf ::+  forall a.+  (Typeable a) =>+  String+nameOf =+  let s = show $ typeRep (Proxy @a)+   in if ' ' `elem` s+        then "(" ++ s ++ ")"+        else s -(<==>) :: Bool -> Bool -> Bool-(<==>) a b = a ===> b && b ===> a+genDescr ::+  forall a.+  (Typeable a) =>+  String ->+  String+genDescr genname = unwords ["\"" ++ genname, "::", nameOf @a ++ "\""] -nameOf :: Typeable a => Proxy a -> String-nameOf proxy =-    let (_, [ty]) = splitTyConApp $ typeOf proxy-    in show ty+binRelStr ::+  forall a.+  (Typeable a) =>+  String ->+  String+binRelStr op = unwords ["(" ++ op ++ ")", "::", name, "->", name, "->", "Bool"]+  where+    name = nameOf @a++newtype Anon a+  = Anon a++instance Show (Anon a) where+  show _ = "Anonymous"++instance Functor Anon where+  fmap f (Anon a) = Anon (f a)++-- I'm not sure why mapSpecTree was removed from hspec-core,+-- but it has been copied here for convenience.+-- https://github.com/hspec/hspec/commit/020c7ecc4a73c24af38e9fab049f60bb9aec6981#diff-29cb22f0ef6e98086a71fc045847bd21L22+mapSpecTree' :: (SpecTree a -> SpecTree b) -> SpecM a r -> SpecM b r++#if MIN_VERSION_hspec(2,10,0)+mapSpecTree' f (SpecM specs) = SpecM (mapWriterT (fmap (second (fmap (map f)))) specs)+#else+mapSpecTree' f (SpecM specs) = SpecM (mapWriterT (fmap (second (map f))) specs)+#endif+{- ORMOLU_DISABLE -}+-- | Asserts that a given 'Spec' tree fails _somewhere_.+--+-- It also shows the given string when reporting that the tree unexpectedly+-- succeeded.+failsBecause :: String -> SpecWith () -> SpecWith ()+failsBecause s = mapSpecTree' go+  where+    go :: SpecTree () -> SpecTree ()+    go sp =+      Leaf+        Item+          { itemRequirement = s,+            itemLocation = Nothing,+            itemIsFocused = False,+            itemIsParallelizable = Nothing,+#if MIN_VERSION_hspec(2,11,10)+            itemAnnotations = mempty,+#endif+            itemExample =+              \_ _ _ -> do+                let conf =+                      defaultConfig {configFormatter = Just silent}+                r <- hspecWithResult conf $ fromSpecList [sp]+                let succesful =+                      summaryExamples r > 0 && summaryFailures r > 0+                pure $ produceResult succesful+          }+{- ORMOLU_ENABLE -}++produceResult :: Bool -> Test.Hspec.Core.Spec.Result+produceResult succesful =+  Result+    { resultInfo = "",+      resultStatus =+        if succesful+          then Success+          else Failure Nothing $ Test.Hspec.Core.Spec.Reason "Should have failed but didn't."+    }++shouldFail :: Property -> Property+shouldFail =+  mapResult $ \res ->+    res+      { reason = unwords ["Should have failed:", reason res],+        expect = not $ expect res+      }

− test/DocTest.hs

@@ -1,4 +0,0 @@-import Test.DocTest--main :: IO ()-main = doctest ["-isrc", "src"]

+ test/Spec.hs view

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

+ test/Test/Validity/ApplicativeSpec.hs view

@@ -0,0 +1,45 @@+{-# LANGUAGE TypeApplications #-}++module Test.Validity.ApplicativeSpec where++import Data.GenValidity+import Test.Hspec+import Test.Validity.Applicative++spec :: Spec+spec = do+  applicativeSpec @(Either Int)+  applicativeSpec @[]+  applicativeSpec @Maybe+  applicativeSpecOnArbitrary @[]+  applicativeSpecOnArbitrary @Maybe+  applicativeSpecOnGens+    @[]+    @Int+    (pure 4)+    "four"+    (genListOf $ pure 5)+    "list of fives"+    (pure [])+    "purely empty list"+    ((+) <$> genValid)+    "increments"+    (pure <$> ((+) <$> genValid))+    "increments in a list"+    (pure <$> ((*) <$> genValid))+    "scalings in a list"+  applicativeSpecOnGens+    @Maybe+    @String+    (pure "ABC")+    "ABC"+    (Just <$> pure "ABC")+    "Just an ABC"+    (pure Nothing)+    "purely Nothing"+    ((++) <$> genValid)+    "prepends"+    (pure <$> ((++) <$> genValid))+    "prepends in a Just"+    (pure <$> (flip (++) <$> genValid))+    "appends in a Just"

+ test/Test/Validity/ArbitrarySpec.hs view

@@ -0,0 +1,9 @@+{-# LANGUAGE TypeApplications #-}++module Test.Validity.ArbitrarySpec where++import Test.Hspec+import Test.Validity.Arbitrary++spec :: Spec+spec = arbitrarySpec @Int

+ test/Test/Validity/EqSpec.hs view

@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-}++module Test.Validity.EqSpec where++import Data.GenValidity+import GHC.Generics (Generic)+import Test.Hspec+import Test.Validity.Eq+import Test.Validity.Utils++spec :: Spec+spec = do+  eqSpec @Rational+  eqSpec @Int+  -- eqSpec @Double DOES NOT HOLD because of NaN+  eqSpecOnArbitrary @Int+  eqSpecOnGen ((* 2) <$> genValid @Int) "even" (const [])+  failsBecause "(/=) and (==) don't have opposite semantics" $+    eqSpec @EqFuncMismatch++newtype EqFuncMismatch+  = EqFuncMismatch ()+  deriving (Show, Generic)++instance Validity EqFuncMismatch++instance Eq EqFuncMismatch where+  (==) _ _ = True+  (/=) _ _ = True++instance GenValid EqFuncMismatch where+  genValid = EqFuncMismatch <$> genValid+  shrinkValid _ = []

+ test/Test/Validity/FunctorSpec.hs view

@@ -0,0 +1,55 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-}++module Test.Validity.FunctorSpec where++import Data.GenValidity+import GHC.Generics (Generic)+import Test.Hspec+import Test.Validity.Functor+import Test.Validity.Utils++spec :: Spec+spec = do+  functorSpec @[]+  functorSpec @Maybe+  failsBecause "Fcks does not satisfy any Functor laws" $ functorSpec @Fcks+  functorSpec @(Either Int)+  functorSpec @((,) Int)+  functorSpecOnArbitrary @[]+  functorSpecOnArbitrary @Maybe+  functorSpecOnGens+    @[]+    @Int+    (pure 4)+    "four"+    (genListOf $ pure 5)+    "list of fives"+    ((+) <$> genValid)+    "increments"+    ((*) <$> genValid)+    "scalings"+  functorSpecOnGens+    @Maybe+    @String+    (pure "ABC")+    "ABC"+    (Just <$> pure "ABC")+    "Just an ABC"+    ((++) <$> genValid)+    "prepends"+    (flip (++) <$> genValid)+    "appends"++newtype Fcks a+  = Fcks Int+  deriving (Show, Eq, Generic)++instance Validity (Fcks a)++instance GenValid (Fcks a) where+  genValid = Fcks <$> genValid+  shrinkValid (Fcks i) = Fcks <$> shrinkValid i++instance Functor Fcks where+  fmap _ (Fcks i) = Fcks $ i * 2

+ test/Test/Validity/GenRelativeValiditySpec.hs view

@@ -0,0 +1,7 @@+module Test.Validity.GenRelativeValiditySpec where++import Test.Hspec++-- import Test.Validity.GenRelativeValidity+spec :: Spec+spec = pure () -- TODO add examples once we have some instances

+ test/Test/Validity/GenValiditySpec.hs view

@@ -0,0 +1,11 @@+{-# LANGUAGE TypeApplications #-}++module Test.Validity.GenValiditySpec where++import Test.Hspec+import Test.Validity.GenValidity++spec :: Spec+spec = do+  genValidSpec @Rational+  genValidSpec @Rational

+ test/Test/Validity/MonadSpec.hs view

@@ -0,0 +1,51 @@+{-# LANGUAGE TypeApplications #-}++module Test.Validity.MonadSpec where++import Data.GenValidity+import Test.Hspec+import Test.Validity.Monad++{-# ANN module "HLint: ignore Use :" #-}++spec :: Spec+spec = do+  monadSpec @[]+  monadSpec @Maybe+  monadSpec @(Either Int)+  monadSpecOnArbitrary @[]+  monadSpecOnArbitrary @Maybe+  monadSpecOnGens+    @[]+    @Int+    (pure 4)+    "four"+    (genListOf $ pure 5)+    "list of fives"+    (genListOf $ pure 6)+    "list of sixes"+    ((*) <$> genValid)+    "factorisations"+    (pure $ \a -> [a])+    "singletonisation"+    (pure $ \a -> [a])+    "singletonisation"+    (pure $ pure (+ 1))+    "increment in list"+  monadSpecOnGens+    @Maybe+    @String+    (pure "ABC")+    "ABC"+    (Just <$> pure "ABC")+    "Just an ABC"+    (Just <$> pure "CDE")+    "Just an ABC"+    (flip (++) <$> genValid)+    "appends"+    (pure $ \a -> Just a)+    "justisation"+    (pure $ \a -> Just a)+    "justisation"+    (pure $ pure (++ "a"))+    "append 'a' in Just"

+ test/Test/Validity/MonoidSpec.hs view

@@ -0,0 +1,13 @@+{-# LANGUAGE TypeApplications #-}++module Test.Validity.MonoidSpec where++import Test.Hspec+import Test.Validity.Monoid++spec :: Spec+spec = do+  monoidSpecOnValid @[Rational]+  monoidSpec @[Int]+  monoidSpecOnArbitrary @[Int]+  monoidSpecOnGen (pure "a") "singleton list of 'a'" (const [])

+ test/Test/Validity/OrdSpec.hs view

@@ -0,0 +1,16 @@+{-# LANGUAGE TypeApplications #-}++module Test.Validity.OrdSpec where++import Data.GenValidity+import Test.Hspec+import Test.Validity.Ord+import Test.Validity.Utils++spec :: Spec+spec = do+  ordSpec @Rational+  failsBecause "NaN >= NaN is False" $ ordSpec @Double+  ordSpec @Int+  ordSpecOnArbitrary @Int+  ordSpecOnGen ((* 2) <$> genValid @Int) "even" (const [])

+ test/Test/Validity/RelativeValiditySpec.hs view

@@ -0,0 +1,7 @@+module Test.Validity.RelativeValiditySpec where++import Test.Hspec++-- import Test.Validity.RelativeValidity+spec :: Spec+spec = pure ()

+ test/Test/Validity/ShowSpec.hs view

@@ -0,0 +1,32 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-}++module Test.Validity.ShowSpec where++import Data.GenValidity+import GHC.Generics (Generic)+import Test.Hspec+import Test.Validity.Show+import Test.Validity.Utils++spec :: Spec+spec = do+  showReadSpec @Rational+  showReadSpec @Int+  showReadSpecOnArbitrary @Rational+  showReadSpecOnGen ((* 2) <$> genValid @Int) "even" (const [])+  failsBecause "show and read don't have the correct semantics" $+    showReadSpec @ShowFuncMismatch++data ShowFuncMismatch+  = ShowFuncMismatch+  deriving (Eq, Read, Generic)++instance Validity ShowFuncMismatch++instance Show ShowFuncMismatch where+  show ShowFuncMismatch = "wrong"++instance GenValid ShowFuncMismatch where+  genValid = pure ShowFuncMismatch+  shrinkValid _ = []

+ test/Test/Validity/ShrinkingSpec.hs view

@@ -0,0 +1,25 @@+{-# LANGUAGE TypeApplications #-}++module Test.Validity.ShrinkingSpec where++import Data.Int+import Data.Ratio+import Test.Hspec+import Test.Validity.Shrinking++spec :: Spec+spec = do+  shrinkValidSpec @(Ratio Int8)+  shrinkValidSpec @Int+  describe "shrinkValidPreservesValidOnGenValid" $ do+    it "Ordering" $ shrinkValidPreservesValidOnGenValid @Ordering+    it "[Ordering]" $ shrinkValidPreservesValidOnGenValid @[Ordering]+  describe "shrinkValidPreservesValidOnGenValid" $ do+    it "Ordering" $ shrinkValidPreservesValidOnGenValid @Ordering+    it "[Ordering]" $ shrinkValidPreservesValidOnGenValid @[Ordering]+  describe "shrinkValidDoesNotShrinkToItself" $ do+    it "Int" $ shrinkValidDoesNotShrinkToItself @Int+    it "[Int]" $ shrinkValidDoesNotShrinkToItself @[Int]+  describe "shrinkValidDoesNotShrinkToItself" $ do+    it "Ordering" $ shrinkValidDoesNotShrinkToItself @Ordering+    it "[Ordering]" $ shrinkValidDoesNotShrinkToItself @[Ordering]