{-# LANGUAGE NoImplicitPrelude #-}
module Numeric.Floating.IEEE.Internal.GenericArith where
import           Data.Proxy
import           MyPrelude
import           Numeric.Floating.IEEE.Internal.Classify
import           Numeric.Floating.IEEE.Internal.Conversion
import           Numeric.Floating.IEEE.Internal.FMA

default ()

-- $setup
-- >>> :m + Data.Proxy
-- >>> import Numeric.Floating.IEEE.Internal.GenericArith

infixl 6 `genericAdd`, `genericSub`
infixl 7 `genericMul`, `genericDiv`

-- |
-- IEEE 754 @addition@ operation.
genericAdd :: (RealFloat a, RealFloat b) => a -> a -> b
genericAdd :: forall a b. (RealFloat a, RealFloat b) => a -> a -> b
genericAdd a
x a
y | a
x forall a. Eq a => a -> a -> Bool
== a
0 Bool -> Bool -> Bool
&& a
y forall a. Eq a => a -> a -> Bool
== a
0 = forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
x forall a. Num a => a -> a -> a
+ a
y)
               | forall a. RealFloat a => a -> Bool
isFinite a
x Bool -> Bool -> Bool
&& forall a. RealFloat a => a -> Bool
isFinite a
y = forall a. Fractional a => Rational -> a
fromRational (forall a. Real a => a -> Rational
toRational a
x forall a. Num a => a -> a -> a
+ forall a. Real a => a -> Rational
toRational a
y)
               | Bool
otherwise = forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
x forall a. Num a => a -> a -> a
+ a
y)
{-# NOINLINE [1] genericAdd #-}

-- |
-- IEEE 754 @subtraction@ operation.
genericSub :: (RealFloat a, RealFloat b) => a -> a -> b
genericSub :: forall a b. (RealFloat a, RealFloat b) => a -> a -> b
genericSub a
x a
y | a
x forall a. Eq a => a -> a -> Bool
== a
0 Bool -> Bool -> Bool
&& a
y forall a. Eq a => a -> a -> Bool
== a
0 = forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
x forall a. Num a => a -> a -> a
- a
y)
               | forall a. RealFloat a => a -> Bool
isFinite a
x Bool -> Bool -> Bool
&& forall a. RealFloat a => a -> Bool
isFinite a
y = forall a. Fractional a => Rational -> a
fromRational (forall a. Real a => a -> Rational
toRational a
x forall a. Num a => a -> a -> a
- forall a. Real a => a -> Rational
toRational a
y)
               | Bool
otherwise = forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
x forall a. Num a => a -> a -> a
- a
y)
{-# NOINLINE [1] genericSub #-}

-- |
-- IEEE 754 @multiplication@ operation.
genericMul :: (RealFloat a, RealFloat b) => a -> a -> b
genericMul :: forall a b. (RealFloat a, RealFloat b) => a -> a -> b
genericMul a
x a
y | a
x forall a. Eq a => a -> a -> Bool
== a
0 Bool -> Bool -> Bool
|| a
y forall a. Eq a => a -> a -> Bool
== a
0 = forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
x forall a. Num a => a -> a -> a
* a
y)
               | forall a. RealFloat a => a -> Bool
isFinite a
x Bool -> Bool -> Bool
&& forall a. RealFloat a => a -> Bool
isFinite a
y = forall a. Fractional a => Rational -> a
fromRational (forall a. Real a => a -> Rational
toRational a
x forall a. Num a => a -> a -> a
* forall a. Real a => a -> Rational
toRational a
y)
               | Bool
otherwise = forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
x forall a. Num a => a -> a -> a
* a
y)
{-# NOINLINE [1] genericMul #-}

-- |
-- IEEE 754 @division@ operation.
genericDiv :: (RealFloat a, RealFloat b) => a -> a -> b
genericDiv :: forall a b. (RealFloat a, RealFloat b) => a -> a -> b
genericDiv a
x a
y | a
x forall a. Eq a => a -> a -> Bool
== a
0 Bool -> Bool -> Bool
|| a
y forall a. Eq a => a -> a -> Bool
== a
0 = forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
x forall a. Fractional a => a -> a -> a
/ a
y)
               | forall a. RealFloat a => a -> Bool
isFinite a
x Bool -> Bool -> Bool
&& forall a. RealFloat a => a -> Bool
isFinite a
y = forall a. Fractional a => Rational -> a
fromRational (forall a. Real a => a -> Rational
toRational a
x forall a. Fractional a => a -> a -> a
/ forall a. Real a => a -> Rational
toRational a
y)
               | Bool
