{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
    Module      :  Numeric.MixedType.Eq
    Description :  Bottom-up typed equality comparisons
    Copyright   :  (c) Michal Konecny
    License     :  BSD3

    Maintainer  :  mikkonecny@gmail.com
    Stability   :  experimental
    Portability :  portable
-}

module Numeric.MixedTypes.Eq
(
  -- * Equality checks
  HasEq,  HasEqAsymmetric(..), (==), (/=)
  , HasEqCertainly, HasEqCertainlyAsymmetric
  , notCertainlyDifferentFrom, certainlyEqualTo, certainlyNotEqualTo
  , (?==?), (!==!), (!/=!)
  -- ** Tests
  , specHasEq, specHasEqNotMixed
  , specConversion
  -- ** Specific comparisons
  , CanTestValid(..), specResultIsValid1, specResultIsValid2, specResultIsValid1Pre, specResultIsValid2Pre
  , 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 Control.CollectErrors ( CollectErrors, CanBeErrors )
import qualified Control.CollectErrors as CE

import Numeric.MixedTypes.Literals
import Numeric.MixedTypes.Bool

infix  4  ==, /=
infix 4 ?==?
infix 4 !==!, !/=!

{---- Equality tests -----}

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))

class (IsBool (EqCompareType a b)) => HasEqAsymmetric a b where
    type EqCompareType a b
    type EqCompareType a b = Bool -- default
    equalTo :: a -> b -> (EqCompareType a b)
    -- default equalToA via Prelude for (->) and Bool:
    default equalTo :: (EqCompareType a b ~ Bool, a~b, P.Eq a) => a -> b -> EqCompareType a b
    equalTo = a -> b -> EqCompareType a b
forall a. Eq a => a -> a -> Bool
(P.==)
    notEqualTo :: a -> b -> (EqCompareType a b)
    -- default notEqualToA via equalToA for Bool:
    default notEqualTo ::
        (CanNegSameType (EqCompareType a b)) =>
        a -> b -> (EqCompareType a b)
    notEqualTo a
a b
b = EqCompareType a b -> NegType (EqCompareType a b)
forall t. CanNeg t => t -> NegType t
not (EqCompareType a b -> NegType (EqCompareType a b))
-> EqCompareType a b -> NegType (EqCompareType a b)
forall a b. (a -> b) -> a -> b
$ a -> b -> EqCompareType a b
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
equalTo a
a b
b

(==) :: (HasEqAsymmetric a b) => a -> b -> EqCompareType a b
== :: a -> b -> EqCompareType a b
(==) = a -> b -> EqCompareType a b
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
equalTo
(/=) :: (HasEqAsymmetric a b) => a -> b -> EqCompareType a b
/= :: a -> b -> EqCompareType a b
(/=) = a -> b -> EqCompareType a b
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
notEqualTo

certainlyEqualTo :: (HasEqCertainlyAsymmetric a b) => a -> b -> Bool
certainlyEqualTo :: a -> b -> Bool
certainlyEqualTo a
a b
b = EqCompareType a b -> Bool
forall t. CanTestCertainly t => t -> Bool
isCertainlyTrue (EqCompareType a b -> Bool) -> EqCompareType a b -> Bool
forall a b. (a -> b) -> a -> b
$ a
a a -> b -> EqCompareType a b
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== b
b
certainlyNotEqualTo :: (HasEqCertainlyAsymmetric a b) => a -> b -> Bool
certainlyNotEqualTo :: a -> b -> Bool
certainlyNotEqualTo a
a b
b = EqCompareType a b -> Bool
forall t. CanTestCertainly t => t -> Bool
isCertainlyTrue (EqCompareType a b -> Bool) -> EqCompareType a b -> Bool
forall a b. (a -> b) -> a -> b
$ a
a a -> b -> EqCompareType a b
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
/= b
b
notCertainlyDifferentFrom :: (HasEqCertainlyAsymmetric a b) => a -> b -> Bool
notCertainlyDifferentFrom :: a -> b -> Bool
notCertainlyDifferentFrom a
a b
b = EqCompareType a b -> Bool
forall t. CanTestCertainly t => t -> Bool
isNotFalse (EqCompareType a b -> Bool) -> EqCompareType a b -> Bool
forall a b. (a -> b) -> a -> b
$ a
a a -> b -> EqCompareType a b
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== b
b

(?==?) :: (HasEqCertainlyAsymmetric a b) => a -> b -> Bool
?==? :: a -> b -> Bool
(?==?) = a -> b -> Bool
forall a b. HasEqCertainlyAsymmetric a b => a -> b -> Bool
notCertainlyDifferentFrom

(!==!) :: (HasEqCertainlyAsymmetric a b) => a -> b -> Bool
!==! :: a -> b -> Bool
(!==!) = a -> b -> Bool
forall a b. HasEqCertainlyAsymmetric a b => a -> b -> Bool
certainlyEqualTo

(!/=!) :: (HasEqCertainlyAsymmetric a b) => a -> b -> Bool
!/=! :: a -> b -> Bool
(!/=!) = a -> b -> Bool
forall a b. HasEqCertainlyAsymmetric a b => a -> b -> Bool
certainlyNotEqualTo

{-|
  HSpec properties that each implementation of HasEq should satisfy.
 -}
specHasEq :: 
  _ => T t1 -> T t2 -> T t3 -> Spec
specHasEq :: T t1 -> T t2 -> T t3 -> Spec
specHasEq (T String
typeName1 :: T t1) (T String
typeName2 :: T t2) (T String
typeName3 :: T t3) =
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (String -> String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"HasEq %s %s, HasEq %s %s" String
typeName1 String
typeName2 String
typeName2 String
typeName3) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"has reflexive ==" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$ do
      (t1 -> Bool) -> Property
