hedgehog-checkers (empty) → 0.1.0.0
raw patch · 8 files changed
+641/−0 lines, 8 filesdep +basedep +containersdep +eithersetup-changed
Dependencies added: base, containers, either, hedgehog, hedgehog-checkers, semigroupoids, semigroups
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- hedgehog-checkers.cabal +42/−0
- src/Hedgehog/Checkers.hs +7/−0
- src/Hedgehog/Checkers/Classes.hs +277/−0
- src/Hedgehog/Checkers/Properties.hs +103/−0
- src/Hedgehog/Checkers/Ugly/Function/Hack.hs +47/−0
- tests/tests.hs +133/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Author name here (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hedgehog-checkers.cabal view
@@ -0,0 +1,42 @@+name: hedgehog-checkers+version: 0.1.0.0+cabal-version: >=1.10+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: 2017, Chris Allen+maintainer: cma@bitemyapp.com+homepage: https://github.com/bitemyapp/hedgehog-checkers#readme+description:+ hedgehog-checkers wraps up the expected properties associated with various standard type classes as Hedgehog properties.+category: Web+author: Chris Allen++library+ exposed-modules:+ Hedgehog.Checkers+ Hedgehog.Checkers.Ugly.Function.Hack+ build-depends:+ base >=4.7 && <5,+ hedgehog ==0.5.*,+ containers >=0.4 && <0.6,+ semigroups >=0.9 && <1,+ semigroupoids ==5.*+ default-language: Haskell2010+ hs-source-dirs: src+ other-modules:+ Hedgehog.Checkers.Classes+ Hedgehog.Checkers.Properties+ Paths_hedgehog_checkers++test-suite tests+ type: exitcode-stdio-1.0+ main-is: tests.hs+ build-depends:+ base >=4.7 && <5,+ hedgehog ==0.5.*,+ hedgehog-checkers -any,+ either >=4.3.2 && <5+ default-language: Haskell2010+ hs-source-dirs: tests+ ghc-options: -threaded -Wall -rtsopts -with-rtsopts=-N
+ src/Hedgehog/Checkers.hs view
@@ -0,0 +1,7 @@+module Hedgehog.Checkers+ (+ module Export+ ) where++import Hedgehog.Checkers.Classes as Export+import Hedgehog.Checkers.Properties as Export
+ src/Hedgehog/Checkers/Classes.hs view
@@ -0,0 +1,277 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}++module Hedgehog.Checkers.Classes+ (+ -- | Classes+ ord+ , alt+ , alternative+ , alternativeAltAgreement+ , bifunctor+ , functor+ , semigroup+ , monoid+ , apply+ , applicative+ , applicativeApplyAgreement+ ) where++import Control.Applicative+import Data.Bifunctor+import Data.Functor.Alt+import Data.Semigroup++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Hedgehog.Checkers.Properties+import Hedgehog.Checkers.Ugly.Function.Hack++-- | Total ordering, genf (a -> Gen a) should+-- always return a value equal to or higher+-- than its input.+ord :: forall a. (Eq a, Ord a, Show a)+ => Gen a -> (a -> Gen a) -> PropertyT IO ()+ord gena genf = do+ reflexive rel gena+ transitive rel gena genf+ antiSymmetric rel gena genf+ where+ rel = (<=)++-- | <!> is associative: (a <!> b) <!> c = a <!> (b <!> c)+-- <$> left-distributes over <!>: f <$> (a <!> b) = (f <$> a) <!> (f <$> b)+alt :: ( Alt f+ , Eq (f a)+ , Show (f a)+ )+ => Gen (f a) -> PropertyT IO ()+alt gen = do+ associativity (<!>) gen+-- f <$> (a <!> b) = (f <$> a) <!> (f <$> b)++-- | Alternative instances should respect identity+-- (left and right) and associativity for (<|>)+-- empty <|> x = x+-- x <|> empty = x+--+-- a <|> (b <|> c) = (a <|> b) <|> c+alternative :: ( Alternative f+ , Eq (f a)+ , Show (f a)+ )+ => Gen (f a) -> PropertyT IO ()+alternative gen = do+ identity (<|>) empty gen+ associativity (<|>) gen++alternativeAltAgreement :: ( Alt f+ , Alternative f+ , Eq (f a)+ , Show (f a)+ )+ => Gen (f a) -> PropertyT IO ()+alternativeAltAgreement gen = do+ fa <- forAll gen+ fb <- forAll gen+ (fa <!> fb) === (fa <|> fb)++-- fmap (f . g) == fmap f . fmap g+-- ??? inferrable from: fmap id = id+functor :: ( Functor f+ , Eq (f a)+ , Show (f a)+ )+ => Gen (f a) -> PropertyT IO ()+functor gen = do+ functorIdentity+ where functorIdentity = do+ fa <- forAll gen+ fmap id fa === id fa++-- bimap id id ≡ id+-- first id ≡ id+-- second id ≡ id+-- bimap f g ≡ first f . second g+bifunctor :: -- forall f a b .+ ( Bifunctor f+ , Eq (f a b)+ , Eq (f c c)+ , Ord a+ , Ord b+ , Show (f a b)+ , Show (f c c)+ )+ => Gen (f a b)+ -> Gen a+ -> Gen b+ -> Gen c+ -> PropertyT IO ()+bifunctor gen gena genb genc = do+ bimapIdentity+ firstIdentity+ secondIdentity+ bimapFirstSecondDistribute+ where bimapIdentity = do+ fab <- forAll gen+ bimap id id fab === id fab+ firstIdentity = do+ fab <- forAll gen+ first id fab === id fab+ secondIdentity = do+ fab <- forAll gen+ second id fab === id fab+ bimapFirstSecondDistribute = do+ fab <- forAll gen+ f <- ordFuncWtf gena genc+ g <- ordFuncWtf genb genc+ bimap f g fab === (first f . second g) fab++semigroup :: ( Semigroup a+ , Eq a+ , Show a+ )+ => Gen a+ -> PropertyT IO ()+semigroup gen = do+ associativity (<>) gen++monoid :: ( Monoid a+ , Semigroup a+ , Eq a+ , Show a+ )+ => Gen a+ -> PropertyT IO ()+monoid gen = do+ semigroup gen+ identity mappend mempty gen+ associativity mappend gen+ monoidSemigroupSame+ where monoidSemigroupSame = do+ a <- forAll gen+ b <- forAll gen+ mappend a b === a <> b++apply :: forall f a b c+ . ( Apply f+ , Eq (f a)+ , Eq (f b)+ , Eq (f c)+ , Ord a+ , Ord b+ , Show a+ , Show b+ , Show c+ , Show (f a)+ , Show (f b)+ , Show (f c)+ )+ => Gen (f a)+ -> Gen a+ -> Gen b+ -> Gen c+ -> PropertyT IO ()+apply gen gena genb genc = do+ applyComposition+ applyRight+ applyLeft+ where applyComposition = do+ fa <- forAll gen+ fbc <- liftedFunctionWtf gen genb genc+ fab <- liftedFunctionWtf gen gena genb+ ((.) <$> fbc <.> fab <.> fa) === (fbc <.> (fab <.> fa))+ applyRight = do+ fa <- forAll gen+ fbc <- liftedFunctionWtf gen genb genc+ ab <- ordFuncWtf gena genb+ (fbc <.> (ab <$> fa)) === ((. ab) <$> fbc <.> fa)+ applyLeft = do+ fa <- forAll gen+ fab <- liftedFunctionWtf gen gena genb+ bc <- ordFuncWtf genb genc+ (bc <$> (fab <.> fa)) === ((bc .) <$> fab <.> fa)++applicative :: forall f a b c+ . ( Applicative f+ , Eq (f a)+ , Eq (f b)+ , Eq (f c)+ , Ord a+ , Ord b+ , Show a+ , Show (f a)+ , Show (f b)+ , Show (f c)+ )+ => Gen (f a)+ -> Gen a+ -> Gen b+ -> Gen c+ -> PropertyT IO ()+applicative gen gena genb genc = do+ applicativeIdentity+ applicativeComposition+ applicativeHomomorphism+ applicativeInterchange+ applicativeFunctor+ where applicativeIdentity = do+ fa <- forAll gen+ (pure id <*> fa) === fa++ applicativeComposition = do+ fa <- forAll gen+ fbc <- liftedFunctionWtf gen genb genc+ fab <- liftedFunctionWtf gen gena genb+ (pure (.) <*> fbc <*> fab <*> fa) === (fbc <*> (fab <*> fa))++ applicativeHomomorphism = do+ a <- forAll gena+ f <- ordFuncWtf gena genb+ let p :: x -> f x+ p = pure+ (p f <*> p a) === p (f a)++ applicativeInterchange = do+ a <- forAll gena+ fab <- liftedFunctionWtf gen gena genb+ (fab <*> pure a) === (pure ($ a) <*> fab)++ applicativeFunctor = do+ fa <- forAll gen+ f <- ordFuncWtf gena genb+ fmap f fa === (pure f <*> fa)++applicativeApplyAgreement :: ( Monad m+ , Apply f+ , Applicative f+ , Show b+ , Show (f a)+ , Show (f b)+ , Eq (f b)+ , Ord a+ )+ => Gen (f a) -> Gen a -> Gen b -> PropertyT m ()+applicativeApplyAgreement gen gena genb = do+ fa <- forAll gen+ fab <- liftedFunctionWtf gen gena genb+ (fab <.> fa) === (fab <*> fa)++---- Done+-- (Semigroup e, Monoid e) => Alternative (Validation e) +-- Alt (Validation e) +-- Functor (Validation e)+-- Bifunctor Validation+-- Semigroup e => Semigroup (Validation e a) +-- Monoid e => Monoid (Validation e a)Source+-- Semigroup e => Applicative (Validation e) +-- (Ord a, Ord e) => Ord (Validation e a)++---- To be done+-- Traversable (Validation e)+-- Bitraversable Validation ++-- (Eq a, Eq e) => Eq (Validation e a) +-- (Show a, Show e) => Show (Validation e a)
+ src/Hedgehog/Checkers/Properties.hs view
@@ -0,0 +1,103 @@++{-# LANGUAGE ScopedTypeVariables #-}++module Hedgehog.Checkers.Properties+ (+ -- | Laws+ identity+ , leftIdentity+ , rightIdentity+ , associativity+ , commutativity+ , reflexive+ , transitive+ , symmetric+ , antiSymmetric+ ) where++import Hedgehog++leftIdentity :: (Eq a, Show a)+ => (a -> a -> a)+ -> a+ -> Gen a+ -> PropertyT IO ()+leftIdentity f i gen = do+ x <- forAll gen+ f i x === x++rightIdentity :: (Eq a, Show a)+ => (a -> a -> a)+ -> a+ -> Gen a+ -> PropertyT IO ()+rightIdentity f i gen = do+ x <- forAll gen+ f x i === x++identity :: (Eq a, Show a)+ => (a -> a -> a)+ -> a+ -> Gen a+ -> PropertyT IO ()+identity f i gen = do+ leftIdentity f i gen+ rightIdentity f i gen++associativity :: (Eq a, Show a)+ => (a -> a -> a)+ -> Gen a+ -> PropertyT IO ()+associativity f gen = do+ x <- forAll gen+ y <- forAll gen+ z <- forAll gen+ f x (f y z) === f (f x y) z++commutativity :: (Eq b, Show a, Show b)+ => (a -> a -> b)+ -> Gen a+ -> PropertyT IO ()+commutativity f gena = do+ a <- forAll gena+ a' <- forAll gena+ f a a' === f a' a++reflexive :: (Show a)+ => (a -> a -> Bool)+ -> Gen a+ -> PropertyT IO ()+reflexive rel gena = do+ a <- forAll gena+ assert $ rel a a++transitive :: (Show a)+ => (a -> a -> Bool)+ -> Gen a+ -> (a -> Gen a)+ -> PropertyT IO ()+transitive rel gena genf = do+ a <- forAll gena+ b <- forAll (genf a)+ c <- forAll (genf b)+ ((rel a b) && (rel b c)) === (rel a c)++symmetric :: (Show a)+ => (a -> a -> Bool)+ -> Gen a+ -> (a -> Gen a)+ -> PropertyT IO ()+symmetric rel gena genf = do+ a <- forAll gena+ b <- forAll (genf a)+ (rel a b) === (rel b a)++antiSymmetric :: (Eq a, Show a)+ => (a -> a -> Bool)+ -> Gen a+ -> (a -> Gen a)+ -> PropertyT IO ()+antiSymmetric rel gena genf = do+ a <- forAll gena+ b <- forAll (genf a)+ ((rel a b) && (rel b a)) === (a == b)
+ src/Hedgehog/Checkers/Ugly/Function/Hack.hs view
@@ -0,0 +1,47 @@+module Hedgehog.Checkers.Ugly.Function.Hack where++import Data.Map (Map)+import qualified Data.Map as Map++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++---------- vvvvv CANCER PLEASE IGNORE vvvvv -----------------------------++fromMap :: Ord k => v -> Map k v -> k -> v+fromMap defaultValue kvs k =+ case Map.lookup k kvs of+ Nothing ->+ defaultValue+ Just value ->+ value++ordFuncWtf'' :: Ord a => Range Int -> Gen a -> Gen b -> Gen (a -> b)+ordFuncWtf'' range gen gen' = do+ defaultV <- gen'+ let tupGen = (,) <$> gen <*> gen'+ map <- Gen.map range tupGen+ return $ fromMap defaultV map++ordFuncWtf' :: Ord a => Gen a -> Gen b -> Gen (a -> b)+ordFuncWtf' = ordFuncWtf'' (Range.linear 0 1000)++funcForAllWtf :: Monad m => Gen a -> PropertyT m a+funcForAllWtf g = do+ let funcShow _ = "<func>"+ forAllWith funcShow $ g++ordFuncWtf :: (Ord a, Monad m) => Gen a -> Gen b -> PropertyT m (a -> b)+ordFuncWtf gena genb = do+ -- let funcShow _ = "<func>"+ -- forAllWith funcShow $ ordFuncWtf' gena genb+ funcForAllWtf $ ordFuncWtf' gena genb++liftedFunctionWtf :: (Functor f, Show (f z), Ord a, Monad m)+ => Gen (f z) -> Gen a -> Gen b -> PropertyT m (f (a -> b))+liftedFunctionWtf gen gena genb = do+ fab' <- ordFuncWtf gena genb+ fmap (const fab') <$> forAll gen++---------- ^^^^^ CANCER PLEASE IGNORE ^^^^^ -----------------------------
+ tests/tests.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Applicative+import Control.Monad+import Data.Either.Validation+import Data.Functor (void)+import Data.Monoid (Sum(..))+import System.Exit (exitFailure)++import Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range++import Hedgehog.Checkers++genValidation :: Gen a -> Gen b -> Gen (Validation a b)+genValidation ga gb = do+ a <- ga+ b <- gb+ Gen.choice [return $ Failure a, return $ Success b]++validationAlternative :: Property+validationAlternative = property $ do+ let genSumInt = Sum <$> Gen.int (Range.linear 0 maxBound)+ genVal = genValidation genSumInt genSumInt+ alternative genVal++genInt :: Gen Int+genInt = Gen.int (Range.linear 0 maxBound)++genSum :: Gen (Sum Int)+genSum = Sum <$> genInt++genEither' :: Gen a -> Gen b -> Gen (Either a b)+genEither' ga gb = do+ a <- ga+ b <- gb+ Gen.choice [return $ Left a, return $ Right b]++genEither :: Gen (Either Int Int)+genEither = genEither' genInt genInt++eitherAlt :: Property+eitherAlt = property $ do+ alt genEither++eitherBifunctor :: Property+eitherBifunctor = property $ do+ bifunctor genEither genInt genInt genInt++eitherFunctor :: Property+eitherFunctor = property $ do+ functor genEither++eitherApply :: Property+eitherApply = property $ do+ apply genEither genInt genInt genInt++eitherApplicative :: Property+eitherApplicative = property $ do+ applicative genEither genInt genInt genInt++eitherSemigroup :: Property+eitherSemigroup = property $ do+ semigroup genEither++genMaybe' :: Gen a -> Gen (Maybe a)+genMaybe' ga =+ -- I need to bias this to Just+ Gen.choice [return Nothing, Just <$> ga]++genMaybe :: Gen (Maybe (Sum Int))+genMaybe = genMaybe' genSum++maybeMonoid :: Property+maybeMonoid = property $ do+ monoid genMaybe++maybeAlt :: Property+maybeAlt = property $ alt genMaybe++maybeAlternative :: Property+maybeAlternative = property $ alternative genMaybe++maybeAlternativeAlt :: Property+maybeAlternativeAlt = property $ alternativeAltAgreement genMaybe++maybeApply :: Property+maybeApply = property $+ apply genMaybe genSum genSum genSum++maybeApplicative :: Property+maybeApplicative = property $+ applicative genMaybe genSum genSum genSum++maybeApplicativeApply :: Property+maybeApplicativeApply = property $+ applicativeApplyAgreement genMaybe genSum genSum++intOrd :: Property+intOrd = property $+ ord genInt varyGenInt+ where varyGenInt i =+ Gen.int (Range.linear i maxBound)++main :: IO ()+main = do+ e <-+ checkParallel $+ Group "Data.Either" [ ("Alt", eitherAlt)+ , ("Bifunctor", eitherBifunctor)+ , ("Functor", eitherFunctor)+ , ("Semigroup", eitherSemigroup)+ , ("Apply", eitherApply)+ , ("Applicative", eitherApplicative)+ ]+ m <-+ checkParallel $+ Group "Data.Maybe" [ ("Monoid", maybeMonoid)+ , ("Alt", maybeAlt)+ , ("Alternative", maybeAlternative)+ , ("AlternativeAlt", maybeAlternativeAlt)+ , ("Apply", maybeApply)+ , ("Applicative", maybeApplicative)+ , ("ApplicativeApply", maybeApplicativeApply)+ ]+ o <-+ checkParallel $+ Group "Ord" [ ("Int", intOrd)+ ]+ unless (and [e,m,o]) exitFailure