hedgehog-classes 0.2.0.1 → 0.2.1
raw patch · 7 files changed
+122/−23 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +6/−0
- hedgehog-classes.cabal +1/−1
- src/Hedgehog/Classes/Common/Compat.hs +1/−1
- src/Hedgehog/Classes/Common/Laws.hs +8/−0
- src/Hedgehog/Classes/Common/Property.hs +44/−3
- src/Hedgehog/Classes/Ord.hs +13/−17
- test/Spec/Ord.hs +49/−1
CHANGELOG.md view
@@ -3,6 +3,12 @@ `hedgehog-classes` uses [PVP Versioning][1]. The changelog is available [on GitHub][2]. +0.2.1+=====+* fix problem where ordLaws failed for everything. there was+ some messed up logic used to check that transitivity held.+ Thanks @ocharles for reporting this.+ 0.2.0.1 ======= * improve reliability of hedgehog output filtering.
hedgehog-classes.cabal view
@@ -2,7 +2,7 @@ name: hedgehog-classes version:- 0.2.0.1+ 0.2.1 synopsis: Hedgehog will eat your typeclass bugs description:
src/Hedgehog/Classes/Common/Compat.hs view
@@ -2,7 +2,7 @@ module Hedgehog.Classes.Common.Compat ( readMaybe- , eq + , eq , eq1 , eq2
src/Hedgehog/Classes/Common/Laws.hs view
@@ -15,8 +15,10 @@ , reduced , lawWhere , congruency+ , implies , congruent+ , implication , newline , tab , tab2@@ -40,8 +42,14 @@ congruent :: String congruent = " ≡ " +implication :: String+implication = " ==> "+ congruency :: String -> String -> String congruency x y = x ++ congruent ++ y++implies :: String -> String -> String+implies x y = x ++ implication ++ y newline, tab, tab2 :: String newline = "\n"
src/Hedgehog/Classes/Common/Property.hs view
@@ -10,11 +10,13 @@ -- that don't contain CallStack information, since this would -- expose library internals in error messages. module Hedgehog.Classes.Common.Property- ( hLessThan, hGreaterThan- , heq, heq1, heq2+ ( heq, heq1, heq2 , heqCtx, heqCtx1, heqCtx2 , hneq, hneq1, hneq2 , hneqCtx, hneqCtx1, hneqCtx2+ , himplCtx+ , hLessThan, hGreaterThan+ , hLessThanCtx, hGreaterThanCtx , bar , Context(..) ) where@@ -24,7 +26,7 @@ import GHC.Stack import Hedgehog.Classes.Common.Compat import Hedgehog.Internal.Exception (tryEvaluate)-import Hedgehog.Internal.Property (MonadTest, liftTest, mkTest, success, Failure(..))+import Hedgehog.Internal.Property (MonadTest, liftTest, mkTest, success, discard, Failure(..), PropertyT) import Text.Show.Pretty (ppShow) import qualified Data.Char as Char import qualified Data.List as List@@ -63,6 +65,34 @@ failContext ctx = withFrozenCallStack $ failWithNoSrc $ contextToString ctx +-- | Fails the test with the given context if the right argument is+-- less than or equal to the left.+hLessThanCtx ::+ ( MonadTest m+ , Ord a+ , Show a+ , HasCallStack+ ) => a -> a -> Context -> m ()+hLessThanCtx x y ctx = do+ ok <- withFrozenCallStack $ evalNoSrc (x < y)+ if ok+ then success+ else withFrozenCallStack $ failContext ctx++-- | Fails the test with the given context if the right argument is+-- greater than or equal to the left.+hGreaterThanCtx ::+ ( MonadTest m+ , Ord a+ , Show a+ , HasCallStack+ ) => a -> a -> Context -> m ()+hGreaterThanCtx x y ctx = do+ ok <- withFrozenCallStack $ evalNoSrc (x > y)+ if ok+ then success+ else withFrozenCallStack $ failContext ctx+ -- | Fails the test if the right argument is less than or equal to the left. -- see https://github.com/hedgehogqa/haskell-hedgehog/pull/196 hLessThan :: (MonadTest m, Ord a, Show a, HasCallStack) => a -> a -> m ()@@ -264,3 +294,14 @@ , forall x y. (Show x, Show y) => Show (f x y) ) => f a b -> f a b -> m () hneq2 x y = hneqCtx2 x y NoContext++-- | Passes the test if the LHS implies the RHS. Otherwise fails with+-- the given 'Context'.+himplCtx ::+ ( Monad m+ , HasCallStack+ ) => Bool -> Bool -> Context -> PropertyT m ()+himplCtx False _ _ = discard+himplCtx True b ctx = if b+ then success+ else withFrozenCallStack $ failContext ctx
src/Hedgehog/Classes/Ord.hs view
@@ -16,7 +16,7 @@ [ ("Antisymmetry", ordAntisymmetric gen) , ("Transitivity", ordTransitive gen) , ("Reflexivity", ordReflexive gen)- , ("Totality", ordTotal gen) + , ("Totality", ordTotal gen) ] ordAntisymmetric :: forall a. (Ord a, Show a) => Gen a -> Property@@ -33,10 +33,10 @@ let showA = show a; showB = show b; in lawWhere [ "x <= y && y <= x" `congruency` "x == y, where"- , "x = " ++ showA + , "x = " ++ showA , "y = " ++ showB ]- } + } heqCtx lhs rhs ctx ordTransitive :: forall a. (Ord a, Show a) => Gen a -> Property@@ -48,31 +48,27 @@ let rhs = x <= z let ctx = contextualise $ LawContext { lawContextLawName = "Transitivity", lawContextTcName = "Ord"- , lawContextLawBody = "x <= y && y <= z" `congruency` "x <= z"+ , lawContextLawBody = "x <= y && y <= z" `implies` "x <= z" , lawContextReduced = reduced lhs rhs , lawContextTcProp = let showX = show x; showY = show y; showZ = show z; in lawWhere- [ "x <= y && y <= z" `congruency` "x <= z, where"+ [ "x <= y && y <= z" `implies` "x <= z, where" , "x = " ++ showX , "y = " ++ showY , "z = " ++ showZ ] }- heqCtx lhs rhs ctx--{-- case (compare a b, compare b c) of- (LT,LT) -> a `hLessThan` c- (LT,EQ) -> a `hLessThan` c+ case (compare x y, compare y z) of+ (LT,LT) -> hLessThanCtx x z ctx+ (LT,EQ) -> hLessThanCtx x z ctx (LT,GT) -> success- (EQ,LT) -> a `hLessThan` c- (EQ,EQ) -> a === c- (EQ,GT) -> a `hGreaterThan` c+ (EQ,LT) -> hLessThanCtx x z ctx+ (EQ,EQ) -> heqCtx x z ctx+ (EQ,GT) -> hGreaterThanCtx x z ctx (GT,LT) -> success- (GT,EQ) -> a `hGreaterThan` c- (GT,GT) -> a `hGreaterThan` c--}+ (GT,EQ) -> hGreaterThanCtx x z ctx+ (GT,GT) -> hGreaterThanCtx x z ctx ordTotal :: forall a. (Ord a, Show a) => Gen a -> Property ordTotal gen = property $ do
test/Spec/Ord.hs view
@@ -1,7 +1,55 @@+{-# language TypeApplications #-}+ module Spec.Ord (testOrd) where import Hedgehog.Classes+import Hedgehog (Gen)+import GHC.Natural +import qualified Hedgehog.Range as Range+import qualified Hedgehog.Gen as Gen+ testOrd :: [(String, [Laws])]-testOrd = []+testOrd =+ [ ("Int", listInt)+ , ("Int8", listInt8)+ , ("Int16", listInt16)+ , ("Int32", listInt32)+ , ("Int64", listInt64)+ , ("Word", listWord)+ , ("Word8", listWord8)+ , ("Word16", listWord16)+ , ("Word32", listWord32)+ , ("Word64", listWord64)+ , ("Natural", listNatural)+ , ("Pair", listPair)+ ] +ranged :: (Integral a) => (Range.Range a -> b) -> b+ranged f = f (Range.linear 0 100)++listInt, listInt8, listInt16, listInt32, listInt64 :: [Laws]+listInt = [ordLaws (ranged Gen.int)]+listInt8 = [ordLaws (ranged Gen.int8)]+listInt16 = [ordLaws (ranged Gen.int16)]+listInt32 = [ordLaws (ranged Gen.int32)]+listInt64 = [ordLaws (ranged Gen.int64)]++listWord, listWord8, listWord16, listWord32, listWord64 :: [Laws]+listWord = [ordLaws (ranged Gen.word)]+listWord8 = [ordLaws (ranged Gen.word8)]+listWord16 = [ordLaws (ranged Gen.word16)]+listWord32 = [ordLaws (ranged Gen.word32)]+listWord64 = [ordLaws (ranged Gen.word64)]++listNatural :: [Laws]+listNatural = [ordLaws (ranged @Natural Gen.integral)]++listPair :: [Laws]+listPair = [ordLaws (genPair (ranged Gen.int) (ranged Gen.int8))]++data Pair a b = Pair a b+ deriving (Eq, Ord, Show)++genPair :: Gen a -> Gen b -> Gen (Pair a b)+genPair genA genB = Pair <$> genA <*> genB