forall prop. Testable prop => prop -> Property
property ((t1 -> Bool) -> Property) -> (t1 -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \ (t1
x :: t1) -> Bool -> NegType Bool
forall t. CanNeg t => t -> NegType t
not (Bool -> NegType Bool) -> Bool -> NegType Bool
forall a b. (a -> b) -> a -> b
$ EqCompareType t1 t1 -> Bool
forall t. CanTestCertainly t => t -> Bool
isCertainlyFalse (t1
x t1 -> t1 -> EqCompareType t1 t1
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== t1
x)
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"has anti-reflexive /=" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$ do
      (t1 -> Bool) -> Property
forall prop. Testable prop => prop -> Property
property ((t1 -> Bool) -> Property) -> (t1 -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \ (t1
x :: t1) -> Bool -> NegType Bool
forall t. CanNeg t => t -> NegType t
not (Bool -> NegType Bool) -> Bool -> NegType Bool
forall a b. (a -> b) -> a -> b
$ EqCompareType t1 t1 -> Bool
forall t. CanTestCertainly t => t -> Bool
isCertainlyTrue (t1
x t1 -> t1 -> EqCompareType t1 t1
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
/= t1
x)
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"has stronly commutative ==" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$ do
      (t1 -> t2 -> Bool) -> Property
forall prop. Testable prop => prop -> Property
property ((t1 -> t2 -> Bool) -> Property) -> (t1 -> t2 -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \ (t1
x :: t1) (t2
y :: t2) -> (t1
x t1 -> t2 -> EqCompareType t1 t2
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== t2
y) EqCompareType t1 t2 -> EqCompareType t2 t1 -> Bool
forall t1 t2.
(CanTestCertainly t1, CanTestCertainly t2) =>
t1 -> t2 -> Bool
`stronglyEquivalentTo` (t2
y t2 -> t1 -> EqCompareType t2 t1
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== t1
x)
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"has stronly commutative /=" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$ do
      (t1 -> t2 -> Bool) -> Property
forall prop. Testable prop => prop -> Property
property ((t1 -> t2 -> Bool) -> Property) -> (t1 -> t2 -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \ (t1
x :: t1) (t2
y :: t2) -> (t1
x t1 -> t2 -> EqCompareType t1 t2
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
/= t2
y) EqCompareType t1 t2 -> EqCompareType t2 t1 -> Bool
forall t1 t2.
(CanTestCertainly t1, CanTestCertainly t2) =>
t1 -> t2 -> Bool
`stronglyEquivalentTo` (t2
y t2 -> t1 -> EqCompareType t2 t1
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
/= t1
x)
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"has stronly transitive ==" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$ do
      (t1 -> t2 -> t3 -> Bool) -> Property
forall prop. Testable prop => prop -> Property
property ((t1 -> t2 -> t3 -> Bool) -> Property)
-> (t1 -> t2 -> t3 -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \ (t1
x :: t1) (t2
y :: t2) (t3
z :: t3) -> ((t1
x t1 -> t2 -> EqCompareType t1 t2
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== t2
y) EqCompareType t1 t2
-> EqCompareType t2 t3
-> AndOrType (EqCompareType t1 t2) (EqCompareType t2 t3)
forall a b. CanAndOrAsymmetric a b => a -> b -> AndOrType a b
&& (t2
y t2 -> t3 -> EqCompareType t2 t3
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== t3
z)) AndOrType (EqCompareType t1 t2) (EqCompareType t2 t3)
-> EqCompareType t2 t3 -> Bool
forall t1 t2.
(CanTestCertainly t1, CanTestCertainly t2) =>
t1 -> t2 -> Bool
`stronglyImplies` (t2
y t2 -> t3 -> EqCompareType t2 t3
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== t3
z)

{-|
  HSpec properties that each implementation of HasEq should satisfy.
 -}
specHasEqNotMixed ::
  _ => T t -> Spec
specHasEqNotMixed :: T t -> Spec
specHasEqNotMixed (T t
t :: T t) = T t -> T t -> T t -> Spec
forall t1 t2 t3.
(Arbitrary t1, Arbitrary t2, Arbitrary t3, Show t1, Show t2,
 Show t3, CanTestCertainly (EqCompareType t1 t1),
 CanTestCertainly (EqCompareType t1 t2),
 CanTestCertainly (EqCompareType t2 t1),
 CanTestCertainly
   (AndOrType (EqCompareType t1 t2) (EqCompareType t2 t3)),
 CanTestCertainly (EqCompareType t2 t3), HasEqAsymmetric t1 t1,
 HasEqAsymmetric t1 t2, HasEqAsymmetric t2 t1,
 HasEqAsymmetric t2 t3,
 CanAndOrAsymmetric (EqCompareType t1 t2) (EqCompareType t2 t3)) =>
T t1 -> T t2 -> T t3 -> Spec
specHasEq T t
t T t
t T t
t

{-|
  HSpec property of there-and-back conversion.
-}
specConversion :: -- this definition cannot be in Literals because it needs HasEq
  (Arbitrary t1, Show t1, HasEqCertainly t1 t1) =>
  T t1 -> T t2 -> (t1 -> t2) -> (t2 -> t1) ->  Spec
specConversion :: T t1 -> T t2 -> (t1 -> t2) -> (t2 -> t1) -> Spec
specConversion (T String
typeName1 :: T t1) (T String
typeName2 :: T t2) t1 -> t2
conv12 t2 -> t1
conv21 =
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe String
"conversion" (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it (String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%s -> %s -> %s" String
typeName1 String
typeName2 String
typeName1) (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$ do
      (t1 -> Bool) -> Property
forall prop. Testable prop => prop -> Property
property ((t1 -> Bool) -> Property) -> (t1 -> Bool) -> Property
forall a b. (a -> b) -> a -> b
$ \ (t1
x1 :: t1) ->
        t1
x1 t1 -> t1 -> Bool
forall a b. HasEqCertainlyAsymmetric a b => a -> b -> Bool
?==? (t2 -> t1
conv21 (t2 -> t1) -> t2 -> t1
forall a b. (a -> b) -> a -> b
$ t1 -> t2
conv12 t1
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 :: Int -> Integer -> EqCompareType Int Integer
equalTo = (Integer -> Integer -> Bool) -> Int -> Integer -> Bool
forall a b c.
ConvertibleExactly a b =>
(b -> b -> c) -> a -> b -> c
convertFirst Integer -> Integer -> Bool
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
equalTo
instance HasEqAsymmetric Integer Int where
  equalTo :: Integer -> Int -> EqCompareType Integer Int
equalTo = (Integer -> Integer -> Bool) -> Integer -> Int -> Bool
forall b a c.
ConvertibleExactly b a =>
(a -> a -> c) -> a -> b -> c
convertSecond Integer -> Integer -> Bool
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
equalTo

instance HasEqAsymmetric Int Rational where
  equalTo :: Int -> Rational -> EqCompareType Int Rational
equalTo = (Rational -> Rational -> Bool) -> Int -> Rational -> Bool
forall a b c.
ConvertibleExactly a b =>
(b -> b -> c) -> a -> b -> c
convertFirst Rational -> Rational -> Bool
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
equalTo
instance HasEqAsymmetric Rational Int where
  equalTo :: Rational -> Int -> EqCompareType Rational Int
equalTo = (Rational -> Rational -> Bool) -> Rational -> Int -> Bool
forall b a c.
ConvertibleExactly b a =>
(a -> a -> c) -> a -> b -> c
convertSecond Rational -> Rational -> Bool
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
equalTo

instance HasEqAsymmetric Integer Rational where
  equalTo :: Integer -> Rational -> EqCompareType Integer Rational
equalTo = (Rational -> Rational -> Bool) -> Integer -> Rational -> Bool
forall a b c.
ConvertibleExactly a b =>
(b -> b -> c) -> a -> b -> c
convertFirst Rational -> Rational -> Bool
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
equalTo
instance HasEqAsymmetric Rational Integer where
  equalTo :: Rational -> Integer -> EqCompareType Rational Integer
equalTo = (Rational -> Rational -> Bool) -> Rational -> Integer -> Bool
forall b a c.
ConvertibleExactly b a =>
(a -> a -> c) -> a -> b -> c
convertSecond Rational -> Rational -> Bool
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
equalTo

instance HasEqAsymmetric Integer Double where
  equalTo :: Integer -> Double -> EqCompareType Integer Double
equalTo Integer
n Double
d = ((Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
P.floor Double
d :: Integer) Integer -> Integer -> EqCompareType Integer Integer
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== Integer
n) Bool -> Bool -> AndOrType Bool Bool
forall a b. CanAndOrAsymmetric a b => a -> b -> AndOrType a b
&& (Integer
n Integer -> Integer -> EqCompareType Integer Integer
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
P.ceiling Double
d :: Integer))
instance HasEqAsymmetric Double Integer where
  equalTo :: Double -> Integer -> EqCompareType Double Integer
equalTo Double
d Integer
n = ((Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
P.floor Double
d :: Integer) Integer -> Integer -> EqCompareType Integer Integer
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== Integer
n) Bool -> Bool -> AndOrType Bool Bool
forall a b. CanAndOrAsymmetric a b => a -> b -> AndOrType a b
&& (Integer
n Integer -> Integer -> EqCompareType Integer Integer
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
P.ceiling Double
d :: Integer))

instance HasEqAsymmetric Int Double where
  equalTo :: Int -> Double -> EqCompareType Int Double
equalTo Int
n Double
d = Integer -> Double -> EqCompareType Integer Double
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
equalTo (Int -> Integer
forall t. CanBeInteger t => t -> Integer
integer Int
n) Double
d
instance HasEqAsymmetric Double Int where
  equalTo :: Double -> Int -> EqCompareType Double Int
equalTo Double
d Int
n = Integer -> Double -> EqCompareType Integer Double
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
equalTo (Int -> Integer
forall t. CanBeInteger t => t -> Integer
integer Int
n) Double
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) -> EqCompareType (a1, a2) (b1, b2)
equalTo (a1
a1,a2
a2) (b1
b1,b2
b2) =
    (a1
a1 a1 -> b1 -> EqCompareType a1 b1
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== b1
b1) EqCompareType a1 b1
-> EqCompareType a2 b2
-> AndOrType (EqCompareType a1 b1) (EqCompareType a2 b2)
forall a b. CanAndOrAsymmetric a b => a -> b -> AndOrType a b
&& (a2
a2 a2 -> b2 -> EqCompareType a2 b2
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== b2
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) -> EqCompareType (a1, a2, a3) (b1, b2, b3)
equalTo (a1
a1,a2
a2,a3
a3) (b1
b1,b2
b2,b3
b3) =
    ((a1
a1,a2
a2), a3
a3) ((a1, a2), a3)
-> ((b1, b2), b3) -> EqCompareType ((a1, a2), a3) ((b1, b2), b3)
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== ((b1
b1,b2
b2), b3
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)
-> EqCompareType (a1, a2, a3, a4) (b1, b2, b3, b4)
equalTo (a1
a1,a2
a2,a3
a3,a4
a4) (b1
b1,b2
b2,b3
b3,b4
b4) =
    ((a1
a1,a2
a2,a3
a3), a4
a4) ((a1, a2, a3), a4)
-> ((b1, b2, b3), b4)
-> EqCompareType ((a1, a2, a3), a4) ((b1, b2, b3), b4)
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== ((b1
b1,b2
b2,b3
b3), b4
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)
-> EqCompareType (a1, a2, a3, a4, a5) (b1, b2, b3, b4, b5)
equalTo (a1
a1,a2
a2,a3
a3,a4
a4,a5
a5) (b1
b1,b2
b2,b3
b3,b4
b4,b5
b5) =
    ((a1
a1,a2
a2,a3
a3,a4
a4), a5
a5) ((a1, a2, a3, a4), a5)
-> ((b1, b2, b3, b4), b5)
-> EqCompareType ((a1, a2, a3, a4), a5) ((b1, b2, b3, b4), b5)
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== ((b1
b1,b2
b2,b3
b3,b4
b4), b5
b5)

instance (HasEqAsymmetric a b) => HasEqAsymmetric [a] [b] where
  type EqCompareType [a] [b] = EqCompareType a b
  equalTo :: [a] -> [b] -> EqCompareType [a] [b]
equalTo [] [] = Bool -> EqCompareType a b
forall t1 t2. ConvertibleExactly t1 t2 => t1 -> t2
convertExactly Bool
True
  equalTo (a
x:[a]
xs) (b
y:[b]
ys) = (a
x a -> b -> EqCompareType a b
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== b
y) EqCompareType a b
-> EqCompareType a b
-> AndOrType (EqCompareType a b) (EqCompareType a b)
forall a b. CanAndOrAsymmetric a b => a -> b -> AndOrType a b
&& ([a]
xs [a] -> [b] -> EqCompareType [a] [b]
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== [b]
ys)
  equalTo [a]
_ [b]
_ = Bool -> EqCompareType a b
forall t1 t2. ConvertibleExactly t1 t2 => t1 -> t2
convertExactly Bool
False

instance (HasEqAsymmetric a b) => HasEqAsymmetric (Maybe a) (Maybe b) where
  type EqCompareType (Maybe a) (Maybe b) = EqCompareType a b
  equalTo :: Maybe a -> Maybe b -> EqCompareType (Maybe a) (Maybe b)
equalTo Maybe a
Nothing Maybe b
Nothing = Bool -> EqCompareType a b
forall t1 t2. ConvertibleExactly t1 t2 => t1 -> t2
convertExactly Bool
True
  equalTo (Just a
x) (Just b
y) = (a
x a -> b -> EqCompareType a b
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== b
y)
  equalTo Maybe a
_ Maybe b
_ = Bool -> EqCompareType a b
forall t1 t2. ConvertibleExactly t1 t2 => t1 -> t2
convertExactly Bool
False

instance
  (HasEqAsymmetric a b, CanBeErrors es, CanTestCertainly (EqCompareType a b))
  =>
  HasEqAsymmetric (CollectErrors es a) (CollectErrors es  b)
  where
  type EqCompareType (CollectErrors es  a) (CollectErrors es  b) =
    CollectErrors es (EqCompareType a b)
  equalTo :: CollectErrors es a
-> CollectErrors es b
-> EqCompareType (CollectErrors es a) (CollectErrors es b)
equalTo = (a -> b -> EqCompareType a b)
-> CollectErrors es a
-> CollectErrors es b
-> CollectErrors es (EqCompareType a b)
forall es a b c.
Monoid es =>
(a -> b -> c)
-> CollectErrors es a -> CollectErrors es b -> CollectErrors es c
CE.lift2 a -> b -> EqCompareType a b
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
equalTo

$(declForTypes
  [[t| Bool |], [t| Maybe Bool |], [t| Integer |], [t| Int |], [t| Rational |], [t| Double |]]
  (\ t -> [d|

    instance
      (HasEqAsymmetric $t b, CanBeErrors es, CanTestCertainly (EqCompareType $t b))
      =>
      HasEqAsymmetric $t (CollectErrors es  b)
      where
      type EqCompareType $t (CollectErrors es  b) =
        CollectErrors es (EqCompareType $t b)
      equalTo = CE.liftT1 equalTo

    instance
      (HasEqAsymmetric a $t, CanBeErrors es, CanTestCertainly (EqCompareType a $t))
      =>
      HasEqAsymmetric (CollectErrors es a) $t
      where
      type EqCompareType (CollectErrors es  a) $t =
        CollectErrors es (EqCompareType a $t)
      equalTo = CE.lift1T equalTo

  |]))


{---- Checking whether it is valid / finite -----}

class CanTestValid t where
  isValid :: t -> Bool

{-|
  HSpec property checking the validity of unary operations' results.
 -}
specResultIsValid1 ::
  (Arbitrary t1, Show t1, CanTestValid t1, CanTestValid t2)
  =>
  (t1 -> t2) -> String -> T t1 -> Spec
specResultIsValid1 :: (t1 -> t2) -> String -> T t1 -> Spec
specResultIsValid1 = (t1 -> Bool) -> (t1 -> t2) -> String -> T t1 -> Spec
forall t1 t2.
(Arbitrary t1, Show t1, CanTestValid t1, CanTestValid t2) =>
(t1 -> Bool) -> (t1 -> t2) -> String -> T t1 -> Spec
specResultIsValid1Pre (Bool -> t1 -> Bool
forall a b. a -> b -> a
const Bool
True)

specResultIsValid1Pre ::
  (Arbitrary t1, Show t1, CanTestValid t1, CanTestValid t2)
  =>
  (t1 -> Bool) -> (t1 -> t2) -> String -> T t1 -> Spec
specResultIsValid1Pre :: (t1 -> Bool) -> (t1 -> t2) -> String -> T t1 -> Spec
specResultIsValid1Pre t1 -> Bool
pre t1 -> t2
f String
fName (T String
tName1 :: T t1) =
  String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it (String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Function %s returns a valid result for valid %s inputs" String
fName String
tName1) (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$ do
    (t1 -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((t1 -> Property) -> Property) -> (t1 -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ (t1
x :: t1) -> t1 -> Bool
forall t. CanTestValid t => t -> Bool
isValid t1
x Bool -> Bool -> AndOrType Bool Bool
forall a b. CanAndOrAsymmetric a b => a -> b -> AndOrType a b
&& t1 -> Bool
pre t1
x Bool -> Bool -> Property
forall prop. Testable prop => Bool -> prop -> Property
==> t2 -> Bool
forall t. CanTestValid t => t -> Bool
isValid (t1 -> t2
f t1
x)

{-|
  HSpec properties that check validity of operations' results.
 -}
specResultIsValid2 ::
  (Arbitrary t1, Show t1, Arbitrary t2, Show t2, CanTestValid t1, CanTestValid t2, CanTestValid t3)
  =>
  (t1 -> t2 -> t3) -> String -> T t1 -> T t2 -> Spec
specResultIsValid2 :: (t1 -> t2 -> t3) -> String -> T t1 -> T t2 -> Spec
specResultIsValid2 = (t1 -> t2 -> Bool)
-> (t1 -> t2 -> t3) -> String -> T t1 -> T t2 -> Spec
forall t1 t2 t3.
(Arbitrary t1, Show t1, Arbitrary t2, Show t2, CanTestValid t1,
 CanTestValid t2, CanTestValid t3) =>
(t1 -> t2 -> Bool)
-> (t1 -> t2 -> t3) -> String -> T t1 -> T t2 -> Spec
specResultIsValid2Pre (\t1
_ t2
_ -> Bool
True)

specResultIsValid2Pre ::
  (Arbitrary t1, Show t1, Arbitrary t2, Show t2, CanTestValid t1, CanTestValid t2, CanTestValid t3)
  =>
  (t1 -> t2 -> Bool) -> (t1 -> t2 -> t3) -> String -> T t1 -> T t2 -> Spec
specResultIsValid2Pre :: (t1 -> t2 -> Bool)
-> (t1 -> t2 -> t3) -> String -> T t1 -> T t2 -> Spec
specResultIsValid2Pre t1 -> t2 -> Bool
pre t1 -> t2 -> t3
f String
fName (T String
t1Name :: T t1) (T String
t2Name :: T t2) =
  String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it (String -> String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"Function %s returns a valid result for valid %s, %s inputs" String
fName String
t1Name String
t2Name) (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$ do
    (t1 -> t2 -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((t1 -> t2 -> Property) -> Property)
-> (t1 -> t2 -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ (t1
x :: t1) (t2
y :: t2) -> t1 -> Bool
forall t. CanTestValid t => t -> Bool
isValid t1
x Bool -> Bool -> AndOrType Bool Bool
forall a b. CanAndOrAsymmetric a b => a -> b -> AndOrType a b
&& t2 -> Bool
forall t. CanTestValid t => t -> Bool
isValid t2
y Bool -> Bool -> AndOrType Bool Bool
forall a b. CanAndOrAsymmetric a b => a -> b -> AndOrType a b
&& t1 -> t2 -> Bool
pre t1
x t2
y Bool -> Bool -> Property
forall prop. Testable prop => Bool -> prop -> Property
==> t3 -> Bool
forall t. CanTestValid t => t -> Bool
isValid (t1 -> t2 -> t3
f t1
x t2
y)

class CanTestNaN t where
  isNaN :: t -> Bool
  default isNaN :: (P.RealFloat t) => t -> Bool
  isNaN = t -> Bool
forall a. RealFloat a => a -> Bool
P.isNaN

class CanTestFinite t where
  isInfinite :: t -> Bool
  default isInfinite :: (P.RealFloat t) => t -> Bool
  isInfinite = t -> Bool
forall a. RealFloat a => a -> Bool
P.isInfinite
  isFinite :: t -> Bool
  default isFinite :: (P.RealFloat t) => t -> Bool
  isFinite t
x = (Bool -> NegType Bool
forall t. CanNeg t => t -> NegType t
not (Bool -> NegType Bool) -> Bool -> NegType Bool
forall a b. (a -> b) -> a -> b
$ t -> Bool
forall a. RealFloat a => a -> Bool
P.isNaN t
x) Bool -> Bool -> AndOrType Bool Bool
forall a b. CanAndOrAsymmetric a b => a -> b -> AndOrType a b
&& (Bool -> NegType Bool
forall t. CanNeg t => t -> NegType t
not (Bool -> NegType Bool) -> Bool -> NegType Bool
forall a b. (a -> b) -> a -> b
$ t -> Bool
forall a. RealFloat a => a -> Bool
P.isInfinite t
x)

instance CanTestNaN Double
instance CanTestFinite Double

instance CanTestNaN Integer where
  isNaN :: Integer -> Bool
isNaN = Bool -> Integer -> Bool
forall a b. a -> b -> a
const Bool
False
instance CanTestNaN Rational where
  isNaN :: Rational -> Bool
isNaN = Bool -> Rational -> Bool
forall a b. a -> b -> a
const Bool
False
instance CanTestFinite Int where
  isInfinite :: Int -> Bool
isInfinite = Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
False
  isFinite :: Int -> Bool
isFinite = Bool -> Int -> Bool
forall a b. a -> b -> a
const Bool
True
instance CanTestFinite Integer where
  isInfinite :: Integer -> Bool
isInfinite = Bool -> Integer -> Bool
forall a b. a -> b -> a
const Bool
False
  isFinite :: Integer -> Bool
isFinite = Bool -> Integer -> Bool
forall a b. a -> b -> a
const Bool
True
instance CanTestFinite Rational where
  isInfinite :: Rational -> Bool
isInfinite = Bool -> Rational -> Bool
forall a b. a -> b -> a
const Bool
False
  isFinite :: Rational -> Bool
isFinite = Bool -> Rational -> Bool
forall a b. a -> b -> a
const Bool
True

instance (CanTestNaN t, CanBeErrors es) => (CanTestNaN (CollectErrors es t)) where
  isNaN :: CollectErrors es t -> Bool
isNaN = (es -> Bool) -> (t -> Bool) -> CollectErrors es t -> Bool
forall es t v.
CanBeErrors es =>
(es -> t) -> (v -> t) -> CollectErrors es v -> t
CE.withErrorOrValue (Bool -> es -> Bool
forall a b. a -> b -> a
const Bool
False) t -> Bool
forall t. CanTestNaN t => t -> Bool
isNaN

instance (CanTestFinite t, CanBeErrors es) => (CanTestFinite (CollectErrors es t)) where
  isInfinite :: CollectErrors es t -> Bool
isInfinite = (es -> Bool) -> (t -> Bool) -> CollectErrors es t -> Bool
forall es t v.
CanBeErrors es =>
(es -> t) -> (v -> t) -> CollectErrors es v -> t
CE.withErrorOrValue (Bool -> es -> Bool
forall a b. a -> b -> a
const Bool
False) t -> Bool
forall t. CanTestFinite t => t -> Bool
isInfinite
  isFinite :: CollectErrors es t -> Bool
isFinite = (es -> Bool) -> (t -> Bool) -> CollectErrors es t -> Bool
forall es t v.
CanBeErrors es =>
(es -> t) -> (v -> t) -> CollectErrors es v -> t
CE.withErrorOrValue (Bool -> es -> Bool
forall a b. a -> b -> a
const Bool
False) t -> Bool
forall t. CanTestFinite t => t -> Bool
isFinite

{---- Checking whether it is an integer -----}

class CanTestInteger t where
  certainlyNotInteger :: t -> Bool
  certainlyInteger :: t -> Bool
  certainlyInteger t
s = case t -> Maybe Integer
forall t. CanTestInteger t => t -> Maybe Integer
certainlyIntegerGetIt t
s of Just Integer
_ -> Bool
True; Maybe Integer
_ -> Bool
False
  certainlyIntegerGetIt :: t -> Maybe Integer

instance CanTestInteger Integer where
  certainlyNotInteger :: Integer -> Bool
certainlyNotInteger Integer
_ = Bool
False
  certainlyInteger :: Integer -> Bool
certainlyInteger Integer
_ = Bool
True
  certainlyIntegerGetIt :: Integer -> Maybe Integer
certainlyIntegerGetIt Integer
n = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
n

instance CanTestInteger Int where
  certainlyNotInteger :: Int -> Bool
certainlyNotInteger Int
_ = Bool
False
  certainlyInteger :: Int -> Bool
certainlyInteger Int
_ = Bool
True
  certainlyIntegerGetIt :: Int -> Maybe Integer
certainlyIntegerGetIt Int
n = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Int -> Integer
forall t. CanBeInteger t => t -> Integer
integer Int
n)

instance CanTestInteger Rational where
  certainlyNotInteger :: Rational -> Bool
certainlyNotInteger Rational
q = (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
q Integer -> Integer -> EqCompareType Integer Integer
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
/= Integer
1)
  certainlyInteger :: Rational -> Bool
certainlyInteger Rational
q = (Rational -> Integer
forall a. Ratio a -> a
denominator Rational
q Integer -> Integer -> EqCompareType Integer Integer
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== Integer
1)
  certainlyIntegerGetIt :: Rational -> Maybe Integer
certainlyIntegerGetIt Rational
q
    | Rational -> Integer
forall a. Ratio a -> a
denominator Rational
q Integer -> Integer -> EqCompareType Integer Integer
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== Integer
1 = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Rational -> Integer
forall a. Ratio a -> a
numerator Rational
q)
    | Bool
otherwise = Maybe Integer
forall a. Maybe a
Nothing

instance CanTestInteger Double where
  certainlyNotInteger :: Double -> Bool
certainlyNotInteger Double
d =
    Double -> Bool
forall t. CanTestFinite t => t -> Bool
isInfinite Double
d Bool -> Bool -> AndOrType Bool Bool
forall a b. CanAndOrAsymmetric a b => a -> b -> AndOrType a b
|| Double -> Bool
forall t. CanTestNaN t => t -> Bool
isNaN Double
d Bool -> Bool -> AndOrType Bool Bool
forall a b. CanAndOrAsymmetric a b => a -> b -> AndOrType a b
||
      (Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
P.floor Double
d :: Integer) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
P.< Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
P.ceiling Double
d
  certainlyIntegerGetIt :: Double -> Maybe Integer
certainlyIntegerGetIt Double
d
    | Double -> Bool
forall t. CanTestFinite t => t -> Bool
isFinite Double
d Bool -> Bool -> AndOrType Bool Bool
forall a b. CanAndOrAsymmetric a b => a -> b -> AndOrType a b
&& (Integer
dF Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
P.== Integer
dC) = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
dF
    | Bool
otherwise = Maybe Integer
forall a. Maybe a
Nothing
    where
      dF :: Integer
dF = Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
P.floor Double
d
      dC :: Integer
dC = Double -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
P.ceiling Double
d

instance (CanTestInteger t, CanBeErrors es) => (CanTestInteger (CollectErrors es t)) where
  certainlyNotInteger :: CollectErrors es t -> Bool
certainlyNotInteger = (es -> Bool) -> (t -> Bool) -> CollectErrors es t -> Bool
forall es t v.
CanBeErrors es =>
(es -> t) -> (v -> t) -> CollectErrors es v -> t
CE.withErrorOrValue (Bool -> es -> Bool
forall a b. a -> b -> a
const Bool
False) t -> Bool
forall t. CanTestInteger t => t -> Bool
certainlyNotInteger
  certainlyIntegerGetIt :: CollectErrors es t -> Maybe Integer
certainlyIntegerGetIt = (es -> Maybe Integer)
-> (t -> Maybe Integer) -> CollectErrors es t -> Maybe Integer
forall es t v.
CanBeErrors es =>
(es -> t) -> (v -> t) -> CollectErrors es v -> t
CE.withErrorOrValue (Maybe Integer -> es -> Maybe Integer
forall a b. a -> b -> a
const Maybe Integer
forall a. Maybe a
Nothing) t -> Maybe Integer
forall t. CanTestInteger t => t -> Maybe Integer
certainlyIntegerGetIt

{---- Checking whether it is zero -----}

class CanTestZero t where
  isCertainlyZero :: t -> Bool
  isCertainlyNonZero :: t -> Bool
  default isCertainlyZero :: (HasEqCertainly t Integer) => t -> Bool
  isCertainlyZero t
a = EqCompareType Integer t -> Bool
forall t. CanTestCertainly t => t -> Bool
isCertainlyTrue (t
a t -> Integer -> EqCompareType t Integer
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
== Integer
0)
  default isCertainlyNonZero :: (HasEqCertainly t Integer) => t -> Bool
  isCertainlyNonZero t
a = EqCompareType Integer t -> Bool
forall t. CanTestCertainly t => t -> Bool
isCertainlyTrue (t
a t -> Integer -> EqCompareType t Integer
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
/= Integer
0)

{-|
  HSpec properties that each implementation of CanTestZero should satisfy.
 -}
specCanTestZero ::
  (CanTestZero t, ConvertibleExactly Integer t)
  =>
  T t -> Spec
specCanTestZero :: T t -> Spec
specCanTestZero (T String
typeName :: T t) =
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"CanTestZero %s" String
typeName) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"converted non-zero Integer is not isCertainlyZero" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$ do
      (Integer -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((Integer -> Property) -> Property)
-> (Integer -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ (Integer
x :: Integer) ->
        Integer
x Integer -> Integer -> EqCompareType Integer Integer
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
/= Integer
0 Bool -> Bool -> Property
forall prop. Testable prop => Bool -> prop -> Property
==> (Bool -> NegType Bool
forall t. CanNeg t => t -> NegType t
not (Bool -> NegType Bool) -> Bool -> NegType Bool
forall a b. (a -> b) -> a -> b
$ t -> Bool
forall t. CanTestZero t => t -> Bool
isCertainlyZero (Integer -> t
forall t1 t2. ConvertibleExactly t1 t2 => t1 -> t2
convertExactly Integer
x :: t))
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"converted non-zero Integer is isCertainlyNonZero" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$ do
      (Integer -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((Integer -> Property) -> Property)
-> (Integer -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ (Integer
x :: Integer) ->
        Integer
x Integer -> Integer -> EqCompareType Integer Integer
forall a b. HasEqAsymmetric a b => a -> b -> EqCompareType a b
/= Integer
0 Bool -> Bool -> Property
forall prop. Testable prop => Bool -> prop -> Property
==> (t -> Bool
forall t. CanTestZero t => t -> Bool
isCertainlyNonZero (Integer -> t
forall t1 t2. ConvertibleExactly t1 t2 => t1 -> t2
convertExactly Integer
x :: t))
    String -> Expectation -> SpecWith (Arg Expectation)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"converted 0.0 is not isCertainlyNonZero" (Expectation -> SpecWith (Arg Expectation))
-> Expectation -> SpecWith (Arg Expectation)
forall a b. (a -> b) -> a -> b
$ do
      (t -> Bool
forall t. CanTestZero t => t -> Bool
isCertainlyNonZero (Integer -> t
forall t1 t2. ConvertibleExactly t1 t2 => t1 -> t2
convertExactly Integer
0 :: t)) Bool -> Bool -> Expectation
forall a. (HasCallStack, Show a, Eq a) => a -> a -> Expectation
`shouldBe` Bool
False

instance CanTestZero Int
instance CanTestZero Integer
instance CanTestZero Rational
instance CanTestZero Double

instance (CanTestZero t, CanBeErrors es) => (CanTestZero (CollectErrors es t)) where
  isCertainlyZero :: CollectErrors es t -> Bool
isCertainlyZero = (es -> Bool) -> (t -> Bool) -> CollectErrors es t -> Bool
forall es t v.
CanBeErrors es =>
(es -> t) -> (v -> t) -> CollectErrors es v -> t
CE.withErrorOrValue (Bool -> es -> Bool
forall a b. a -> b -> a
const Bool
False) t -> Bool
forall t. CanTestZero t => t -> Bool
isCertainlyZero
  isCertainlyNonZero :: CollectErrors es t -> Bool
isCertainlyNonZero = (es -> Bool) -> (t -> Bool) -> CollectErrors es t -> Bool
forall es t v.
CanBeErrors es =>
(es -> t) -> (v -> t) -> CollectErrors es v -> t
CE.withErrorOrValue (Bool -> es -> Bool
forall a b. a -> b -> a
const Bool
False) t -> Bool
forall t. CanTestZero t => t -> Bool
isCertainlyNonZero


class CanPickNonZero t where
  {-|
    Given a list @[(a1,b1),(a2,b2),...]@ and assuming that
    at least one of @a1,a2,...@ is non-zero, pick one of them
    and return the corresponding pair @(ai,bi)@.

    If none of @a1,a2,...@ is zero, either throws an exception
    or loops forever.

    The default implementation is based on a `CanTestZero` instance
    and is not parallel.
   -}
  pickNonZero :: [(t,s)] -> Maybe (t,s)
  default pickNonZero :: (CanTestZero t, Show t) => [(t,s)] -> Maybe (t,s)
  pickNonZero [(t, s)]
list = [(t, s)] -> Maybe (t, s)
forall a b. CanTestZero a => [(a, b)] -> Maybe (a, b)
aux [(t, s)]
list
    where
      aux :: [(a, b)] -> Maybe (a, b)
aux ((a
a,b
b):[(a, b)]
rest)
        | a -> Bool
forall t. CanTestZero t => t -> Bool
isCertainlyNonZero a
a = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
a,b
b)
        | Bool
otherwise = [(a, b)] -> Maybe (a, b)
aux [(a, b)]
rest
      aux [] = Maybe (a, b)
forall a. Maybe a
Nothing

{-|
  HSpec properties that each implementation of CanPickNonZero should satisfy.
 -}
specCanPickNonZero ::
  (CanPickNonZero t, CanTestZero t, ConvertibleExactly Integer t, Show t, Arbitrary t)
  =>
  T t -> Spec
specCanPickNonZero :: T t -> Spec
specCanPickNonZero (T String
typeName :: T t) =
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (String -> String -> String
forall r. PrintfType r => String -> r
printf String
"CanPickNonZero %s" String
typeName) (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ do
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"picks a non-zero element if there is one" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$ do
      ([(t, ())] -> Property) -> Property
forall prop. Testable prop => prop -> Property
property (([(t, ())] -> Property) -> Property)
-> ([(t, ())] -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ ([(t, ())]
xs :: [(t, ())]) ->
        [Bool] -> Bool
forall t. (CanAndOrSameType t, CanTestCertainly t) => [t] -> t
or (((t, ()) -> Bool) -> [(t, ())] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (t -> Bool
forall t. CanTestZero t => t -> Bool
isCertainlyNonZero (t -> Bool) -> ((t, ()) -> t) -> (t, ()) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t, ()) -> t
forall a b. (a, b) -> a
fst) [(t, ())]
xs) -- if at least one is non-zero
        Bool -> Bool -> Property
forall prop. Testable prop => Bool -> prop -> Property
==>
        (case [(t, ())] -> Maybe (t, ())
forall t s. CanPickNonZero t => [(t, s)] -> Maybe (t, s)
pickNonZero [(t, ())]
xs of
          Just (t
v, ()
_) -> t -> Bool
forall t. CanTestZero t => t -> Bool
isCertainlyNonZero t
v
          Maybe (t, ())
_ -> Bool
False)
    String -> Bool -> SpecWith (Arg Bool)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"returns Nothing when all the elements are 0" (Bool -> SpecWith (Arg Bool)) -> Bool -> SpecWith (Arg Bool)
forall a b. (a -> b) -> a -> b
$ do
      case [(t, ())] -> Maybe (t, ())
forall t s. CanPickNonZero t => [(t, s)] -> Maybe (t, s)
pickNonZero [(Integer -> t
forall t1 t2. ConvertibleExactly t1 t2 => t1 -> t2
convertExactly Integer
i :: t, ()) | Integer
i <- [Integer
0,Integer
0,Integer
0]] of
        Maybe (t, ())
Nothing -> Bool
True
        Maybe (t, ())
_ -> Bool
False

instance CanPickNonZero Int
instance CanPickNonZero Integer
instance CanPickNonZero Rational

instance (CanPickNonZero a, CanBeErrors es) => (CanPickNonZero (CollectErrors es a)) where
  pickNonZero :: [(CollectErrors es a, s)] -> Maybe (CollectErrors es a, s)
pickNonZero =
    ((a, s) -> (CollectErrors es a, s))
-> Maybe (a, s) -> Maybe (CollectErrors es a, s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a
v,s
s) -> (a -> CollectErrors es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
v,s
s))
    (Maybe (a, s) -> Maybe (CollectErrors es a, s))
-> ([(CollectErrors es a, s)] -> Maybe (a, s))
-> [(CollectErrors es a, s)]
-> Maybe (CollectErrors es a, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, s)] -> Maybe (a, s)
forall t s. CanPickNonZero t => [(t, s)] -> Maybe (t, s)
pickNonZero
    ([(a, s)] -> Maybe (a, s))
-> ([(CollectErrors es a, s)] -> [(a, s)])
-> [(CollectErrors es a, s)]
-> Maybe (a, s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CollectErrors es (a, s)] -> [(a, s)]
forall es v. CanBeErrors es => [CollectErrors es v] -> [v]
CE.filterValuesWithoutError
    ([CollectErrors es (a, s)] -> [(a, s)])
-> ([(CollectErrors es a, s)] -> [CollectErrors es (a, s)])
-> [(CollectErrors es a, s)]
-> [(a, s)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (((CollectErrors es a, s) -> CollectErrors es (a, s))
-> [(CollectErrors es a, s)] -> [CollectErrors es (a, s)]
forall a b. (a -> b) -> [a] -> [b]
map (\(CollectErrors es a
vCN,s
s) -> (a -> (a, s)) -> CollectErrors es a -> CollectErrors es (a, s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a
v -> (a
v,s
s)) CollectErrors es a
vCN))