diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2016 Tom Sydney Kerckhove + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/genvalidity-property.cabal b/genvalidity-property.cabal new file mode 100644 --- /dev/null +++ b/genvalidity-property.cabal @@ -0,0 +1,61 @@ +name: genvalidity-property +version: 0.0.0.0 +cabal-version: >=1.10 +build-type: Simple +license: MIT +license-file: LICENSE +copyright: Copyright: (c) 2016 Tom Sydney Kerckhove +maintainer: syd.kerckhove@gmail.com +homepage: https://github.com/NorfairKing/validity#readme +synopsis: Standard properties for functions on `Validity` types +description: Standard properties for functions on `Validity` types +category: Testing +author: Tom Sydney Kerckhove + +source-repository head + type: git + location: https://github.com/NorfairKing/validity + +library + exposed-modules: + Test.Validity.Property + 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.Property + Test.Validity.Operations + Test.Validity.Operations.Associativity + Test.Validity.Operations.Commutativity + Test.Validity.Operations.Identity + Test.Validity.Relations + Test.Validity.Relations.Antireflexivity + Test.Validity.Relations.Antisymmetry + Test.Validity.Relations.Reflexivity + Test.Validity.Relations.Symmetry + Test.Validity.Relations.Transitivity + Test.Validity.Types + Test.Validity.Property.Utils + build-depends: + base >=4.7 && <5, + validity >=0.3 && <0.4, + genvalidity >=0.3 && <0.4, + QuickCheck -any, + hspec >=2.1 && <2.5 + default-language: Haskell2010 + hs-source-dirs: src + +test-suite genvalidity-property-doctests + type: exitcode-stdio-1.0 + main-is: DocTest.hs + build-depends: + base -any, + doctest >=0.9 && <0.12, + genvalidity-property -any, + directory >= 1.2 && < 1.4, + filepath >= 1.3 && < 1.5 + default-language: Haskell2010 + hs-source-dirs: test + ghc-options: -threaded diff --git a/src/Test/Validity/Functions.hs b/src/Test/Validity/Functions.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Functions.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Validity tests involving functions +module Test.Validity.Functions + ( producesValidsOnGen + , producesValidsOnValids + , producesValid + , producesValidsOnArbitrary + , producesValidsOnGens2 + , producesValidsOnValids2 + , producesValid2 + , producesValidsOnArbitrary2 + , producesValidsOnGens3 + , producesValidsOnValids3 + , producesValid3 + , producesValidsOnArbitrary3 + , succeedsOnGen + , succeedsOnValid + , succeeds + , succeedsOnArbitrary + , succeedsOnGens2 + , succeedsOnValids2 + , succeeds2 + , succeedsOnArbitrary2 + , failsOnGen + , failsOnInvalid + , failsOnGens2 + , failsOnInvalid2 + , validIfSucceedsOnGen + , validIfSucceedsOnValid + , validIfSucceedsOnArbitrary + , validIfSucceeds + , validIfSucceedsOnGens2 + , validIfSucceedsOnValids2 + , validIfSucceeds2 + , validIfSucceedsOnArbitrary2 + , validIfSucceedsOnGens3 + , validIfSucceedsOnValids3 + , validIfSucceeds3 + , validIfSucceedsOnArbitrary3 + , equivalentOnGen + , equivalentOnValid + , equivalent + , equivalentOnArbitrary + , equivalentOnGens2 + , equivalentOnValids2 + , equivalent2 + , equivalentOnArbitrary2 + , equivalentWhenFirstSucceedsOnGen + , equivalentWhenFirstSucceedsOnValid + , equivalentWhenFirstSucceeds + , equivalentWhenFirstSucceedsOnArbitrary + , equivalentWhenFirstSucceedsOnGens2 + , equivalentWhenFirstSucceedsOnValids2 + , equivalentWhenFirstSucceeds2 + , equivalentWhenFirstSucceedsOnArbitrary2 + , equivalentWhenSecondSucceedsOnGen + , equivalentWhenSecondSucceedsOnValid + , equivalentWhenSecondSucceeds + , equivalentWhenSecondSucceedsOnArbitrary + , equivalentWhenSecondSucceedsOnGens2 + , equivalentWhenSecondSucceedsOnValids2 + , equivalentWhenSecondSucceeds2 + , equivalentWhenSecondSucceedsOnArbitrary2 + , equivalentWhenSucceedOnGen + , equivalentWhenSucceedOnValid + , equivalentWhenSucceed + , equivalentWhenSucceedOnArbitrary + , equivalentWhenSucceedOnGens2 + , equivalentWhenSucceedOnValids2 + , equivalentWhenSucceed2 + , equivalentWhenSucceedOnArbitrary2 + , equivalentOnGens3 + , equivalentOnValids3 + , equivalent3 + , equivalentOnArbitrary3 + , inverseFunctionsOnGen + , inverseFunctionsOnValid + , inverseFunctions + , inverseFunctionsOnArbitrary + , inverseFunctionsIfFirstSucceedsOnGen + , inverseFunctionsIfFirstSucceedsOnValid + , inverseFunctionsIfFirstSucceeds + , inverseFunctionsIfFirstSucceedsOnArbitrary + , inverseFunctionsIfSecondSucceedsOnGen + , inverseFunctionsIfSecondSucceedsOnValid + , inverseFunctionsIfSecondSucceeds + , inverseFunctionsIfSecondSucceedsOnArbitrary + , inverseFunctionsIfSucceedOnGen + , inverseFunctionsIfSucceedOnValid + , inverseFunctionsIfSucceed + , inverseFunctionsIfSucceedOnArbitrary + , idempotentOnGen + , idempotentOnValid + , idempotent + , idempotentOnArbitrary + ) where + +import Test.Validity.Functions.CanFail +import Test.Validity.Functions.Equivalence +import Test.Validity.Functions.Idempotence +import Test.Validity.Functions.Inverse +import Test.Validity.Functions.Validity diff --git a/src/Test/Validity/Functions/CanFail.hs b/src/Test/Validity/Functions/CanFail.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Functions/CanFail.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Validity.Functions.CanFail + ( succeedsOnGen + , succeedsOnValid + , succeeds + , succeedsOnArbitrary + , succeedsOnGens2 + , succeedsOnValids2 + , succeeds2 + , succeedsOnArbitrary2 + , failsOnGen + , failsOnInvalid + , failsOnGens2 + , failsOnInvalid2 + , validIfSucceedsOnGen + , validIfSucceedsOnValid + , validIfSucceedsOnArbitrary + , validIfSucceeds + , validIfSucceedsOnGens2 + , validIfSucceedsOnValids2 + , validIfSucceeds2 + , validIfSucceedsOnArbitrary2 + , validIfSucceedsOnGens3 + , validIfSucceedsOnValids3 + , validIfSucceeds3 + , validIfSucceedsOnArbitrary3 + ) where + +import Data.GenValidity + +import Test.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 `shouldSatisfy` (not . hasFailed) + +-- | The function succeeds if the input is generated by @genValid@ +succeedsOnValid + :: (Show a, Show b, Show (f b), GenValid 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), GenUnchecked 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), GenInvalid 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), GenValid 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), GenUnchecked 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 `shouldSatisfy` (not . hasFailed) + +succeedsOnValids2 + :: (Show a, Show b, Show c, Show (f c), GenValid a, GenValid b, CanFail f) + => (a -> b -> f c) -> Property +succeedsOnValids2 func = succeedsOnGens2 func genValid + +succeeds2 + :: ( Show a + , Show b + , Show c + , Show (f c) + , GenUnchecked a + , GenUnchecked 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) + , GenInvalid a + , GenInvalid 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) + , GenValid a + , GenValid 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) + , GenUnchecked a + , GenUnchecked 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 + +validIfSucceedsOnGens3 + :: (Show a, Show b, Show c, Show d, Show (f d), Validity d, CanFail f) + => (a -> b -> c -> f d) -> Gen (a, b, c) -> Property +validIfSucceedsOnGens3 func gen = + forAll gen $ \(a, b, c) -> + case resultIfSucceeded (func a b c) of + Nothing -> return () -- Can happen + Just res -> res `shouldSatisfy` isValid + +validIfSucceedsOnValids3 + :: ( Show a + , Show b + , Show c + , Show d + , Show (f d) + , GenValid a + , GenValid b + , GenValid c + , Validity d + , CanFail f + ) + => (a -> b -> c -> f d) -> Property +validIfSucceedsOnValids3 func = validIfSucceedsOnGens3 func genValid + +validIfSucceeds3 + :: ( Show a + , Show b + , Show c + , Show d + , Show (f d) + , GenUnchecked a + , GenUnchecked b + , GenUnchecked c + , Validity d + , CanFail f + ) + => (a -> b -> c -> f d) -> Property +validIfSucceeds3 func = validIfSucceedsOnGens3 func genUnchecked + +validIfSucceedsOnArbitrary3 + :: ( Show a + , Show b + , Show c + , Show d + , Show (f d) + , Arbitrary a + , Arbitrary b + , Arbitrary c + , Validity d + , CanFail f + ) + => (a -> b -> c -> f d) -> Property +validIfSucceedsOnArbitrary3 func = validIfSucceedsOnGens3 func arbitrary diff --git a/src/Test/Validity/Functions/Equivalence.hs b/src/Test/Validity/Functions/Equivalence.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Functions/Equivalence.hs @@ -0,0 +1,381 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Validity.Functions.Equivalence + ( equivalentOnGen + , equivalentOnValid + , equivalent + , equivalentOnArbitrary + , equivalentOnGens2 + , equivalentOnValids2 + , equivalent2 + , equivalentOnArbitrary2 + , equivalentWhenFirstSucceedsOnGen + , equivalentWhenFirstSucceedsOnValid + , equivalentWhenFirstSucceeds + , equivalentWhenFirstSucceedsOnArbitrary + , equivalentWhenFirstSucceedsOnGens2 + , equivalentWhenFirstSucceedsOnValids2 + , equivalentWhenFirstSucceeds2 + , equivalentWhenFirstSucceedsOnArbitrary2 + , equivalentWhenSecondSucceedsOnGen + , equivalentWhenSecondSucceedsOnValid + , equivalentWhenSecondSucceeds + , equivalentWhenSecondSucceedsOnArbitrary + , equivalentWhenSecondSucceedsOnGens2 + , equivalentWhenSecondSucceedsOnValids2 + , equivalentWhenSecondSucceeds2 + , equivalentWhenSecondSucceedsOnArbitrary2 + , equivalentWhenSucceedOnGen + , equivalentWhenSucceedOnValid + , equivalentWhenSucceed + , equivalentWhenSucceedOnArbitrary + , equivalentWhenSucceedOnGens2 + , equivalentWhenSucceedOnValids2 + , equivalentWhenSucceed2 + , equivalentWhenSucceedOnArbitrary2 + , equivalentOnGens3 + , equivalentOnValids3 + , equivalent3 + , equivalentOnArbitrary3 + ) where + +import Data.GenValidity + +import Test.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, GenValid a, Show b, Eq b) + => (a -> b) -> (a -> b) -> Property +equivalentOnValid f g = equivalentOnGen f g genValid + +equivalent + :: (Show a, Eq a, GenUnchecked a, Show b, Eq b) + => (a -> b) -> (a -> b) -> Property +equivalent f g = equivalentOnGen f g genUnchecked + +-- | +-- +-- prop> equivalentOnArbitrary ((* 2) . (+ 1)) ((+ 2) . (* 2) :: Int -> Int) +equivalentOnArbitrary + :: (Show a, Eq a, Arbitrary a, Show b, Eq b) + => (a -> b) -> (a -> b) -> Property +equivalentOnArbitrary f g = equivalentOnGen f g arbitrary + +equivalentOnGens2 + :: (Show a, Show 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, GenValid a, Show b, GenValid b, Show c, Eq c) + => (a -> b -> c) -> (a -> b -> c) -> Property +equivalentOnValids2 f g = equivalentOnGens2 f g genValid + +equivalent2 + :: (Show a, GenUnchecked a, Show b, GenUnchecked b, Show c, Eq c) + => (a -> b -> c) -> (a -> b -> c) -> Property +equivalent2 f g = equivalentOnGens2 f g genUnchecked + +-- | +-- +-- prop> equivalentOnArbitrary2 (+) ((+) :: Int -> Int -> Int) +equivalentOnArbitrary2 + :: (Show a, Arbitrary a, Show b, Arbitrary b, Show c, Eq c) + => (a -> b -> c) -> (a -> b -> c) -> Property +equivalentOnArbitrary2 f g = equivalentOnGens2 f g arbitrary + +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, GenValid a, Show b, Eq b, CanFail f) + => (a -> f b) -> (a -> b) -> Property +equivalentWhenFirstSucceedsOnValid f g = + equivalentWhenFirstSucceedsOnGen f g genValid + +equivalentWhenFirstSucceedsOnArbitrary + :: (Show a, Eq a, Arbitrary a, Show b, Eq b, CanFail f) + => (a -> f b) -> (a -> b) -> Property +equivalentWhenFirstSucceedsOnArbitrary f g = + equivalentWhenFirstSucceedsOnGen f g arbitrary + +equivalentWhenFirstSucceeds + :: (Show a, Eq a, GenUnchecked 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 + , GenValid a + , Show b + , Eq b + , GenValid b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> f c) -> (a -> b -> c) -> Property +equivalentWhenFirstSucceedsOnValids2 f g = + equivalentWhenFirstSucceedsOnGens2 f g genValid + +equivalentWhenFirstSucceedsOnArbitrary2 + :: ( Show a + , Eq a + , Arbitrary a + , Show b + , Eq b + , Arbitrary b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> f c) -> (a -> b -> c) -> Property +equivalentWhenFirstSucceedsOnArbitrary2 f g = + equivalentWhenFirstSucceedsOnGens2 f g arbitrary + +equivalentWhenFirstSucceeds2 + :: ( Show a + , Eq a + , GenUnchecked a + , Show b + , Eq b + , GenUnchecked 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, GenValid a, Show b, Eq b, CanFail f) + => (a -> b) -> (a -> f b) -> Property +equivalentWhenSecondSucceedsOnValid f g = + equivalentWhenSecondSucceedsOnGen f g genValid + +equivalentWhenSecondSucceedsOnArbitrary + :: (Show a, Eq a, Arbitrary a, Show b, Eq b, CanFail f) + => (a -> b) -> (a -> f b) -> Property +equivalentWhenSecondSucceedsOnArbitrary f g = + equivalentWhenSecondSucceedsOnGen f g arbitrary + +equivalentWhenSecondSucceeds + :: (Show a, Eq a, GenUnchecked 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 + , GenValid a + , Show b + , Eq b + , GenValid b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> c) -> (a -> b -> f c) -> Property +equivalentWhenSecondSucceedsOnValids2 f g = + equivalentWhenSecondSucceedsOnGens2 f g genValid + +equivalentWhenSecondSucceedsOnArbitrary2 + :: ( Show a + , Eq a + , Arbitrary a + , Show b + , Eq b + , Arbitrary b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> c) -> (a -> b -> f c) -> Property +equivalentWhenSecondSucceedsOnArbitrary2 f g = + equivalentWhenSecondSucceedsOnGens2 f g arbitrary + +equivalentWhenSecondSucceeds2 + :: ( Show a + , Eq a + , GenUnchecked a + , Show b + , Eq b + , GenUnchecked 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, GenValid 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, GenUnchecked a, Show b, Eq b, CanFail f) + => (a -> f b) -> (a -> f b) -> Property +equivalentWhenSucceed f g = equivalentWhenSucceedOnGen f g genUnchecked + +equivalentWhenSucceedOnArbitrary + :: (Show a, Eq a, Arbitrary a, Show b, Eq b, CanFail f) + => (a -> f b) -> (a -> f b) -> Property +equivalentWhenSucceedOnArbitrary f g = equivalentWhenSucceedOnGen f g arbitrary + +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 + , GenValid a + , Show b + , Eq b + , GenValid b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> f c) -> (a -> b -> f c) -> Property +equivalentWhenSucceedOnValids2 f g = equivalentWhenSucceedOnGens2 f g genValid + +equivalentWhenSucceedOnArbitrary2 + :: ( Show a + , Eq a + , Arbitrary a + , Show b + , Eq b + , Arbitrary b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> f c) -> (a -> b -> f c) -> Property +equivalentWhenSucceedOnArbitrary2 f g = + equivalentWhenSucceedOnGens2 f g arbitrary + +equivalentWhenSucceed2 + :: ( Show a + , Eq a + , GenUnchecked a + , Show b + , Eq b + , GenUnchecked b + , Show c + , Eq c + , CanFail f + ) + => (a -> b -> f c) -> (a -> b -> f c) -> Property +equivalentWhenSucceed2 f g = equivalentWhenSucceedOnGens2 f g genUnchecked + +equivalentOnGens3 + :: (Show a, Show b, Show c, Show d, Eq d) + => (a -> b -> c -> d) -> (a -> b -> c -> d) -> Gen (a, b, c) -> Property +equivalentOnGens3 f g gen = + forAll gen $ \(a, b, c) -> f a b c `shouldBe` g a b c + +equivalentOnValids3 + :: ( Show a + , GenValid a + , Show b + , GenValid b + , Show c + , GenValid c + , Show d + , Eq d + ) + => (a -> b -> c -> d) -> (a -> b -> c -> d) -> Property +equivalentOnValids3 f g = equivalentOnGens3 f g genValid + +equivalent3 + :: ( Show a + , GenUnchecked a + , Show b + , GenUnchecked b + , Show c + , GenUnchecked c + , Show d + , Eq d + ) + => (a -> b -> c -> d) -> (a -> b -> c -> d) -> Property +equivalent3 f g = equivalentOnGens3 f g genUnchecked + +equivalentOnArbitrary3 + :: ( Show a + , Arbitrary a + , Show b + , Arbitrary b + , Show c + , Arbitrary c + , Show d + , Eq d + ) + => (a -> b -> c -> d) -> (a -> b -> c -> d) -> Property +equivalentOnArbitrary3 f g = equivalentOnGens3 f g arbitrary diff --git a/src/Test/Validity/Functions/Idempotence.hs b/src/Test/Validity/Functions/Idempotence.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Functions/Idempotence.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Standard tests involving validity +module Test.Validity.Functions.Idempotence + ( 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, GenValid a) + => (a -> a) -> Property +idempotentOnValid func = idempotentOnGen func genValid + +idempotent + :: (Show a, Eq a, GenUnchecked a) + => (a -> a) -> Property +idempotent func = idempotentOnGen func genUnchecked + +-- | +-- +-- 'id' is idempotent for any type: +-- +-- prop> idempotentOnArbitrary (id :: Int -> Int) +-- +-- 'const', given any input, is idempotent for any type as well: +-- +-- prop> \int -> idempotentOnArbitrary (const int :: Int -> Int) +idempotentOnArbitrary + :: (Show a, Eq a, Arbitrary a) + => (a -> a) -> Property +idempotentOnArbitrary func = idempotentOnGen func arbitrary diff --git a/src/Test/Validity/Functions/Inverse.hs b/src/Test/Validity/Functions/Inverse.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Functions/Inverse.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Standard tests involving inverse functions +module Test.Validity.Functions.Inverse + ( inverseFunctionsOnGen + , inverseFunctionsOnValid + , inverseFunctions + , inverseFunctionsOnArbitrary + , inverseFunctionsIfFirstSucceedsOnGen + , inverseFunctionsIfFirstSucceedsOnValid + , inverseFunctionsIfFirstSucceeds + , inverseFunctionsIfFirstSucceedsOnArbitrary + , inverseFunctionsIfSecondSucceedsOnGen + , inverseFunctionsIfSecondSucceedsOnValid + , inverseFunctionsIfSecondSucceeds + , inverseFunctionsIfSecondSucceedsOnArbitrary + , inverseFunctionsIfSucceedOnGen + , inverseFunctionsIfSucceedOnValid + , inverseFunctionsIfSucceed + , inverseFunctionsIfSucceedOnArbitrary + ) where + +import Data.GenValidity + +import Test.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, GenValid a) + => (a -> b) -> (b -> a) -> Property +inverseFunctionsOnValid f g = inverseFunctionsOnGen f g genValid + +inverseFunctions + :: (Show a, Eq a, GenUnchecked 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, GenValid a, CanFail f) + => (a -> f b) -> (b -> a) -> Property +inverseFunctionsIfFirstSucceedsOnValid f g = + inverseFunctionsIfFirstSucceedsOnGen f g genValid + +inverseFunctionsIfFirstSucceeds + :: (Show a, Eq a, GenUnchecked 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, GenValid a, CanFail f) + => (a -> b) -> (b -> f a) -> Property +inverseFunctionsIfSecondSucceedsOnValid f g = + inverseFunctionsIfSecondSucceedsOnGen f g genValid + +inverseFunctionsIfSecondSucceeds + :: (Show a, Eq a, GenUnchecked 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, GenValid a, CanFail f, CanFail g) + => (a -> f b) -> (b -> g a) -> Property +inverseFunctionsIfSucceedOnValid f g = + inverseFunctionsIfSucceedOnGen f g genValid + +inverseFunctionsIfSucceed + :: (Show a, Eq a, GenUnchecked a, CanFail f, CanFail g) + => (a -> f b) -> (b -> g a) -> Property +inverseFunctionsIfSucceed f g = inverseFunctionsIfSucceedOnGen f g genUnchecked + +inverseFunctionsIfSucceedOnArbitrary + :: (Show a, Eq a, Arbitrary a, CanFail f, CanFail g) + => (a -> f b) -> (b -> g a) -> Property +inverseFunctionsIfSucceedOnArbitrary f g = + inverseFunctionsIfSucceedOnGen f g arbitrary diff --git a/src/Test/Validity/Functions/Validity.hs b/src/Test/Validity/Functions/Validity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Functions/Validity.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Standard tests involving validity +module Test.Validity.Functions.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 +-- @genValid@ +producesValidsOnValids + :: (Show a, Show b, GenValid a, Validity b) + => (a -> b) -> Property +producesValidsOnValids = (`producesValidsOnGen` genValid) + +-- | The function produces valid output when the input is generated by +-- @genUnchecked@ +producesValid + :: (Show a, Show b, GenUnchecked a, Validity b) + => (a -> b) -> Property +producesValid = (`producesValidsOnGen` genUnchecked) + +-- | 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) + +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, GenValid a, GenValid b, Validity c) + => (a -> b -> c) -> Property +producesValidsOnValids2 func = producesValidsOnGens2 func genValid + +producesValid2 + :: (Show a, Show b, Show c, GenUnchecked a, GenUnchecked b, Validity c) + => (a -> b -> c) -> Property +producesValid2 func = producesValidsOnGens2 func genUnchecked + +producesValidsOnArbitrary2 + :: (Show a, Show b, Show c, Arbitrary a, Arbitrary b, Validity c) + => (a -> b -> c) -> Property +producesValidsOnArbitrary2 func = producesValidsOnGens2 func arbitrary + +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 + +producesValidsOnValids3 + :: ( Show a + , Show b + , Show c + , Show d + , GenValid a + , GenValid b + , GenValid c + , Validity d + ) + => (a -> b -> c -> d) -> Property +producesValidsOnValids3 func = producesValidsOnGens3 func genValid + +producesValid3 + :: ( Show a + , Show b + , Show c + , Show d + , GenUnchecked a + , GenUnchecked b + , GenUnchecked c + , Validity d + ) + => (a -> b -> c -> d) -> Property +producesValid3 func = producesValidsOnGens3 func genUnchecked + +producesValidsOnArbitrary3 + :: ( Show a + , Show b + , Show c + , Show d + , Arbitrary a + , Arbitrary b + , Arbitrary c + , Validity d + ) + => (a -> b -> c -> d) -> Property +producesValidsOnArbitrary3 func = producesValidsOnGens3 func arbitrary diff --git a/src/Test/Validity/GenValidity/Property.hs b/src/Test/Validity/GenValidity/Property.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/GenValidity/Property.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Tests for GenValidity instances +module Test.Validity.GenValidity.Property + ( genGeneratesValid + , genGeneratesInvalid + ) where + +import Data.Data + +import Data.GenValidity + +import Test.Hspec +import Test.QuickCheck + +import Test.Validity.Property.Utils + +-- | The given generator generates only valid data points +genGeneratesValid + :: forall a. + (Show a, Validity a) + => Gen a -> Property +genGeneratesValid gen = forAll gen (`shouldSatisfy` isValid) + +-- | The given generator generates only invalid data points +genGeneratesInvalid + :: forall a. + (Show a, Validity a) + => Gen a -> Property +genGeneratesInvalid gen = forAll gen (`shouldSatisfy` isInvalid) diff --git a/src/Test/Validity/Operations.hs b/src/Test/Validity/Operations.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Operations.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Properties of operations +module Test.Validity.Operations + ( leftIdentityOnElemWithEquality + , leftIdentityOnGenWithEquality + , leftIdentityOnGen + , leftIdentityOnValid + , leftIdentity + , leftIdentityOnArbitrary + , rightIdentityOnElemWithEquality + , rightIdentityOnGenWithEquality + , rightIdentityOnGen + , rightIdentityOnValid + , rightIdentity + , rightIdentityOnArbitrary + , identityOnGen + , identityOnValid + , identity + , identityOnArbitrary + , associativeOnGens + , associativeOnValids + , associative + , associativeOnArbitrary + , commutativeOnGens + , commutativeOnValids + , commutative + , commutativeOnArbitrary + ) where + +import Test.Validity.Operations.Associativity +import Test.Validity.Operations.Commutativity +import Test.Validity.Operations.Identity diff --git a/src/Test/Validity/Operations/Associativity.hs b/src/Test/Validity/Operations/Associativity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Operations/Associativity.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Validity.Operations.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, GenValid a) + => (a -> a -> a) -> Property +associativeOnValids op = associativeOnGens op genValid + +-- | +-- +-- prop> associative ((*) :: Int -> Int -> Int) +-- prop> associative ((+) :: Int -> Int -> Int) +associative + :: (Show a, Eq a, GenUnchecked a) + => (a -> a -> a) -> Property +associative op = associativeOnGens op genUnchecked + +-- | +-- +-- prop> associativeOnArbitrary ((*) :: Int -> Int -> Int) +-- prop> associativeOnArbitrary ((+) :: Int -> Int -> Int) +associativeOnArbitrary + :: (Show a, Eq a, Arbitrary a) + => (a -> a -> a) -> Property +associativeOnArbitrary op = associativeOnGens op arbitrary diff --git a/src/Test/Validity/Operations/Commutativity.hs b/src/Test/Validity/Operations/Commutativity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Operations/Commutativity.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Validity.Operations.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) + +-- | +-- +-- prop> commutative ((+) :: Double -> Double -> Double) +-- prop> commutative ((*) :: Double -> Double -> Double) +commutativeOnValids + :: (Show a, Eq a, GenValid a) + => (a -> a -> a) -> Property +commutativeOnValids op = commutativeOnGens op genValid + +-- | +-- +-- prop> commutative ((+) :: Int -> Int -> Int) +-- prop> commutative ((*) :: Int -> Int -> Int) +commutative + :: (Show a, Eq a, GenUnchecked a) + => (a -> a -> a) -> Property +commutative op = commutativeOnGens op genUnchecked + +-- | +-- +-- prop> commutativeOnArbitrary ((+) :: Int -> Int -> Int) +-- prop> commutativeOnArbitrary ((*) :: Int -> Int -> Int) +commutativeOnArbitrary + :: (Show a, Eq a, Arbitrary a) + => (a -> a -> a) -> Property +commutativeOnArbitrary op = commutativeOnGens op arbitrary diff --git a/src/Test/Validity/Operations/Identity.hs b/src/Test/Validity/Operations/Identity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Operations/Identity.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Validity.Operations.Identity + ( leftIdentityOnElemWithEquality + , leftIdentityOnGenWithEquality + , leftIdentityOnGen + , leftIdentityOnValid + , leftIdentity + , leftIdentityOnArbitrary + , rightIdentityOnElemWithEquality + , rightIdentityOnGenWithEquality + , rightIdentityOnGen + , rightIdentityOnValid + , rightIdentity + , rightIdentityOnArbitrary + , identityOnGen + , identityOnValid + , identity + , identityOnArbitrary + ) where + +import Data.GenValidity + +import Test.QuickCheck + +-- | +-- +-- \[ +-- LeftIdentity(\star, \doteq, b) +-- \quad\equiv\quad +-- \forall a: (b \star a) \doteq a +-- \] +leftIdentityOnElemWithEquality + :: (b -> a -> a) -- ^ A binary operation + -> (a -> a -> Bool) -- ^ An equality + -> b -- ^ A candidate left-identity + -> a -- ^ An element + -> Bool +leftIdentityOnElemWithEquality op eq b a = (b `op` a) `eq` a + +leftIdentityOnGenWithEquality + :: Show a + => (b -> a -> a) -- ^ A binary operation + -> (a -> a -> Bool) -- ^ An equality + -> b -- ^ A candidate left-identity + -> Gen a + -> 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 (==) + +-- | +-- +-- prop> leftIdentityOnValid (flip ((^) :: Double -> Int -> Double)) 1 +leftIdentityOnValid + :: (Show a, Eq a, GenValid a) + => (b -> a -> a) -> b -> Property +leftIdentityOnValid op b = leftIdentityOnGen op b genValid + +-- | +-- +-- prop> leftIdentity (flip ((^) :: Int -> Int -> Int)) 1 +leftIdentity + :: (Show a, Eq a, GenUnchecked a) + => (b -> a -> a) -> b -> Property +leftIdentity op b = leftIdentityOnGen op b genUnchecked + +-- | +-- +-- prop> leftIdentityOnArbitrary (flip ((^) :: Int -> Int -> Int)) 1 +leftIdentityOnArbitrary + :: (Show a, Eq a, Arbitrary a) + => (b -> a -> a) -> b -> Property +leftIdentityOnArbitrary op b = leftIdentityOnGen op b arbitrary + +-- | +-- +-- \[ +-- 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 (==) + +-- | +-- +-- prop> rightIdentityOnValid ((^) :: Double -> Int -> Double) 1 +rightIdentityOnValid + :: (Show a, Eq a, GenValid a) + => (a -> b -> a) -> b -> Property +rightIdentityOnValid op b = rightIdentityOnGen op b genValid + +-- | +-- +-- prop> rightIdentity ((^) :: Int -> Int -> Int) 1 +rightIdentity + :: (Show a, Eq a, GenUnchecked a) + => (a -> b -> a) -> b -> Property +rightIdentity op b = rightIdentityOnGen op b genUnchecked + +-- | +-- +-- prop> rightIdentityOnArbitrary ((^) :: Int -> Int -> Int) 1 +rightIdentityOnArbitrary + :: (Show a, Eq a, Arbitrary a) + => (a -> b -> a) -> b -> Property +rightIdentityOnArbitrary op b = rightIdentityOnGen op b arbitrary + +identityOnGen + :: (Show a, Eq a) + => (a -> a -> a) -> a -> Gen a -> Property +identityOnGen op e gen = + leftIdentityOnGen op e gen .&&. rightIdentityOnGen op e gen + +-- | +-- +-- prop> identityOnValid ((*) :: Double -> Double -> Double) 1 +-- prop> identityOnValid ((+) :: Double -> Double -> Double) 0 +identityOnValid + :: (Show a, Eq a, GenValid a) + => (a -> a -> a) -> a -> Property +identityOnValid op a = identityOnGen op a genValid + +-- | +-- +-- prop> identity ((*) :: Int -> Int -> Int) 1 +-- prop> identity ((+) :: Int -> Int -> Int) 0 +identity + :: (Show a, Eq a, GenUnchecked a) + => (a -> a -> a) -> a -> Property +identity op e = identityOnGen op e genUnchecked + +-- | +-- +-- prop> identityOnArbitrary ((*) :: Int -> Int -> Int) 1 +-- prop> identityOnArbitrary ((+) :: Int -> Int -> Int) 0 +identityOnArbitrary + :: (Show a, Eq a, Arbitrary a) + => (a -> a -> a) -> a -> Property +identityOnArbitrary op a = identityOnGen op a arbitrary diff --git a/src/Test/Validity/Property.hs b/src/Test/Validity/Property.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Property.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Validity.Property + ( module Data.GenValidity + -- * Tests for GenValidity instances + , genGeneratesValid + , genGeneratesInvalid + -- * Standard tests involving functions + -- ** Standard tests involving validity + , producesValidsOnGen + , producesValidsOnValids + , producesValid + , producesValidsOnArbitrary + , producesValidsOnGens2 + , producesValidsOnValids2 + , producesValid2 + , producesValidsOnArbitrary2 + , producesValidsOnGens3 + , producesValidsOnValids3 + , producesValid3 + , producesValidsOnArbitrary3 + -- ** Standard tests involving functions that can fail + , CanFail(..) + , succeedsOnGen + , succeedsOnValid + , succeeds + , succeedsOnArbitrary + , succeedsOnGens2 + , succeedsOnValids2 + , succeeds2 + , succeedsOnArbitrary2 + , failsOnGen + , failsOnInvalid + , failsOnGens2 + , failsOnInvalid2 + , validIfSucceedsOnGen + , validIfSucceedsOnValid + , validIfSucceedsOnArbitrary + , validIfSucceeds + , validIfSucceedsOnGens2 + , validIfSucceedsOnValids2 + , validIfSucceeds2 + , validIfSucceedsOnArbitrary2 + , validIfSucceedsOnGens3 + , validIfSucceedsOnValids3 + , validIfSucceeds3 + , validIfSucceedsOnArbitrary3 + -- ** Standard tests involving equivalence of functions + -- *** Simple functions + -- **** One argument + , equivalentOnGen + , equivalentOnValid + , equivalent + , equivalentOnArbitrary + -- **** Two arguments + , equivalentOnGens2 + , equivalentOnValids2 + , equivalent2 + , equivalentOnArbitrary2 + -- **** Three arguments + , equivalentOnGens3 + , equivalentOnValids3 + , equivalent3 + , equivalentOnArbitrary3 + -- *** First function can fail + -- **** One argument + , equivalentWhenFirstSucceedsOnGen + , equivalentWhenFirstSucceedsOnValid + , equivalentWhenFirstSucceeds + , equivalentWhenFirstSucceedsOnArbitrary + -- **** Two arguments + , equivalentWhenFirstSucceedsOnGens2 + , equivalentWhenFirstSucceedsOnValids2 + , equivalentWhenFirstSucceeds2 + , equivalentWhenFirstSucceedsOnArbitrary2 + -- *** Second function can fail + -- **** One argument + , equivalentWhenSecondSucceedsOnGen + , equivalentWhenSecondSucceedsOnValid + , equivalentWhenSecondSucceeds + , equivalentWhenSecondSucceedsOnArbitrary + -- **** Two arguments + , equivalentWhenSecondSucceedsOnGens2 + , equivalentWhenSecondSucceedsOnValids2 + , equivalentWhenSecondSucceeds2 + , equivalentWhenSecondSucceedsOnArbitrary2 + -- *** Both functions can fail + -- **** One argument + , equivalentWhenSucceedOnGen + , equivalentWhenSucceedOnValid + , equivalentWhenSucceed + , equivalentWhenSucceedOnArbitrary + -- **** Two arguments + , equivalentWhenSucceedOnGens2 + , equivalentWhenSucceedOnValids2 + , equivalentWhenSucceed2 + , equivalentWhenSucceedOnArbitrary2 + -- ** Standard tests involving inverse functions + , inverseFunctionsOnGen + , inverseFunctionsOnValid + , inverseFunctions + , inverseFunctionsOnArbitrary + , inverseFunctionsIfFirstSucceedsOnGen + , inverseFunctionsIfFirstSucceedsOnValid + , inverseFunctionsIfFirstSucceeds + , inverseFunctionsIfFirstSucceedsOnArbitrary + , inverseFunctionsIfSecondSucceedsOnGen + , inverseFunctionsIfSecondSucceedsOnValid + , inverseFunctionsIfSecondSucceeds + , inverseFunctionsIfSecondSucceedsOnArbitrary + , inverseFunctionsIfSucceedOnGen + , inverseFunctionsIfSucceedOnValid + , inverseFunctionsIfSucceed + , inverseFunctionsIfSucceedOnArbitrary + -- ** Properties involving idempotence + , idempotentOnGen + , idempotentOnValid + , idempotent + , idempotentOnArbitrary + -- * Properties of relations + -- ** Reflexivity + , reflexiveOnElem + , reflexivityOnGen + , reflexivityOnValid + , reflexivity + , reflexivityOnArbitrary + -- ** Transitivity + , transitiveOnElems + , transitivityOnGens + , transitivityOnValid + , transitivity + , transitivityOnArbitrary + -- ** Antisymmetry + , antisymmetricOnElemsWithEquality + , antisymmetryOnGensWithEquality + , antisymmetryOnGens + , antisymmetryOnValid + , antisymmetry + , antisymmetryOnArbitrary + -- ** Antireflexivity + , antireflexiveOnElem + , antireflexivityOnGen + , antireflexivityOnValid + , antireflexivity + , antireflexivityOnArbitrary + -- ** Symmetry + , symmetricOnElems + , symmetryOnGens + , symmetryOnValid + , symmetry + , symmetryOnArbitrary + -- * Properties of operations + -- ** Identity element + -- *** Left Identity + , leftIdentityOnElemWithEquality + , leftIdentityOnGenWithEquality + , leftIdentityOnGen + , leftIdentityOnValid + , leftIdentity + , leftIdentityOnArbitrary + -- *** Right Identity + , rightIdentityOnElemWithEquality + , rightIdentityOnGenWithEquality + , rightIdentityOnGen + , rightIdentityOnValid + , rightIdentity + , rightIdentityOnArbitrary + -- *** Identity + , identityOnGen + , identityOnValid + , identity + , identityOnArbitrary + -- ** Associativity + , associativeOnGens + , associativeOnValids + , associative + , associativeOnArbitrary + -- ** Commutativity + , commutativeOnGens + , commutativeOnValids + , commutative + , commutativeOnArbitrary + ) where + +import Data.GenValidity + +import Test.Validity.Functions +import Test.Validity.GenValidity.Property +import Test.Validity.Operations +import Test.Validity.Relations +import Test.Validity.Types diff --git a/src/Test/Validity/Property/Utils.hs b/src/Test/Validity/Property/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Property/Utils.hs @@ -0,0 +1,12 @@ +module Test.Validity.Property.Utils + ( (<==>) + , (===>) + ) where + +import Data.Data + +(===>) :: Bool -> Bool -> Bool +(===>) a b = not a || b + +(<==>) :: Bool -> Bool -> Bool +(<==>) a b = a ===> b && b ===> a diff --git a/src/Test/Validity/Relations.hs b/src/Test/Validity/Relations.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Relations.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Properties of relations +module Test.Validity.Relations + ( reflexiveOnElem + , reflexivityOnGen + , reflexivityOnValid + , reflexivity + , reflexivityOnArbitrary + , transitiveOnElems + , transitivityOnGens + , transitivityOnValid + , transitivity + , transitivityOnArbitrary + , antisymmetricOnElemsWithEquality + , antisymmetryOnGensWithEquality + , antisymmetryOnGens + , antisymmetryOnValid + , antisymmetry + , antisymmetryOnArbitrary + , antireflexiveOnElem + , antireflexivityOnGen + , antireflexivityOnValid + , antireflexivity + , antireflexivityOnArbitrary + , symmetricOnElems + , symmetryOnGens + , symmetryOnValid + , symmetry + , symmetryOnArbitrary + ) where + +import Test.Validity.Relations.Antireflexivity +import Test.Validity.Relations.Antisymmetry +import Test.Validity.Relations.Reflexivity +import Test.Validity.Relations.Symmetry +import Test.Validity.Relations.Transitivity diff --git a/src/Test/Validity/Relations/Antireflexivity.hs b/src/Test/Validity/Relations/Antireflexivity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Relations/Antireflexivity.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Validity.Relations.Antireflexivity + ( antireflexiveOnElem + , antireflexivityOnGen + , antireflexivityOnValid + , antireflexivity + , antireflexivityOnArbitrary + ) where + +import Data.GenValidity + +import Test.QuickCheck + +-- | +-- +-- \[ +-- Antireflexive(\prec) +-- \quad\equiv\quad +-- \forall a: \neg (a \prec a) +-- \] +antireflexiveOnElem + :: (a -> a -> Bool) -- ^ A relation + -> a -- ^ An element + -> Bool +antireflexiveOnElem func a = not $ func a a + +antireflexivityOnGen + :: Show a + => (a -> a -> Bool) -> Gen a -> Property +antireflexivityOnGen func gen = forAll gen $ antireflexiveOnElem func + +-- | +-- +-- prop> antireflexivityOnValid ((<) :: Double -> Double -> Bool) +-- prop> antireflexivityOnValid ((/=) :: Double -> Double -> Bool) +-- prop> antireflexivityOnValid ((>) :: Double -> Double -> Bool) +antireflexivityOnValid + :: (Show a, GenValid a) + => (a -> a -> Bool) -> Property +antireflexivityOnValid func = antireflexivityOnGen func genValid + +-- | +-- +-- prop> antireflexivity ((<) :: Int -> Int -> Bool) +-- prop> antireflexivity ((/=) :: Int -> Int -> Bool) +-- prop> antireflexivity ((>) :: Int -> Int -> Bool) +antireflexivity + :: (Show a, GenUnchecked a) + => (a -> a -> Bool) -> Property +antireflexivity func = antireflexivityOnGen func genUnchecked + +-- | +-- +-- prop> antireflexivityOnArbitrary ((<) :: Int -> Int -> Bool) +-- prop> antireflexivityOnArbitrary ((/=) :: Int -> Int -> Bool) +-- prop> antireflexivityOnArbitrary ((>) :: Int -> Int -> Bool) +antireflexivityOnArbitrary + :: (Show a, Arbitrary a) + => (a -> a -> Bool) -> Property +antireflexivityOnArbitrary func = antireflexivityOnGen func arbitrary diff --git a/src/Test/Validity/Relations/Antisymmetry.hs b/src/Test/Validity/Relations/Antisymmetry.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Relations/Antisymmetry.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Validity.Relations.Antisymmetry + ( antisymmetricOnElemsWithEquality + , antisymmetryOnGensWithEquality + , antisymmetryOnGens + , antisymmetryOnValid + , antisymmetry + , antisymmetryOnArbitrary + ) where + +import Data.GenValidity + +import Test.QuickCheck + +import Test.Validity.Property.Utils + +-- | +-- +-- \[ +-- Antisymmetric(\prec, \doteq) +-- \quad\equiv\quad +-- \forall a, b: ((a \prec b) \wedge (b \prec a)) \Rightarrow (a \doteq b) +-- \] +antisymmetricOnElemsWithEquality + :: (a -> a -> Bool) -- ^ A relation + -> (a -> a -> Bool) -- ^ An equivalence relation + -> a + -> a -- ^ Two elements + -> Bool +antisymmetricOnElemsWithEquality func eq a b = + (func a b && func b a) ===> (a `eq` b) + +antisymmetryOnGensWithEquality + :: Show a + => (a -> a -> Bool) -> Gen (a, a) -> (a -> a -> Bool) -> Property +antisymmetryOnGensWithEquality func gen eq = + forAll gen $ uncurry $ antisymmetricOnElemsWithEquality func eq + +antisymmetryOnGens + :: (Show a, Eq a) + => (a -> a -> Bool) -> Gen (a, a) -> Property +antisymmetryOnGens func gen = antisymmetryOnGensWithEquality func gen (==) + +-- | +-- +-- prop> antisymmetryOnValid ((>) :: Double -> Double -> Bool) +-- prop> antisymmetryOnValid ((>=) :: Double -> Double -> Bool) +-- prop> antisymmetryOnValid ((<=) :: Double -> Double -> Bool) +-- prop> antisymmetryOnValid ((<) :: Double -> Double -> Bool) +-- prop> antisymmetryOnValid (Data.List.isPrefixOf :: [Double] -> [Double] -> Bool) +-- prop> antisymmetryOnValid (Data.List.isSuffixOf :: [Double] -> [Double] -> Bool) +-- prop> antisymmetryOnValid (Data.List.isInfixOf :: [Double] -> [Double] -> Bool) +antisymmetryOnValid + :: (Show a, Eq a, GenValid a) + => (a -> a -> Bool) -> Property +antisymmetryOnValid func = antisymmetryOnGens func genValid + +-- | +-- +-- prop> antisymmetry ((>) :: Int -> Int -> Bool) +-- prop> antisymmetry ((>=) :: Int -> Int -> Bool) +-- prop> antisymmetry ((<=) :: Int -> Int -> Bool) +-- prop> antisymmetry ((<) :: Int -> Int -> Bool) +-- prop> antisymmetry (Data.List.isPrefixOf :: [Int] -> [Int] -> Bool) +-- prop> antisymmetry (Data.List.isSuffixOf :: [Int] -> [Int] -> Bool) +-- prop> antisymmetry (Data.List.isInfixOf :: [Int] -> [Int] -> Bool) +-- prop> antisymmetry ((\x y -> even x && odd y) :: Int -> Int -> Bool) +antisymmetry + :: (Show a, Eq a, GenUnchecked a) + => (a -> a -> Bool) -> Property +antisymmetry func = antisymmetryOnGens func genUnchecked + +-- | +-- +-- prop> antisymmetryOnArbitrary ((>) :: Int -> Int -> Bool) +-- prop> antisymmetryOnArbitrary ((>=) :: Int -> Int -> Bool) +-- prop> antisymmetryOnArbitrary ((<=) :: Int -> Int -> Bool) +-- prop> antisymmetryOnArbitrary ((<) :: Int -> Int -> Bool) +-- prop> antisymmetryOnArbitrary (Data.List.isPrefixOf :: [Int] -> [Int] -> Bool) +-- prop> antisymmetryOnArbitrary (Data.List.isSuffixOf :: [Int] -> [Int] -> Bool) +-- prop> antisymmetryOnArbitrary (Data.List.isInfixOf :: [Int] -> [Int] -> Bool) +-- prop> antisymmetryOnArbitrary ((\x y -> even x && odd y) :: Int -> Int -> Bool) +antisymmetryOnArbitrary + :: (Show a, Eq a, Arbitrary a) + => (a -> a -> Bool) -> Property +antisymmetryOnArbitrary func = antisymmetryOnGens func arbitrary diff --git a/src/Test/Validity/Relations/Reflexivity.hs b/src/Test/Validity/Relations/Reflexivity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Relations/Reflexivity.hs @@ -0,0 +1,71 @@ +{-# 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 + +-- | +-- +-- prop> reflexivityOnValid ((<=) :: Double -> Double -> Bool) +-- prop> reflexivityOnValid ((==) :: Double -> Double -> Bool) +-- prop> reflexivityOnValid ((>=) :: Double -> Double -> Bool) +-- prop> reflexivityOnValid (Data.List.isPrefixOf :: [Double] -> [Double] -> Bool) +-- prop> reflexivityOnValid (Data.List.isSuffixOf :: [Double] -> [Double] -> Bool) +-- prop> reflexivityOnValid (Data.List.isInfixOf :: [Double] -> [Double] -> Bool) +reflexivityOnValid + :: (Show a, GenValid a) + => (a -> a -> Bool) -> Property +reflexivityOnValid func = reflexivityOnGen func genValid + +-- | +-- +-- prop> reflexivity ((<=) :: Int -> Int -> Bool) +-- prop> reflexivity ((==) :: Int -> Int -> Bool) +-- prop> reflexivity ((>=) :: Int -> Int -> Bool) +-- prop> reflexivity (Data.List.isPrefixOf :: [Int] -> [Int] -> Bool) +-- prop> reflexivity (Data.List.isSuffixOf :: [Int] -> [Int] -> Bool) +-- prop> reflexivity (Data.List.isInfixOf :: [Int] -> [Int] -> Bool) +reflexivity + :: (Show a, GenUnchecked a) + => (a -> a -> Bool) -> Property +reflexivity func = reflexivityOnGen func genUnchecked + +-- | +-- +-- prop> reflexivityOnArbitrary ((<=) :: Int -> Int -> Bool) +-- prop> reflexivityOnArbitrary ((==) :: Int -> Int -> Bool) +-- prop> reflexivityOnArbitrary ((>=) :: Int -> Int -> Bool) +-- prop> reflexivityOnArbitrary (Data.List.isPrefixOf :: [Int] -> [Int] -> Bool) +-- prop> reflexivityOnArbitrary (Data.List.isSuffixOf :: [Int] -> [Int] -> Bool) +-- prop> reflexivityOnArbitrary (Data.List.isInfixOf :: [Int] -> [Int] -> Bool) +reflexivityOnArbitrary + :: (Show a, Arbitrary a) + => (a -> a -> Bool) -> Property +reflexivityOnArbitrary func = reflexivityOnGen func arbitrary diff --git a/src/Test/Validity/Relations/Symmetry.hs b/src/Test/Validity/Relations/Symmetry.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Relations/Symmetry.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Validity.Relations.Symmetry + ( symmetricOnElems + , symmetryOnGens + , symmetryOnValid + , symmetry + , symmetryOnArbitrary + ) where + +import Data.GenValidity + +import Test.QuickCheck + +import Test.Validity.Property.Utils + +-- | +-- +-- \[ +-- Symmetric(\prec) +-- \quad\equiv\quad +-- \forall a, b: (a \prec b) \Leftrightarrow (b \prec a) +-- \] +symmetricOnElems + :: (a -> a -> Bool) -- ^ A relation + -> a + -> a -- ^ Two elements + -> Bool +symmetricOnElems func a b = func a b <==> func b a + +symmetryOnGens + :: Show a + => (a -> a -> Bool) -> Gen (a, a) -> Property +symmetryOnGens func gen = forAll gen $ uncurry $ symmetricOnElems func + +-- | +-- +-- prop> symmetryOnValid ((==) :: Double -> Double -> Bool) +-- prop> symmetryOnValid ((/=) :: Double -> Double -> Bool) +symmetryOnValid + :: (Show a, GenValid a) + => (a -> a -> Bool) -> Property +symmetryOnValid func = symmetryOnGens func genValid + +-- | +-- +-- prop> symmetry ((==) :: Int -> Int -> Bool) +-- prop> symmetry ((/=) :: Int -> Int -> Bool) +symmetry + :: (Show a, GenUnchecked a) + => (a -> a -> Bool) -> Property +symmetry func = symmetryOnGens func genUnchecked + +-- | +-- +-- prop> symmetryOnArbitrary ((==) :: Int -> Int -> Bool) +-- prop> symmetryOnArbitrary ((/=) :: Int -> Int -> Bool) +symmetryOnArbitrary + :: (Show a, Arbitrary a) + => (a -> a -> Bool) -> Property +symmetryOnArbitrary func = symmetryOnGens func arbitrary diff --git a/src/Test/Validity/Relations/Transitivity.hs b/src/Test/Validity/Relations/Transitivity.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Relations/Transitivity.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Validity.Relations.Transitivity + ( transitiveOnElems + , transitivityOnGens + , transitivityOnValid + , transitivity + , transitivityOnArbitrary + ) where + +import Data.GenValidity + +import Test.QuickCheck + +import Test.Validity.Property.Utils + +-- | +-- +-- \[ +-- Transitive(\prec) +-- \quad\equiv\quad +-- \forall a, b, c: ((a \prec b) \wedge (b \prec c)) \Rightarrow (a \prec c) +-- \] +transitiveOnElems + :: (a -> a -> Bool) -- ^ A relation + -> a + -> a + -> a -- ^ Three elements + -> Bool +transitiveOnElems func a b c = (func a b && func b c) ===> func a c + +transitivityOnGens + :: Show a + => (a -> a -> Bool) -> Gen (a, a, a) -> Property +transitivityOnGens func gen = + forAll gen $ \(a, b, c) -> transitiveOnElems func a b c + +-- | +-- +-- prop> transitivityOnValid ((>) :: Double -> Double -> Bool) +-- prop> transitivityOnValid ((>=) :: Double -> Double -> Bool) +-- prop> transitivityOnValid ((==) :: Double -> Double -> Bool) +-- prop> transitivityOnValid ((<=) :: Double -> Double -> Bool) +-- prop> transitivityOnValid ((<) :: Double -> Double -> Bool) +-- prop> transitivityOnValid (Data.List.isPrefixOf :: [Double] -> [Double] -> Bool) +-- prop> transitivityOnValid (Data.List.isSuffixOf :: [Double] -> [Double] -> Bool) +-- prop> transitivityOnValid (Data.List.isInfixOf :: [Double] -> [Double] -> Bool) +transitivityOnValid + :: (Show a, GenValid a) + => (a -> a -> Bool) -> Property +transitivityOnValid func = transitivityOnGens func genValid + +-- | +-- +-- prop> transitivity ((>) :: Int -> Int -> Bool) +-- prop> transitivity ((>=) :: Int -> Int -> Bool) +-- prop> transitivity ((==) :: Int -> Int -> Bool) +-- prop> transitivity ((<=) :: Int -> Int -> Bool) +-- prop> transitivity ((<) :: Int -> Int -> Bool) +-- prop> transitivity (Data.List.isPrefixOf :: [Int] -> [Int] -> Bool) +-- prop> transitivity (Data.List.isSuffixOf :: [Int] -> [Int] -> Bool) +-- prop> transitivity (Data.List.isInfixOf :: [Int] -> [Int] -> Bool) +transitivity + :: (Show a, GenUnchecked a) + => (a -> a -> Bool) -> Property +transitivity func = transitivityOnGens func genUnchecked + +-- | +-- +-- prop> transitivityOnArbitrary ((>) :: Int -> Int -> Bool) +-- prop> transitivityOnArbitrary ((>=) :: Int -> Int -> Bool) +-- prop> transitivityOnArbitrary ((==) :: Int -> Int -> Bool) +-- prop> transitivityOnArbitrary ((<=) :: Int -> Int -> Bool) +-- prop> transitivityOnArbitrary ((<) :: Int -> Int -> Bool) +-- prop> transitivityOnArbitrary (Data.List.isPrefixOf :: [Int] -> [Int] -> Bool) +-- prop> transitivityOnArbitrary (Data.List.isSuffixOf :: [Int] -> [Int] -> Bool) +-- prop> transitivityOnArbitrary (Data.List.isInfixOf :: [Int] -> [Int] -> Bool) +transitivityOnArbitrary + :: (Show a, Arbitrary a) + => (a -> a -> Bool) -> Property +transitivityOnArbitrary func = transitivityOnGens func arbitrary diff --git a/src/Test/Validity/Types.hs b/src/Test/Validity/Types.hs new file mode 100644 --- /dev/null +++ b/src/Test/Validity/Types.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Validity.Types + ( CanFail(..) + ) where + +-- | A class of types that are the result of functions that can fail +class CanFail f where + hasFailed :: f a -> Bool + resultIfSucceeded :: f a -> Maybe a + +instance CanFail Maybe where + hasFailed Nothing = True + hasFailed _ = False + resultIfSucceeded Nothing = Nothing + resultIfSucceeded (Just r) = Just r + +instance CanFail (Either e) where + hasFailed (Left _) = True + hasFailed _ = False + resultIfSucceeded (Left _) = Nothing + resultIfSucceeded (Right r) = Just r diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -0,0 +1,23 @@ +import Test.DocTest + +import Control.Monad + +import System.Directory +import System.FilePath + +main :: IO () +main = do + fs <- listFilesRecur "src" + doctest $ "-isrc" : fs + +listFilesRecur :: FilePath -> IO [FilePath] +listFilesRecur dir = do + entries <- + fmap + (map (dir ) . + filter (\f -> f /= "." && f /= ".." && takeExtension f /= ".swp")) $ + getDirectoryContents dir + dirs <- filterM doesDirectoryExist entries + files <- filterM doesFileExist entries + rests <- mapM listFilesRecur dirs + return $ concat $ files : rests