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

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

-}

module Numeric.MixedTypes.AddSub
(
    -- * Addition
    CanAdd, CanAddAsymmetric(..), CanAddThis, CanAddSameType
    , (+), sum
  -- ** Tests
    , specCanAdd, specCanAddNotMixed, specCanAddSameType
    -- * Subtraction
    , CanSub(..), CanSubThis, CanSubSameType
    , (-)
  -- ** Tests
    , specCanSub, specCanSubNotMixed
)
where

import Utils.TH.DeclForTypes

import Numeric.MixedTypes.PreludeHiding
import qualified Prelude as P
import Text.Printf

import qualified Data.List as List

import Test.Hspec
import Test.QuickCheck

import Control.CollectErrors ( CollectErrors, CanBeErrors )
import qualified Control.CollectErrors as CE

import Numeric.MixedTypes.Literals
import Numeric.MixedTypes.Bool
import Numeric.MixedTypes.Eq
import Numeric.MixedTypes.Ord
import Numeric.MixedTypes.MinMaxAbs ()

{---- Addition -----}

type CanAdd t1 t2 =
  (CanAddAsymmetric t1 t2, CanAddAsymmetric t2 t1,
   AddType t1 t2 ~ AddType t2 t1)

{-|
  A replacement for Prelude's `P.+`.  If @t1 = t2@ and @Num t1@,
  then one can use the default implementation to mirror Prelude's @+@.
-}
class CanAddAsymmetric t1 t2 where
  type AddType t1 t2
  type AddType t1 t2 = t1 -- default
  add :: t1 -> t2 -> AddType t1 t2
  default add :: (AddType t1 t2 ~ t1, t1~t2, P.Num t1) => t1 -> t2 -> AddType t1 t2
  add = t1 -> t2 -> AddType t1 t2
forall a. Num a => a -> a -> a
(P.+)

infixl 6  +, -

(+) :: (CanAddAsymmetric t1 t2) => t1 -> t2 -> AddType t1 t2
+ :: t1 -> t2 -> AddType t1 t2
(+) = t1 -> t2 -> AddType t1 t2
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add

(-) :: (CanSub t1 t2) => t1 -> t2 -> SubType t1 t2
(-) = t1 -> t2 -> SubType t1 t2
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub

type CanAddThis t1 t2 =
  (CanAdd t1 t2, AddType t1 t2 ~ t1)
type CanAddSameType t =
  CanAddThis t t

sum :: (CanAddSameType t, ConvertibleExactly Integer t) => [t] -> t
sum :: [t] -> t
sum [t]
xs = (t -> t -> t) -> t -> [t] -> t
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' t -> t -> t
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add (Integer -> t
forall t1 t2. ConvertibleExactly t1 t2 => t1 -> t2
convertExactly Integer
0) [t]
xs

{-|
  HSpec properties that each implementation of CanAdd should satisfy.
 -}
specCanAdd ::
  _ => T t1 -> T t2 -> T t3 -> Spec
