{-# LANGUAGE FlexibleContexts #-} {- | The following class + helper functions implement law-agnostic testing functionality that is used to test laws for various classes. -} module Test.ClassLaws.TestingEquality where import Test.QuickCheck.Property import Test.ClassLaws.Core(Equal, Param) import Test.ClassLaws.Partial(Partial(Partial)) -- | A class for types which can be checked for 'Equal'ity, possibly -- needing some extra 'Param'eters. class TestEqual b where testEqual :: Equal b -> Param b -> Property -- | The first function, 'testRunEq', returns a property implementing -- an equality check. It takes a function that can `run' a value and a -- comparison operator to a predicate (which in turn takes some -- supposedly equal values, and a parameter needed for the run -- function, and returns a 'Property'). testRunEq :: Show r => (t -> p -> r) -> (r -> r -> Bool) -> (Equal t -> p -> Property) testRunEq run (==) steps p = testEq (==) (map (`run` p) steps) -- | The second function, 'testEq', does the same, but now for pairs -- that are not necessarily runnable. testEq :: Show a => (a -> a -> Bool) -> (Equal a -> Property) testEq (==) steps = whenFail (print $ failingPair (==) steps) $ property $ liftBool $ pairwiseEq (==) steps ---- -- | Variant of 'testRunEq' intended for 'Partial' values. (Only the -- Show part differs - the user also needs to supply an equality -- operator handling 'Partial' values.) testRunEqPartial :: Show (Partial r) => (t -> p -> r) -> (r -> r -> Bool) -> (Equal t -> p -> Property) testRunEqPartial run (==) steps p = testEqPartial (==) (map (`run` p) steps) -- | Similar variant of 'testEq' for 'Partial' values. testEqPartial :: Show (Partial a) => (a -> a -> Bool) -> Equal a -> Property testEqPartial (==) steps = whenFail (print $ Partial (failingPair (==) steps)) $ property $ liftBool (pairwiseEq (==) steps) ---- -- | Local helper pairwiseEq :: (r -> r -> Bool) -> [r] -> Bool pairwiseEq (==) [] = True pairwiseEq (==) [x] = True pairwiseEq (==) (x:y:ys) = x==y && pairwiseEq (==) (y:ys) -- | Position in an equality proof type Pos = Int -- | Local helper failingPair :: (a -> a -> Bool) -> Equal a -> (Pos, a, a) failingPair = failingPair' 1 -- | Local helper failingPair' pos (==) (x:y:ys) = if not (x==y) then (pos,x,y) else failingPair' (1+pos) (==) (y:ys) {- The following function generalises testEq and testRunEq testRunEq :: Show r => Maybe (p,r -> p -> r) -> (r -> r -> Bool) -> Equal r -> Property testRunEq startrun (==) steps = let run = case startrun of Nothing -> id Just (start,run) -> flip run start in whenFail (print (failingPair (==) (map run steps))) $ property $ liftBool (pairwiseEq (==) (map run steps)) -- An instance of testRunEq testEq :: Show a => (a -> a -> Bool) -> Equal a -> Property testEq = testRunEq Nothing -}