otherwise = forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
x forall a. Fractional a => a -> a -> a
/ a
y)
{-# NOINLINE [1] genericDiv #-}

{-
-- |
-- IEEE 754 @squareRoot@ operation.
genericSqrt :: (RealFloat a, RealFloat b) => a -> b
genericSqrt x | x == 0 = realFloatToFrac x
              | x > 0, isFinite x = error "not implemented yet"
              | otherwise = realFloatToFrac (sqrt x)
-}

-- |
-- IEEE 754 @fusedMultiplyAdd@ operation.
genericFusedMultiplyAdd :: (RealFloat a, RealFloat b) => a -> a -> a -> b
genericFusedMultiplyAdd :: forall a b. (RealFloat a, RealFloat b) => a -> a -> a -> b
genericFusedMultiplyAdd a
a a
b a
c
  | forall a. RealFloat a => a -> Bool
isFinite a
a Bool -> Bool -> Bool
&& forall a. RealFloat a => a -> Bool
isFinite a
b Bool -> Bool -> Bool
&& forall a. RealFloat a => a -> Bool
isFinite a
c = case forall a. Real a => a -> Rational
toRational a
a forall a. Num a => a -> a -> a
* forall a. Real a => a -> Rational
toRational a
b forall a. Num a => a -> a -> a
+ forall a. Real a => a -> Rational
toRational a
c of
                                               Rational
0 | forall a. RealFloat a => a -> Bool
isNegativeZero (a
a forall a. Num a => a -> a -> a
* a
b forall a. Num a => a -> a -> a
+ a
c) -> -b
0
                                               Rational
r -> forall a. Fractional a => Rational -> a
fromRational Rational
r
  | forall a. RealFloat a => a -> Bool
isFinite a
a Bool -> Bool -> Bool
&& forall a. RealFloat a => a -> Bool
isFinite a
b = forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac a
c -- c is Infinity or NaN
  | Bool
otherwise = forall a b. (RealFloat a, Fractional b) => a -> b
realFloatToFrac (a
a forall a. Num a => a -> a -> a
* a
b forall a. Num a => a -> a -> a
+ a
c)
{-# NOINLINE [1] genericFusedMultiplyAdd #-}

{-# RULES
"genericAdd/a->a" genericAdd = (+)
"genericSub/a->a" genericSub = (-)
"genericMul/a->a" genericMul = (*)
"genericDiv/a->a" genericDiv = (/)
"genericFusedMultiplyAdd/a->a" genericFusedMultiplyAdd = fusedMultiplyAdd
  #-}

-- | Returns True if @a@ is a subtype of @b@
--
-- >>> isSubFloatingType (undefined :: Float) (undefined :: Double)
-- True
-- >>> isSubFloatingType (undefined :: Double) (undefined :: Float)
-- False
-- >>> isSubFloatingType (undefined :: Double) (undefined :: Double)
-- True
isSubFloatingType :: (RealFloat a, RealFloat b) => a -> b -> Bool
isSubFloatingType :: forall a b. (RealFloat a, RealFloat b) => a -> b -> Bool
isSubFloatingType a
a b
b = Bool
ieeeA Bool -> Bool -> Bool
&& Bool
ieeeB Bool -> Bool -> Bool
&& Integer
baseA forall a. Eq a => a -> a -> Bool
== Integer
baseB Bool -> Bool -> Bool
&& Int
eminB forall a. Ord a => a -> a -> Bool
<= Int
eminA Bool -> Bool -> Bool
&& Int
emaxA forall a. Ord a => a -> a -> Bool
<= Int
emaxB Bool -> Bool -> Bool
&& Int
digitsA forall a. Ord a => a -> a -> Bool
<= Int
digitsB
  where
    ieeeA :: Bool
ieeeA = forall a. RealFloat a => a -> Bool
isIEEE a
a
    ieeeB :: Bool
ieeeB = forall a. RealFloat a => a -> Bool
isIEEE b
b
    baseA :: Integer
baseA = forall a. RealFloat a => a -> Integer
floatRadix a
a
    baseB :: Integer
baseB = forall a. RealFloat a => a -> Integer
floatRadix b
b
    (Int
eminA,Int
emaxA) = forall a. RealFloat a => a -> (Int, Int)
floatRange a
a
    (Int
eminB,Int
emaxB) = forall a. RealFloat a => a -> (Int, Int)
floatRange b
b
    digitsA :: Int
digitsA = forall a. RealFloat a => a -> Int
floatDigits a
a
    digitsB :: Int
digitsB = forall a. RealFloat a => a -> Int
floatDigits b
b

-- | Returns True if @a@ is a subtype of @b@
--
-- >>> isSubFloatingTypeProxy (Proxy :: Proxy Float) (Proxy :: Proxy Double)
-- True
-- >>> isSubFloatingTypeProxy (Proxy :: Proxy Double) (Proxy :: Proxy Float)
-- False
-- >>> isSubFloatingTypeProxy (Proxy :: Proxy Double) (Proxy :: Proxy Double)
-- True
isSubFloatingTypeProxy :: (RealFloat a, RealFloat b) => Proxy a -> Proxy b -> Bool
isSubFloatingTypeProxy :: forall a b.
(RealFloat a, RealFloat b) =>
Proxy a -> Proxy b -> Bool
isSubFloatingTypeProxy Proxy a
proxyA Proxy b
proxyB = forall a b. (RealFloat a, RealFloat b) => a -> b -> Bool
isSubFloatingType (forall a. HasCallStack => a
undefined forall a (proxy :: * -> *). a -> proxy a -> a
`asProxyTypeOf` Proxy a
proxyA) (forall a. HasCallStack => a
undefined forall a (proxy :: * -> *). a -> proxy a -> a
`asProxyTypeOf` Proxy b
proxyB)