{-# LANGUAGE TemplateHaskell #-}
module Numeric.MixedTypes.Eq
(
HasEq, HasEqAsymmetric(..), (==), (/=)
, HasEqCertainly, HasEqCertainlyAsymmetric
, HasEqCertainlyCE, HasEqCertainlyCN
, notCertainlyDifferentFrom, certainlyEqualTo, certainlyNotEqualTo
, (?==?), (!==!), (!/=!)
, specHasEq, specHasEqNotMixed
, specConversion
, CanTestNaN(..)
, CanTestFinite(..)
, CanTestInteger(..)
, CanTestZero(..), specCanTestZero
, CanPickNonZero(..), specCanPickNonZero
)
where
import Utils.TH.DeclForTypes
import Numeric.MixedTypes.PreludeHiding
import qualified Prelude as P
import Text.Printf
import Data.Ratio
import Test.Hspec
import Test.QuickCheck as QC
import Numeric.CollectErrors
import Control.CollectErrors
import Numeric.MixedTypes.Literals
import Numeric.MixedTypes.Bool
infix 4 ==, /=
infix 4 ?==?
infix 4 !==!, !/=!
type HasEq t1 t2 =
(HasEqAsymmetric t1 t2, HasEqAsymmetric t2 t1,
EqCompareType t1 t2 ~ EqCompareType t2 t1)
type HasEqCertainlyAsymmetric t1 t2 =
(HasEqAsymmetric t1 t2, CanTestCertainly (EqCompareType t1 t2))
type HasEqCertainly t1 t2 =
(HasEq t1 t2, CanTestCertainly (EqCompareType t1 t2))
type HasEqCertainlyCE es t1 t2 =
(HasEqCertainly t1 t2,
HasEqCertainly (EnsureCE es t1) (EnsureCE es t2))
type HasEqCertainlyCN t1 t2 = HasEqCertainlyCE NumErrors t1 t2
class (IsBool (EqCompareType a b)) => HasEqAsymmetric a b where
type EqCompareType a b
type EqCompareType a b = Bool
equalTo :: a -> b -> (EqCompareType a b)
default equalTo :: (EqCompareType a b ~ Bool, a~b, P.Eq a) => a -> b -> EqCompareType a b
equalTo = (P.==)
notEqualTo :: a -> b -> (EqCompareType a b)
default notEqualTo ::
(CanNegSameType (EqCompareType a b)) =>
a -> b -> (EqCompareType a b)
notEqualTo a b = not $ equalTo a b
(==) :: (HasEqAsymmetric a b) => a -> b -> EqCompareType a b
(==) = equalTo
(/=) :: (HasEqAsymmetric a b) => a -> b -> EqCompareType a b
(/=) = notEqualTo
certainlyEqualTo :: (HasEqCertainlyAsymmetric a b) => a -> b -> Bool
certainlyEqualTo a b = isCertainlyTrue $ a == b
certainlyNotEqualTo :: (HasEqCertainlyAsymmetric a b) => a -> b -> Bool
certainlyNotEqualTo a b = isCertainlyTrue $ a /= b
notCertainlyDifferentFrom :: (HasEqCertainlyAsymmetric a b) => a -> b -> Bool
notCertainlyDifferentFrom a b = isNotFalse $ a == b
(?==?) :: (HasEqCertainlyAsymmetric a b) => a -> b -> Bool
(?==?) = notCertainlyDifferentFrom
(!==!) :: (HasEqCertainlyAsymmetric a b) => a -> b -> Bool
(!==!) = certainlyEqualTo
(!/=!) :: (HasEqCertainlyAsymmetric a b) => a -> b -> Bool
(!/=!) = certainlyNotEqualTo
specHasEq ::
(Show t1, Show t2, Show t3, Arbitrary t1, Arbitrary t2,
Arbitrary t3, CanTestCertainly (EqCompareType t1 t1),
CanTestCertainly (EqCompareType t1 t2),
CanTestCertainly (EqCompareType t2 t1),
CanTestCertainly (EqCompareType t2 t3),
CanTestCertainly
(AndOrType (EqCompareType t1 t2) (EqCompareType t2 t3)),
CanAndOrAsymmetric (EqCompareType t1 t2) (EqCompareType t2 t3),
HasEqAsymmetric t1 t1, HasEqAsymmetric t1 t2,
HasEqAsymmetric t2 t1, HasEqAsymmetric t2 t3)
=>
T t1 -> T t2 -> T t3 -> Spec
specHasEq (T typeName1 :: T t1) (T typeName2 :: T t2) (T typeName3 :: T t3) =
describe (printf "HasEq %s %s, HasEq %s %s" typeName1 typeName2 typeName2 typeName3) $ do
it "has reflexive ==" $ do
property $ \ (x :: t1) -> not $ isCertainlyFalse (x == x)
it "has anti-reflexive /=" $ do
property $ \ (x :: t1) -> not $ isCertainlyTrue (x /= x)
it "has stronly commutative ==" $ do
property $ \ (x :: t1) (y :: t2) -> (x == y) `stronglyEquivalentTo` (y == x)
it "has stronly commutative /=" $ do
property $ \ (x :: t1) (y :: t2) -> (x /= y) `stronglyEquivalentTo` (y /= x)
it "has stronly transitive ==" $ do
property $ \ (x :: t1) (y :: t2) (z :: t3) -> ((x == y) && (y == z)) `stronglyImplies` (y == z)
specHasEqNotMixed ::
(Show t, Arbitrary t, CanTestCertainly (EqCompareType t t),
CanTestCertainly
(AndOrType (EqCompareType t t) (EqCompareType t t)),
HasEqAsymmetric t t)
=>
T t -> Spec
specHasEqNotMixed (t :: T t) = specHasEq t t t
specConversion ::
(Arbitrary t1, Show t1, HasEqCertainly t1 t1) =>
T t1 -> T t2 -> (t1 -> t2) -> (t2 -> t1) -> Spec
specConversion (T typeName1 :: T t1) (T typeName2 :: T t2) conv12 conv21 =
describe "conversion" $ do
it (printf "%s -> %s -> %s" typeName1 typeName2 typeName1) $ do
property $ \ (x1 :: t1) ->
x1 ?==? (conv21 $ conv12 x1)
instance HasEqAsymmetric () ()
instance HasEqAsymmetric Bool Bool
instance HasEqAsymmetric Char Char
instance HasEqAsymmetric Int Int
instance HasEqAsymmetric Integer Integer
instance HasEqAsymmetric Rational Rational
instance HasEqAsymmetric Double Double
instance HasEqAsymmetric Int Integer where
equalTo = convertFirst equalTo
instance HasEqAsymmetric Integer Int where
equalTo = convertSecond equalTo
instance HasEqAsymmetric Int Rational where
equalTo = convertFirst equalTo
instance HasEqAsymmetric Rational Int where
equalTo = convertSecond equalTo
instance HasEqAsymmetric Integer Rational where
equalTo = convertFirst equalTo
instance HasEqAsymmetric Rational Integer where
equalTo = convertSecond equalTo
instance HasEqAsymmetric Integer Double where
equalTo n d = ((P.floor d :: Integer) == n) && (n == (P.ceiling d :: Integer))
instance HasEqAsymmetric Double Integer where
equalTo d n = ((P.floor d :: Integer) == n) && (n == (P.ceiling d :: Integer))
instance HasEqAsymmetric Int Double where
equalTo n d = equalTo (integer n) d
instance HasEqAsymmetric Double Int where
equalTo d n = equalTo (integer n) d
instance
(HasEqAsymmetric a1 b1,
HasEqAsymmetric a2 b2,
CanAndOrAsymmetric (EqCompareType a1 b1) (EqCompareType a2 b2),
IsBool (AndOrType (EqCompareType a1 b1) (EqCompareType a2 b2))
) =>
HasEqAsymmetric (a1,a2) (b1,b2) where
type EqCompareType (a1,a2) (b1,b2) =
AndOrType (EqCompareType a1 b1) (EqCompareType a2 b2)
equalTo (a1,a2) (b1,b2) =
(a1 == b1) && (a2 == b2)
instance
(HasEqAsymmetric ((a1,a2), a3) ((b1,b2), b3))
=>
HasEqAsymmetric (a1,a2,a3) (b1,b2,b3) where
type EqCompareType (a1,a2,a3) (b1,b2,b3) =
EqCompareType ((a1,a2), a3) ((b1,b2), b3)
equalTo (a1,a2,a3) (b1,b2,b3) =
((a1,a2), a3) == ((b1,b2), b3)
instance
(HasEqAsymmetric ((a1,a2,a3), a4) ((b1,b2,b3), b4))
=>
HasEqAsymmetric (a1,a2,a3,a4) (b1,b2,b3,b4) where
type EqCompareType (a1,a2,a3,a4) (b1,b2,b3,b4) =
EqCompareType ((a1,a2,a3), a4) ((b1,b2,b3), b4)
equalTo (a1,a2,a3,a4) (b1,b2,b3,b4) =
((a1,a2,a3), a4) == ((b1,b2,b3), b4)
instance
(HasEqAsymmetric ((a1,a2,a3,a4), a5) ((b1,b2,b3,b4), b5))
=>
HasEqAsymmetric (a1,a2,a3,a4,a5) (b1,b2,b3,b4,b5) where
type EqCompareType (a1,a2,a3,a4,a5) (b1,b2,b3,b4,b5) =
EqCompareType ((a1,a2,a3,a4), a5) ((b1,b2,b3,b4), b5)
equalTo (a1,a2,a3,a4,a5) (b1,b2,b3,b4,b5) =
((a1,a2,a3,a4), a5) == ((b1,b2,b3,b4), b5)
instance (HasEqAsymmetric a b) => HasEqAsymmetric [a] [b] where
type EqCompareType [a] [b] = EqCompareType a b
equalTo [] [] = convertExactly True
equalTo (x:xs) (y:ys) = (x == y) && (xs == ys)
equalTo _ _ = convertExactly False
instance (HasEqAsymmetric a b) => HasEqAsymmetric (Maybe a) (Maybe b) where
type EqCompareType (Maybe a) (Maybe b) = EqCompareType a b
equalTo Nothing Nothing = convertExactly True
equalTo (Just x) (Just y) = (x == y)
equalTo _ _ = convertExactly False
instance
(HasEqAsymmetric a b
, CanEnsureCE es (EqCompareType a b)
, CanEnsureCE es a, CanEnsureCE es b
, IsBool (EnsureCE es (EqCompareType a b))
, SuitableForCE es)
=>
HasEqAsymmetric (CollectErrors es a) (CollectErrors es b)
where
type EqCompareType (CollectErrors es a) (CollectErrors es b) =
EnsureCE es (EqCompareType a b)
equalTo = lift2CE equalTo
$(declForTypes
[[t| Bool |], [t| Maybe Bool |], [t| Integer |], [t| Int |], [t| Rational |], [t| Double |]]
(\ t -> [d|
instance
(HasEqAsymmetric $t b
, CanEnsureCE es b
, CanEnsureCE es (EqCompareType $t b)
, IsBool (EnsureCE es (EqCompareType $t b))
, SuitableForCE es)
=>
HasEqAsymmetric $t (CollectErrors es b)
where
type EqCompareType $t (CollectErrors es b) =
EnsureCE es (EqCompareType $t b)
equalTo = lift2TLCE equalTo
instance
(HasEqAsymmetric a $t
, CanEnsureCE es a
, CanEnsureCE es (EqCompareType a $t)
, IsBool (EnsureCE es (EqCompareType a $t))
, SuitableForCE es)
=>
HasEqAsymmetric (CollectErrors es a) $t
where
type EqCompareType (CollectErrors es a) $t =
EnsureCE es (EqCompareType a $t)
equalTo = lift2TCE equalTo
|]))
class CanTestNaN t where
isNaN :: t -> Bool
default isNaN :: (P.RealFloat t) => t -> Bool
isNaN = P.isNaN
class CanTestFinite t where
isInfinite :: t -> Bool
default isInfinite :: (P.RealFloat t) => t -> Bool
isInfinite = P.isInfinite
isFinite :: t -> Bool
default isFinite :: (P.RealFloat t) => t -> Bool
isFinite x = (not $ P.isNaN x) && (not $ P.isInfinite x)
instance CanTestNaN Double
instance CanTestFinite Double
instance CanTestNaN Integer where
isNaN = const False
instance CanTestNaN Rational where
isNaN = const False
instance CanTestFinite Integer where
isInfinite = const False
isFinite = const True
instance CanTestFinite Rational where
isInfinite = const False
isFinite = const True
instance (CanTestNaN t, SuitableForCE es) => (CanTestNaN (CollectErrors es t)) where
isNaN ce = getValueIfNoErrorCE ce isNaN (const False)
instance (CanTestFinite t, SuitableForCE es) => (CanTestFinite (CollectErrors es t)) where
isInfinite ce = getValueIfNoErrorCE ce isInfinite (const False)
isFinite ce = getValueIfNoErrorCE ce isFinite (const False)
class CanTestInteger t where
certainlyNotInteger :: t -> Bool
certainlyInteger :: t -> Bool
certainlyInteger s = case certainlyIntegerGetIt s of Just _ -> True; _ -> False
certainlyIntegerGetIt :: t -> Maybe Integer
instance CanTestInteger Integer where
certainlyNotInteger _ = False
certainlyInteger _ = True
certainlyIntegerGetIt n = Just n
instance CanTestInteger Int where
certainlyNotInteger _ = False
certainlyInteger _ = True
certainlyIntegerGetIt n = Just (integer n)
instance CanTestInteger Rational where
certainlyNotInteger q = (denominator q /= 1)
certainlyInteger q = (denominator q == 1)
certainlyIntegerGetIt q
| denominator q == 1 = Just (numerator q)
| otherwise = Nothing
instance CanTestInteger Double where
certainlyNotInteger d =
isInfinite d || isNaN d ||
(P.floor d :: Integer) P.< P.ceiling d
certainlyIntegerGetIt d
| isFinite d && (dF P.== dC) = Just dF
| otherwise = Nothing
where
dF = P.floor d
dC = P.ceiling d
instance (CanTestInteger t, SuitableForCE es) => (CanTestInteger (CollectErrors es t)) where
certainlyNotInteger ce = getValueIfNoErrorCE ce certainlyNotInteger (const False)
certainlyIntegerGetIt ce = getValueIfNoErrorCE ce certainlyIntegerGetIt (const Nothing)
class CanTestZero t where
isCertainlyZero :: t -> Bool
isCertainlyNonZero :: t -> Bool
default isCertainlyZero :: (HasEqCertainly t Integer) => t -> Bool
isCertainlyZero a = isCertainlyTrue (a == 0)
default isCertainlyNonZero :: (HasEqCertainly t Integer) => t -> Bool
isCertainlyNonZero a = isCertainlyTrue (a /= 0)
specCanTestZero ::
(CanTestZero t, ConvertibleExactly Integer t)
=>
T t -> Spec
specCanTestZero (T typeName :: T t) =
describe (printf "CanTestZero %s" typeName) $ do
it "converted non-zero Integer is not isCertainlyZero" $ do
property $ \ (x :: Integer) ->
x /= 0 ==> (not $ isCertainlyZero (convertExactly x :: t))
it "converted non-zero Integer is isCertainlyNonZero" $ do
property $ \ (x :: Integer) ->
x /= 0 ==> (isCertainlyNonZero (convertExactly x :: t))
it "converted 0.0 is not isCertainlyNonZero" $ do
(isCertainlyNonZero (convertExactly 0 :: t)) `shouldBe` False
instance CanTestZero Int
instance CanTestZero Integer
instance CanTestZero Rational
instance CanTestZero Double
instance (CanTestZero t, SuitableForCE es) => (CanTestZero (CollectErrors es t)) where
isCertainlyZero ce = getValueIfNoErrorCE ce isCertainlyZero (const False)
isCertainlyNonZero ce = getValueIfNoErrorCE ce isCertainlyNonZero (const False)
class CanPickNonZero t where
pickNonZero :: [(t,s)] -> Maybe (t,s)
default pickNonZero :: (CanTestZero t, Show t) => [(t,s)] -> Maybe (t,s)
pickNonZero list = aux list
where
aux ((a,b):rest)
| isCertainlyNonZero a = Just (a,b)
| otherwise = aux rest
aux [] = Nothing
specCanPickNonZero ::
(CanPickNonZero t, CanTestZero t, ConvertibleExactly Integer t, Show t, Arbitrary t)
=>
T t -> Spec
specCanPickNonZero (T typeName :: T t) =
describe (printf "CanPickNonZero %s" typeName) $ do
it "picks a non-zero element if there is one" $ do
property $ \ (xs :: [(t, ())]) ->
or (map (isCertainlyNonZero . fst) xs)
==>
(case pickNonZero xs of
Just (v, _) -> isCertainlyNonZero v
_ -> False)
it "returns Nothing when all the elements are 0" $ do
case pickNonZero [(convertExactly i :: t, ()) | i <- [0,0,0]] of
Nothing -> True
_ -> False
instance CanPickNonZero Int
instance CanPickNonZero Integer
instance CanPickNonZero Rational
instance (CanPickNonZero a, SuitableForCE es) => (CanPickNonZero (CollectErrors es a)) where
pickNonZero =
fmap (\(v,s) -> (pure v,s))
. pickNonZero
. filterValuesWithoutErrorCE
. (map (\(vCN,s) -> fmap (\v -> (v,s)) vCN))