specCanAdd :: T t1 -> T t2 -> T t3 -> Spec
specCanAdd (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
"CanAdd %s %s, CanAdd %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
"absorbs 0" (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) -> let z :: t1
z = (Integer -> t1
forall t1 t2. ConvertibleExactly t1 t2 => t1 -> t2
convertExactly Integer
0 :: t1) in (t1
x t1 -> t1 -> AddType t1 t1
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
+ t1
z) AddType t1 t1 -> t1 -> Property
forall a b.
(HasEqCertainlyAsymmetric a b, Show a, Show b) =>
a -> b -> Property
?==?$ t1
x
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"is commutative" (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
x t1 -> t2 -> AddType t1 t2
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
+ t2
y) AddType t1 t2 -> AddType t2 t1 -> Property
forall a b.
(HasEqCertainlyAsymmetric a b, Show a, Show b) =>
a -> b -> Property
?==?$ (t2
y t2 -> t1 -> AddType t2 t1
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
+ t1
x)
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"is associative" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$ do
      (t1 -> t2 -> t3 -> Property) -> Property
forall prop. Testable prop => prop -> Property
property ((t1 -> t2 -> t3 -> Property) -> Property)
-> (t1 -> t2 -> t3 -> Property) -> Property
forall a b. (a -> b) -> a -> b
$ \ (t1
x :: t1) (t2
y :: t2) (t3
z :: t3) ->
                      (t1
x t1 -> AddType t2 t3 -> AddType t1 (AddType t2 t3)
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
+ (t2
y t2 -> t3 -> AddType t2 t3
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
+ t3
z)) AddType t1 (AddType t2 t3)
-> AddType (AddType t1 t2) t3 -> Property
forall a b.
(HasEqCertainlyAsymmetric a b, Show a, Show b) =>
a -> b -> Property
?==?$ ((t1
x t1 -> t2 -> AddType t1 t2
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
+ t2
y) AddType t1 t2 -> t3 -> AddType (AddType t1 t2) t3
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
+ t3
z)
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"increases when positive" (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. CanTestPosNeg t => t -> Bool
isCertainlyPositive t1
x) Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==> (t1
x t1 -> t2 -> AddType t1 t2
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
+ t2
y) AddType t1 t2 -> t2 -> Property
forall a b.
(HasOrderCertainlyAsymmetric a b, Show a, Show b) =>
a -> b -> Property
?>?$ t2
y
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"decreases when negative" (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. CanTestPosNeg t => t -> Bool
isCertainlyNegative t1
x) Bool -> Property -> Property
forall prop. Testable prop => Bool -> prop -> Property
==> (t1
x t1 -> t2 -> AddType t1 t2
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
+ t2
y) AddType t1 t2 -> t2 -> Property
forall a b.
(HasOrderCertainlyAsymmetric a b, Show a, Show b) =>
a -> b -> Property
?<?$ t2
y
  where
  (?==?$) :: (HasEqCertainlyAsymmetric a b, Show a, Show b) => a -> b -> Property
  ?==?$ :: a -> b -> Property
(?==?$) = String -> (a -> b -> Bool) -> a -> b -> Property
forall prop a b.
(Testable prop, Show a, Show b) =>
String -> (a -> b -> prop) -> a -> b -> Property
printArgsIfFails2 String
"?==?" a -> b -> Bool
forall a b. HasEqCertainlyAsymmetric a b => a -> b -> Bool
(?==?)
  (?>?$) :: (HasOrderCertainlyAsymmetric a b, Show a, Show b) => a -> b -> Property
  ?>?$ :: a -> b -> Property
(?>?$) = String -> (a -> b -> Bool) -> a -> b -> Property
forall prop a b.
(Testable prop, Show a, Show b) =>
String -> (a -> b -> prop) -> a -> b -> Property
printArgsIfFails2 String
"?>?" a -> b -> Bool
forall a b. HasOrderCertainlyAsymmetric a b => a -> b -> Bool
(?>?)
  (?<?$) :: (HasOrderCertainlyAsymmetric a b, Show a, Show b) => a -> b -> Property
  ?<?$ :: a -> b -> Property
(?<?$) = String -> (a -> b -> Bool) -> a -> b -> Property
forall prop a b.
(Testable prop, Show a, Show b) =>
String -> (a -> b -> prop) -> a -> b -> Property
printArgsIfFails2 String
"?<?" a -> b -> Bool
forall a b. HasOrderCertainlyAsymmetric a b => a -> b -> Bool
(?<?)

--
{-|
  HSpec properties that each implementation of CanAdd should satisfy.
 -}
specCanAddNotMixed ::
  _ => T t -> Spec
specCanAddNotMixed :: T t -> Spec
specCanAddNotMixed (T t
t :: T t) = T t -> T t -> T t -> Spec
forall t1 t2 t3.
(Arbitrary t1, Arbitrary t2, Arbitrary t3,
 HasEqAsymmetric (AddType t1 t1) t1,
 HasEqAsymmetric (AddType t1 t2) (AddType t2 t1),
 HasEqAsymmetric
   (AddType t1 (AddType t2 t3)) (AddType (AddType t1 t2) t3),
 Show t1, Show (AddType t1 t1), Show t2, Show (AddType t1 t2),
 Show (AddType t2 t1), Show t3, Show (AddType t1 (AddType t2 t3)),
 Show (AddType (AddType t1 t2) t3), CanAddAsymmetric t1 t1,
 CanAddAsymmetric t1 t2, CanAddAsymmetric t1 (AddType t2 t3),
 CanAddAsymmetric t2 t1, CanAddAsymmetric t2 t3,
 CanAddAsymmetric (AddType t1 t2) t3, CanTestPosNeg t1,
 HasOrderAsymmetric (AddType t1 t2) t2,
 CanTestCertainly (EqCompareType (AddType t1 t1) t1),
 CanTestCertainly (EqCompareType (AddType t1 t2) (AddType t2 t1)),
 CanTestCertainly
   (EqCompareType
      (AddType t1 (AddType t2 t3)) (AddType (AddType t1 t2) t3)),
 CanTestCertainly (OrderCompareType (AddType t1 t2) t2),
 ConvertibleExactly Integer t1) =>
T t1 -> T t2 -> T t3 -> Spec
specCanAdd T t
t T t
t T t
t

{-|
  HSpec properties that each implementation of CanAddSameType should satisfy.
 -}
specCanAddSameType ::
  (ConvertibleExactly Integer t, Show t,
   HasEqCertainly t t, CanAddSameType t)
   =>
   T t -> Spec
specCanAddSameType :: T t -> Spec
specCanAddSameType (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
"CanAddSameType %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
"has sum working over integers" (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]
xsi :: [Integer]) ->
        ([t] -> t
forall t.
(CanAddSameType t, ConvertibleExactly Integer t) =>
[t] -> t
sum ([t] -> t) -> [t] -> t
forall a b. (a -> b) -> a -> b
$ ((Integer -> t) -> [Integer] -> [t]
forall a b. (a -> b) -> [a] -> [b]
map Integer -> t
forall t1 t2. ConvertibleExactly t1 t2 => t1 -> t2
convertExactly [Integer]
xsi :: [t])) t -> t -> Property
forall a b.
(HasEqCertainlyAsymmetric a b, Show a, Show b) =>
a -> b -> Property
?==?$ (Integer -> t
forall t1 t2. ConvertibleExactly t1 t2 => t1 -> t2
convertExactly ([Integer] -> Integer
forall t.
(CanAddSameType t, ConvertibleExactly Integer t) =>
[t] -> t
sum [Integer]
xsi) :: t)
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"has sum [] = 0" (Property -> SpecWith (Arg Property))
-> Property -> SpecWith (Arg Property)
forall a b. (a -> b) -> a -> b
$ do
        ([t] -> t
forall t.
(CanAddSameType t, ConvertibleExactly Integer t) =>
[t] -> t
sum ([] :: [t])) t -> t -> Property
forall a b.
(HasEqCertainlyAsymmetric a b, Show a, Show b) =>
a -> b -> Property
?==?$ (Integer -> t
forall t1 t2. ConvertibleExactly t1 t2 => t1 -> t2
convertExactly Integer
0 :: t)
  where
  (?==?$) :: (HasEqCertainlyAsymmetric a b, Show a, Show b) => a -> b -> Property
  ?==?$ :: a -> b -> Property
(?==?$) = String -> (a -> b -> Bool) -> a -> b -> Property
forall prop a b.
(Testable prop, Show a, Show b) =>
String -> (a -> b -> prop) -> a -> b -> Property
printArgsIfFails2 String
"?==?" a -> b -> Bool
forall a b. HasEqCertainlyAsymmetric a b => a -> b -> Bool
(?==?)

instance CanAddAsymmetric Int Int where
  type AddType Int Int = Integer -- do not risk overflow
  add :: Int -> Int -> AddType Int Int
add Int
a Int
b = (Int -> Integer
forall t. CanBeInteger t => t -> Integer
integer Int
a) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
P.+ (Int -> Integer
forall t. CanBeInteger t => t -> Integer
integer Int
b)

instance CanAddAsymmetric Integer Integer
instance CanAddAsymmetric Rational Rational
instance CanAddAsymmetric Double Double

instance CanAddAsymmetric Int Integer where
  type AddType Int Integer = Integer
  add :: Int -> Integer -> AddType Int Integer
add = (Integer -> Integer -> Integer) -> Int -> Integer -> Integer
forall a b c.
ConvertibleExactly a b =>
(b -> b -> c) -> a -> b -> c
convertFirst Integer -> Integer -> Integer
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add
instance CanAddAsymmetric Integer Int where
  type AddType Integer Int = Integer
  add :: Integer -> Int -> AddType Integer Int
add = (Integer -> Integer -> Integer) -> Integer -> Int -> Integer
forall b a c.
ConvertibleExactly b a =>
(a -> a -> c) -> a -> b -> c
convertSecond Integer -> Integer -> Integer
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add

instance CanAddAsymmetric Int Rational where
  type AddType Int Rational = Rational
  add :: Int -> Rational -> AddType Int Rational
add = (Rational -> Rational -> Rational) -> Int -> Rational -> Rational
forall a b c.
ConvertibleExactly a b =>
(b -> b -> c) -> a -> b -> c
convertFirst Rational -> Rational -> Rational
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add
instance CanAddAsymmetric Rational Int where
  type AddType Rational Int = Rational
  add :: Rational -> Int -> AddType Rational Int
add = (Rational -> Rational -> Rational) -> Rational -> Int -> Rational
forall b a c.
ConvertibleExactly b a =>
(a -> a -> c) -> a -> b -> c
convertSecond Rational -> Rational -> Rational
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add

instance CanAddAsymmetric Integer Rational where
  type AddType Integer Rational = Rational
  add :: Integer -> Rational -> AddType Integer Rational
add = (Rational -> Rational -> Rational)
-> Integer -> Rational -> Rational
forall a b c.
ConvertibleExactly a b =>
(b -> b -> c) -> a -> b -> c
convertFirst Rational -> Rational -> Rational
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add
instance CanAddAsymmetric Rational Integer where
  type AddType Rational Integer = Rational
  add :: Rational -> Integer -> AddType Rational Integer
add = (Rational -> Rational -> Rational)
-> Rational -> Integer -> Rational
forall b a c.
ConvertibleExactly b a =>
(a -> a -> c) -> a -> b -> c
convertSecond Rational -> Rational -> Rational
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add

instance CanAddAsymmetric Int Double where
  type AddType Int Double = Double
  add :: Int -> Double -> AddType Int Double
add Int
n Double
d = Double -> Double -> AddType Double Double
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add (Int -> Double
forall t. CanBeDouble t => t -> Double
double Int
n) Double
d
instance CanAddAsymmetric Double Int where
  type AddType Double Int = Double
  add :: Double -> Int -> AddType Double Int
add Double
d Int
n = Double -> Double -> AddType Double Double
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add Double
d (Int -> Double
forall t. CanBeDouble t => t -> Double
double Int
n)

instance CanAddAsymmetric Integer Double where
  type AddType Integer Double = Double
  add :: Integer -> Double -> AddType Integer Double
add Integer
n Double
d = Double -> Double -> AddType Double Double
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add (Integer -> Double
forall t. CanBeDouble t => t -> Double
double Integer
n) Double
d
instance CanAddAsymmetric Double Integer where
  type AddType Double Integer = Double
  add :: Double -> Integer -> AddType Double Integer
add Double
d Integer
n = Double -> Double -> AddType Double Double
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add Double
d (Integer -> Double
forall t. CanBeDouble t => t -> Double
double Integer
n)

instance CanAddAsymmetric Rational Double where
  type AddType Rational Double = Double
  add :: Rational -> Double -> AddType Rational Double
add Rational
n Double
d = Double -> Double -> AddType Double Double
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add (Rational -> Double
forall t. CanBeDouble t => t -> Double
double Rational
n) Double
d
instance CanAddAsymmetric Double Rational where
  type AddType Double Rational = Double
  add :: Double -> Rational -> AddType Double Rational
add Double
d Rational
n = Double -> Double -> AddType Double Double
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add Double
d (Rational -> Double
forall t. CanBeDouble t => t -> Double
double Rational
n)

instance (CanAddAsymmetric a b) => CanAddAsymmetric [a] [b] where
  type AddType [a] [b] = [AddType a b]
  add :: [a] -> [b] -> AddType [a] [b]
add (a
x:[a]
xs) (b
y:[b]
ys) = (a -> b -> AddType a b
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add a
x b
y) AddType a b -> [AddType a b] -> [AddType a b]
forall a. a -> [a] -> [a]
: ([a] -> [b] -> AddType [a] [b]
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add [a]
xs [b]
ys)
  add [a]
_ [b]
_ = []

instance (CanAddAsymmetric a b) => CanAddAsymmetric (Maybe a) (Maybe b) where
  type AddType (Maybe a) (Maybe b) = Maybe (AddType a b)
  add :: Maybe a -> Maybe b -> AddType (Maybe a) (Maybe b)
add (Just a
x) (Just b
y) = AddType a b -> Maybe (AddType a b)
forall a. a -> Maybe a
Just (a -> b -> AddType a b
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add a
x b
y)
  add Maybe a
_ Maybe b
_ = AddType (Maybe a) (Maybe b)
forall a. Maybe a
Nothing

instance
  (CanAddAsymmetric a b, CanBeErrors es)
  =>
  CanAddAsymmetric (CollectErrors es a) (CollectErrors es  b)
  where
  type AddType (CollectErrors es a) (CollectErrors es b) =
    CollectErrors es (AddType a b)
  add :: CollectErrors es a
-> CollectErrors es b
-> AddType (CollectErrors es a) (CollectErrors es b)
add = (a -> b -> AddType a b)
-> CollectErrors es a
-> CollectErrors es b
-> CollectErrors es (AddType 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 -> AddType a b
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
add

-- TH for ground type instances at is the end of the file due to a bug in TH

{---- Subtraction -----}

{-|
  A replacement for Prelude's binary `P.-`.

  If @CanNeg t2@ and @CanAdd t1 (NegType t2)@,
  then one can use the default implementation
  via @a-b = a + (-b)@.
-}
class CanSub t1 t2 where
  type SubType t1 t2
  type SubType t1 t2 = AddType t1 (NegType t2) -- default
  sub :: t1 -> t2 -> SubType t1 t2
  default sub ::
    (SubType t1 t2 ~ AddType t1 (NegType t2),
    CanNeg t2, CanAdd t1 (NegType t2))
    =>
    t1 -> t2 -> SubType t1 t2
  t1
a `sub` t2
b = t1
a t1 -> NegType t2 -> AddType t1 (NegType t2)
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
+ (t2 -> NegType t2
forall t. CanNeg t => t -> NegType t
negate t2
b)

type CanSubThis t1 t2 =
  (CanSub t1 t2, SubType t1 t2 ~ t1)
type CanSubSameType t =
  CanSubThis t t

{-|
  HSpec properties that each implementation of CanSub should satisfy.
 -}
specCanSub ::
  _ => T t1 -> T t2 -> Spec
specCanSub :: T t1 -> T t2 -> Spec
specCanSub (T String
typeName1 :: T t1) (T String
typeName2 :: T t2) =
  String -> Spec -> Spec
forall a. HasCallStack => String -> SpecWith a -> SpecWith a
describe (String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"CanSub %s %s" String
typeName1 String
typeName2) (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
"x-0 = x" (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) -> let z :: t1
z = (Integer -> t1
forall t1 t2. ConvertibleExactly t1 t2 => t1 -> t2
convertExactly Integer
0 :: t1) in (t1
x t1 -> t1 -> SubType t1 t1
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
- t1
z) SubType t1 t1 -> t1 -> Property
forall a b.
(HasEqCertainlyAsymmetric a b, Show a, Show b) =>
a -> b -> Property
?==?$ t1
x
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"x-x = 0" (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) -> let z :: t1
z = (Integer -> t1
forall t1 t2. ConvertibleExactly t1 t2 => t1 -> t2
convertExactly Integer
0 :: t1) in (t1
x t1 -> t1 -> SubType t1 t1
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
- t1
x) SubType t1 t1 -> t1 -> Property
forall a b.
(HasEqCertainlyAsymmetric a b, Show a, Show b) =>
a -> b -> Property
?==?$ t1
z
    String -> Property -> SpecWith (Arg Property)
forall a.
(HasCallStack, Example a) =>
String -> a -> SpecWith (Arg a)
it String
"x-y = x+(-y)" (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
x t1 -> t2 -> SubType t1 t2
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
- t2
y) SubType t1 t2 -> AddType t1 (NegType t2) -> Property
forall a b.
(HasEqCertainlyAsymmetric a b, Show a, Show b) =>
a -> b -> Property
?==?$ (t1
x t1 -> NegType t2 -> AddType t1 (NegType t2)
forall t1 t2. CanAddAsymmetric t1 t2 => t1 -> t2 -> AddType t1 t2
+ (t2 -> NegType t2
forall t. CanNeg t => t -> NegType t
negate t2
y))
  where
  (?==?$) :: (HasEqCertainlyAsymmetric a b, Show a, Show b) => a -> b -> Property
  ?==?$ :: a -> b -> Property
(?==?$) = String -> (a -> b -> Bool) -> a -> b -> Property
forall prop a b.
(Testable prop, Show a, Show b) =>
String -> (a -> b -> prop) -> a -> b -> Property
printArgsIfFails2 String
"?==?" a -> b -> Bool
forall a b. HasEqCertainlyAsymmetric a b => a -> b -> Bool
(?==?)

--
{-|
  HSpec properties that each implementation of CanSub should satisfy.
 -}
specCanSubNotMixed ::
  _ => T t -> Spec
specCanSubNotMixed :: T t -> Spec
specCanSubNotMixed (T t
t :: T t) = T t -> T t -> Spec
forall t1 t2.
(Arbitrary t1, Arbitrary t2, HasEqAsymmetric (SubType t1 t1) t1,
 HasEqAsymmetric (SubType t1 t2) (AddType t1 (NegType t2)),
 CanTestCertainly (EqCompareType (SubType t1 t1) t1),
 CanTestCertainly
   (EqCompareType (SubType t1 t2) (AddType t1 (NegType t2))),
 Show t1, Show (SubType t1 t1), Show t2, Show (SubType t1 t2),
 Show (AddType t1 (NegType t2)), CanSub t1 t1, CanSub t1 t2,
 CanAddAsymmetric t1 (NegType t2), ConvertibleExactly Integer t1,
 CanNeg t2) =>
T t1 -> T t2 -> Spec
specCanSub T t
t T t
t

instance CanSub Int Int where
  type SubType Int Int = Integer -- do not risk overflow
  sub :: Int -> Int -> SubType Int Int
sub Int
a Int
b = (Int -> Integer
forall t. CanBeInteger t => t -> Integer
integer Int
a) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
P.- (Int -> Integer
forall t. CanBeInteger t => t -> Integer
integer Int
b)

instance CanSub Integer Integer
instance CanSub Rational Rational
instance CanSub Double Double

instance CanSub Int Integer where
  type SubType Int Integer = Integer
  sub :: Int -> Integer -> SubType Int Integer
sub = (Integer -> Integer -> Integer) -> Int -> Integer -> Integer
forall a b c.
ConvertibleExactly a b =>
(b -> b -> c) -> a -> b -> c
convertFirst Integer -> Integer -> Integer
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub
instance CanSub Integer Int where
  type SubType Integer Int = Integer
  sub :: Integer -> Int -> SubType Integer Int
sub = (Integer -> Integer -> Integer) -> Integer -> Int -> Integer
forall b a c.
ConvertibleExactly b a =>
(a -> a -> c) -> a -> b -> c
convertSecond Integer -> Integer -> Integer
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub

instance CanSub Int Rational where
  type SubType Int Rational = Rational
  sub :: Int -> Rational -> SubType Int Rational
sub = (Rational -> Rational -> Rational) -> Int -> Rational -> Rational
forall a b c.
ConvertibleExactly a b =>
(b -> b -> c) -> a -> b -> c
convertFirst Rational -> Rational -> Rational
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub
instance CanSub Rational Int where
  type SubType Rational Int = Rational
  sub :: Rational -> Int -> SubType Rational Int
sub = (Rational -> Rational -> Rational) -> Rational -> Int -> Rational
forall b a c.
ConvertibleExactly b a =>
(a -> a -> c) -> a -> b -> c
convertSecond Rational -> Rational -> Rational
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub

instance CanSub Integer Rational where
  type SubType Integer Rational = Rational
  sub :: Integer -> Rational -> SubType Integer Rational
sub = (Rational -> Rational -> Rational)
-> Integer -> Rational -> Rational
forall a b c.
ConvertibleExactly a b =>
(b -> b -> c) -> a -> b -> c
convertFirst Rational -> Rational -> Rational
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub
instance CanSub Rational Integer where
  type SubType Rational Integer = Rational
  sub :: Rational -> Integer -> SubType Rational Integer
sub = (Rational -> Rational -> Rational)
-> Rational -> Integer -> Rational
forall b a c.
ConvertibleExactly b a =>
(a -> a -> c) -> a -> b -> c
convertSecond Rational -> Rational -> Rational
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub

instance CanSub Int Double where
  type SubType Int Double = Double
  sub :: Int -> Double -> SubType Int Double
sub Int
n Double
d = Double -> Double -> SubType Double Double
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub (Int -> Double
forall t. CanBeDouble t => t -> Double
double Int
n) Double
d
instance CanSub Double Int where
  type SubType Double Int = Double
  sub :: Double -> Int -> SubType Double Int
sub Double
d Int
n = Double -> Double -> SubType Double Double
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub Double
d (Int -> Double
forall t. CanBeDouble t => t -> Double
double Int
n)

instance CanSub Integer Double where
  type SubType Integer Double = Double
  sub :: Integer -> Double -> SubType Integer Double
sub Integer
n Double
d = Double -> Double -> SubType Double Double
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub (Integer -> Double
forall t. CanBeDouble t => t -> Double
double Integer
n) Double
d
instance CanSub Double Integer where
  type SubType Double Integer = Double
  sub :: Double -> Integer -> SubType Double Integer
sub Double
d Integer
n = Double -> Double -> SubType Double Double
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub Double
d (Integer -> Double
forall t. CanBeDouble t => t -> Double
double Integer
n)

instance CanSub Rational Double where
  type SubType Rational Double = Double
  sub :: Rational -> Double -> SubType Rational Double
sub Rational
n Double
d = Double -> Double -> SubType Double Double
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub (Rational -> Double
forall t. CanBeDouble t => t -> Double
double Rational
n) Double
d
instance CanSub Double Rational where
  type SubType Double Rational = Double
  sub :: Double -> Rational -> SubType Double Rational
sub Double
d Rational
n = Double -> Double -> SubType Double Double
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub Double
d (Rational -> Double
forall t. CanBeDouble t => t -> Double
double Rational
n)

instance (CanSub a b) => CanSub [a] [b] where
  type SubType [a] [b] = [SubType a b]
  sub :: [a] -> [b] -> SubType [a] [b]
sub (a
x:[a]
xs) (b
y:[b]
ys) = (a -> b -> SubType a b
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub a
x b
y) SubType a b -> [SubType a b] -> [SubType a b]
forall a. a -> [a] -> [a]
: ([a] -> [b] -> SubType [a] [b]
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub [a]
xs [b]
ys)
  sub [a]
_ [b]
_ = []

instance (CanSub a b) => CanSub (Maybe a) (Maybe b) where
  type SubType (Maybe a) (Maybe b) = Maybe (SubType a b)
  sub :: Maybe a -> Maybe b -> SubType (Maybe a) (Maybe b)
sub (Just a
x) (Just b
y) = SubType a b -> Maybe (SubType a b)
forall a. a -> Maybe a
Just (a -> b -> SubType a b
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub a
x b
y)
  sub Maybe a
_ Maybe b
_ = SubType (Maybe a) (Maybe b)
forall a. Maybe a
Nothing


instance
  (CanSub a b, CanBeErrors es)
  =>
  CanSub (CollectErrors es a) (CollectErrors es  b)
  where
  type SubType (CollectErrors es a) (CollectErrors es b) =
    CollectErrors es (SubType a b)
  sub :: CollectErrors es a
-> CollectErrors es b
-> SubType (CollectErrors es a) (CollectErrors es b)
sub = (a -> b -> SubType a b)
-> CollectErrors es a
-> CollectErrors es b
-> CollectErrors es (SubType 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 -> SubType a b
forall t1 t2. CanSub t1 t2 => t1 -> t2 -> SubType t1 t2
sub

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

    instance
      (CanSub $t b, CanBeErrors es)
      =>
      CanSub $t (CollectErrors es  b)
      where
      type SubType $t (CollectErrors es  b) =
        CollectErrors es (SubType $t b)
      sub = CE.liftT1 sub

    instance
      (CanSub a $t, CanBeErrors es)
      =>
      CanSub (CollectErrors es a) $t
      where
      type SubType (CollectErrors es  a) $t =
        CollectErrors es (SubType a $t)
      sub = CE.lift1T sub

    instance
      (CanAddAsymmetric $t b, CanBeErrors es)
      =>
      CanAddAsymmetric $t (CollectErrors es  b)
      where
      type AddType $t (CollectErrors es  b) =
        CollectErrors es (AddType $t b)
      add = CE.liftT1 add

    instance
      (CanAddAsymmetric a $t, CanBeErrors es)
      =>
      CanAddAsymmetric (CollectErrors es a) $t
      where
      type AddType (CollectErrors es  a) $t =
        CollectErrors es (AddType a $t)
      add = CE.lift1T add
  |]))