{-# LANGUAGE NumericUnderscores #-}
module Numeric.Floating.IEEE.Internal.NaN
  ( module Numeric.Floating.IEEE.Internal.NaN
  , Class (..)
  ) where
import           Data.Bits
import           GHC.Float.Compat (castDoubleToWord64, castFloatToWord32,
                                   castWord32ToFloat, castWord64ToDouble)
import           Numeric.Floating.IEEE.Internal.Classify (Class (..))

-- | An instance of this class supports manipulation of NaN.
class RealFloat a => RealFloatNaN a where
  {-# MINIMAL (copySign | isSignMinus), (isSignaling | classify), getPayload, setPayload, setPayloadSignaling #-}

  -- 5.5.1 Sign bit operations
  -- |
  -- Returns the first operand, with the sign of the second.
  --
  -- IEEE 754 @copySign@ operation.
  copySign :: a -> a -> a
  copySign a
x a
y = if a -> Bool
forall a. RealFloatNaN a => a -> Bool
isSignMinus a
x Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Bool
forall a. RealFloatNaN a => a -> Bool
isSignMinus a
y then
                   a
x
                 else
                   -a
x

  -- 5.7.2 General operations
  -- |
  -- Returns @True@ if the operand is a negative number, negative infinity, negative zero, or a NaN with negative sign bit.
  --
  -- IEEE 754 @isSignMinus@ operation.
  isSignMinus :: a -> Bool
  isSignMinus a
x = a -> a -> a
forall a. RealFloatNaN a => a -> a -> a
copySign a
1.0 a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0

  -- |
  -- Returns @True@ if the operand is a signaling NaN.
  --
  -- IEEE 754 @isSignaling@ operation.
  --
  -- Warning: GHC's optimizer is not aware of signaling NaNs.
  isSignaling :: a -> Bool
  isSignaling a
x = a -> Class
forall a. RealFloatNaN a => a -> Class
classify a
x Class -> Class -> Bool
forall a. Eq a => a -> a -> Bool
== Class
SignalingNaN

  -- 9.7 NaN payload operations

  -- |
  -- Returns the payload of a NaN.
  -- Returns @-1@ if the operand is not a NaN.
  --
  -- IEEE 754 @getPayload@ operation.
  getPayload :: a -> a

  -- |
  -- Returns a quiet NaN with a given payload.
  -- Returns a positive zero if the payload is invalid.
  --
  -- IEEE 754 @setPayload@ operation.
  setPayload :: a -> a

  -- |
  -- Returns a signaling NaN with a given payload.
  -- Returns a positive zero if the payload is invalid.
  --
  -- IEEE 754 @setPayloadSignaling@ operation.
  setPayloadSignaling :: a -> a

  -- |
  -- IEEE 754 @class@ operation.
  classify :: a -> Class
  classify = a -> Class
forall a. RealFloatNaN a => a -> Class
classifyDefault

  -- |
  -- Equality with IEEE 754 @totalOrder@ operation.
  equalByTotalOrder :: a -> a -> Bool
  equalByTotalOrder a
x a
y = a -> a -> Ordering
forall a. RealFloatNaN a => a -> a -> Ordering
compareByTotalOrder a
x a
y Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ

  -- |
  -- Comparison with IEEE 754 @totalOrder@ operation.
  --
  -- Floating-point numbers should be ordered as,
  -- \(-\mathrm{qNaN} < -\mathrm{sNaN} < -\infty < \text{negative reals} < -0 < +0 < \text{positive reals} < +\infty < +\mathrm{sNaN} < +\mathrm{qNaN}\).
  compareByTotalOrder :: a -> a -> Ordering
  compareByTotalOrder = a -> a -> Ordering
forall a. RealFloatNaN a => a -> a -> Ordering
compareByTotalOrderDefault

classifyDefault :: RealFloatNaN a => a -> Class
classifyDefault :: a -> Class
classifyDefault a
x
  | a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x                 = if a -> Bool
forall a. RealFloatNaN a => a -> Bool
isSignaling a
x then
                                Class
SignalingNaN
                              else
                                Class
QuietNaN
  | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0, a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
x     = Class
NegativeInfinity
  | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0, a -> Bool
forall a. RealFloat a => a -> Bool
isDenormalized a
x = Class
NegativeSubnormal
  | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0                   = Class
NegativeNormal
  | a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero a
x        = Class
NegativeZero
  | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0                  = Class
PositiveZero
  | a -> Bool
forall a. RealFloat a => a -> Bool
isDenormalized a
x        = Class
PositiveSubnormal
  | a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
x            = Class
PositiveInfinity
  | Bool
otherwise               = Class
PositiveNormal

compareByTotalOrderDefault :: RealFloatNaN a => a -> a -> Ordering
compareByTotalOrderDefault :: a -> a -> Ordering
compareByTotalOrderDefault a
x a
y
  | a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y = Ordering
LT
  | a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
x = Ordering
GT
  | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y = if a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then
               Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero a
y) (a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero a
x)
             else
               Ordering
EQ -- TODO: cohort?
  | Bool
otherwise = Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> Bool
forall a. RealFloatNaN a => a -> Bool
isSignMinus a
y) (a -> Bool
forall a. RealFloatNaN a => a -> Bool
isSignMinus a
x)
                Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> let r :: Ordering
r = Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x) (a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
y) -- number < +NaN
                           Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> Bool
forall a. RealFloatNaN a => a -> Bool
isSignaling a
y) (a -> Bool
forall a. RealFloatNaN a => a -> Bool
isSignaling a
x) -- +(signaling NaN) < +(quiet NaN)
                           Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (a -> a
forall a. RealFloatNaN a => a -> a
getPayload a
x) (a -> a
forall a. RealFloatNaN a => a -> a
getPayload a
y) -- implementation-defined
                   in if a -> Bool
forall a. RealFloatNaN a => a -> Bool
isSignMinus a
x then
                        Ordering -> Ordering -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Ordering
EQ Ordering
r
                      else
                        Ordering
r

instance RealFloatNaN Float where
  copySign :: Float -> Float -> Float
copySign Float
x Float
y = Word32 -> Float
castWord32ToFloat ((Word32
x' Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x7fff_ffff) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32
y' Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x8000_0000))
    where x' :: Word32
x' = Float -> Word32
castFloatToWord32 Float
x
          y' :: Word32
y' = Float -> Word32
castFloatToWord32 Float
y

  isSignMinus :: Float -> Bool
isSignMinus Float
x = Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit (Float -> Word32
castFloatToWord32 Float
x) Int
31

  isSignaling :: Float -> Bool
isSignaling Float
x = Word32
x' Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x7f80_0000 Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x7f80_0000 Bool -> Bool -> Bool
&& Word32
x' Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x7fff_ffff Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0x7f80_0000 Bool -> Bool -> Bool
&& Bool -> Bool
not (Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
x' Int
22)
    where x' :: Word32
x' = Float -> Word32
castFloatToWord32 Float
x

  getPayload :: Float -> Float
getPayload Float
x
    | Bool -> Bool
not (Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
x) = -Float
1
    | Bool
otherwise = Word32 -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Float -> Word32
castFloatToWord32 Float
x Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x007f_ffff)

  setPayload :: Float -> Float
setPayload Float
x
    | Float
0 Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
x Bool -> Bool -> Bool
&& Float
x Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0x007f_ffff = Word32 -> Float
castWord32ToFloat (Word32 -> Float) -> Word32 -> Float
forall a b. (a -> b) -> a -> b
$ Float -> Word32
forall a b. (RealFrac a, Integral b) => a -> b
round Float
x Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
0x7fc0_0000
    | Bool
otherwise = Float
0

  setPayloadSignaling :: Float -> Float
setPayloadSignaling Float
x
    | Float
0 Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
x Bool -> Bool -> Bool
&& Float
x Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
0x007f_ffff = Word32 -> Float
castWord32ToFloat (Word32 -> Float) -> Word32 -> Float
forall a b. (a -> b) -> a -> b
$ Float -> Word32
forall a b. (RealFrac a, Integral b) => a -> b
round Float
x Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
0x7f80_0000
    | Bool
otherwise = Float
0

  classify :: Float -> Class
classify Float
x = let w :: Word32
w = Float -> Word32
castFloatToWord32 Float
x
                   s :: Bool
s = Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
w Int
31 -- sign bit
                   e :: Word32
e = (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
23) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xff -- exponent (8 bits)
                   m :: Word32
m = Word32
w Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x007f_ffff -- mantissa (23 bits without leading 1)
               in case (Bool
s, Word32
e, Word32
m) of
                    (Bool
True,  Word32
0,    Word32
0) -> Class
NegativeZero
                    (Bool
False, Word32
0,    Word32
0) -> Class
PositiveZero
                    (Bool
True,  Word32
0,    Word32
_) -> Class
NegativeSubnormal
                    (Bool
False, Word32
0,    Word32
_) -> Class
PositiveSubnormal
                    (Bool
True,  Word32
0xff, Word32
0) -> Class
NegativeInfinity
                    (Bool
False, Word32
0xff, Word32
0) -> Class
PositiveInfinity
                    (Bool
_,     Word32
0xff, Word32
_) -> if Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
w Int
22 then
                                          Class
QuietNaN
                                        else
                                          Class
SignalingNaN
                    (Bool
True,  Word32
_,    Word32
_) -> Class
NegativeNormal
                    (Bool
False, Word32
_,    Word32
_) -> Class
PositiveNormal

  equalByTotalOrder :: Float -> Float -> Bool
equalByTotalOrder Float
x Float
y = Float -> Word32
castFloatToWord32 Float
x Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Float -> Word32
castFloatToWord32 Float
y

  compareByTotalOrder :: Float -> Float -> Ordering
compareByTotalOrder Float
x Float
y = let x' :: Word32
x' = Float -> Word32
castFloatToWord32 Float
x
                                y' :: Word32
y' = Float -> Word32
castFloatToWord32 Float
y
                            in Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
y' Int
31) (Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
x' Int
31) -- sign bit
                               Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> if Word32 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word32
x' Int
31 then
                                    Word32 -> Word32 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word32
y' Word32
x' -- negative
                                  else
                                    Word32 -> Word32 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word32
x' Word32
y' -- positive

instance RealFloatNaN Double where
  copySign :: Double -> Double -> Double
copySign Double
x Double
y = Word64 -> Double
castWord64ToDouble ((Word64
x' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x7fff_ffff_ffff_ffff) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
y' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x8000_0000_0000_0000))
    where x' :: Word64
x' = Double -> Word64
castDoubleToWord64 Double
x
          y' :: Word64
y' = Double -> Word64
castDoubleToWord64 Double
y

  isSignMinus :: Double -> Bool
isSignMinus Double
x = Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit (Double -> Word64
castDoubleToWord64 Double
x) Int
63

  isSignaling :: Double -> Bool
isSignaling Double
x = Word64
x' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x7ff0_0000_0000_0000 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Word64
0x7ff0_0000_0000_0000 Bool -> Bool -> Bool
&& Word64
x' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x7fff_ffff_ffff_ffff Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0x7ff0_0000_0000_0000 Bool -> Bool -> Bool
&& Bool -> Bool
not (Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word64
x' Int
51)
    where x' :: Word64
x' = Double -> Word64
castDoubleToWord64 Double
x

  getPayload :: Double -> Double
getPayload Double
x
    | Bool -> Bool
not (Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
x) = -Double
1
    | Bool
otherwise = Word64 -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Double -> Word64
castDoubleToWord64 Double
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x0007_ffff_ffff_ffff)

  setPayload :: Double -> Double
setPayload Double
x
    | Double
0 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
x Bool -> Bool -> Bool
&& Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0x0007_ffff_ffff_ffff = Word64 -> Double
castWord64ToDouble (Word64 -> Double) -> Word64 -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
round Double
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
0x7ff8_0000_0000_0000
    | Bool
otherwise = Double
0

  setPayloadSignaling :: Double -> Double
setPayloadSignaling Double
x
    | Double
0 Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
x Bool -> Bool -> Bool
&& Double
x Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<= Double
0x0007_ffff_ffff_ffff = Word64 -> Double
castWord64ToDouble (Word64 -> Double) -> Word64 -> Double
forall a b. (a -> b) -> a -> b
$ Double -> Word64
forall a b. (RealFrac a, Integral b) => a -> b
round Double
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
0x7ff0_0000_0000_0000
    | Bool
otherwise = Double
0

  classify :: Double -> Class
classify Double
x = let w :: Word64
w = Double -> Word64
castDoubleToWord64 Double
x
                   s :: Bool
s = Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word64
w Int
63 -- sign bit
                   e :: Word64
e = (Word64
w Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
52) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x7ff -- exponent (11 bits)
                   m :: Word64
m = Word64
w Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x000f_ffff_ffff_ffff -- mantissa (52 bits without leading 1)
               in case (Bool
s, Word64
e, Word64
m) of
                    (Bool
True,  Word64
0,     Word64
0) -> Class
NegativeZero
                    (Bool
False, Word64
0,     Word64
0) -> Class
PositiveZero
                    (Bool
True,  Word64
0,     Word64
_) -> Class
NegativeSubnormal
                    (Bool
False, Word64
0,     Word64
_) -> Class
PositiveSubnormal
                    (Bool
True,  Word64
0x7ff, Word64
0) -> Class
NegativeInfinity
                    (Bool
False, Word64
0x7ff, Word64
0) -> Class
PositiveInfinity
                    (Bool
_,     Word64
0x7ff, Word64
_) -> if Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word64
w Int
51 then
                                           Class
QuietNaN
                                         else
                                           Class
SignalingNaN
                    (Bool
True,  Word64
_,     Word64
_) -> Class
NegativeNormal
                    (Bool
False, Word64
_,     Word64
_) -> Class
PositiveNormal

  equalByTotalOrder :: Double -> Double -> Bool
equalByTotalOrder Double
x Double
y = Double -> Word64
castDoubleToWord64 Double
x Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== Double -> Word64
castDoubleToWord64 Double
y

  compareByTotalOrder :: Double -> Double -> Ordering
compareByTotalOrder Double
x Double
y = let x' :: Word64
x' = Double -> Word64
castDoubleToWord64 Double
x
                                y' :: Word64
y' = Double -> Word64
castDoubleToWord64 Double
y
                            in Bool -> Bool -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word64
y' Int
63) (Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word64
x' Int
63) -- sign bit
                               Ordering -> Ordering -> Ordering
forall a. Semigroup a => a -> a -> a
<> if Word64 -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Word64
x' Int
63 then
                                    Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word64
y' Word64
x' -- negative
                                  else
                                    Word64 -> Word64 -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word64
x' Word64
y' -- positive

-- | A newtype wrapper to compare floating-point numbers by @totalOrder@ predicate.
newtype TotallyOrdered a = TotallyOrdered a
  deriving (Int -> TotallyOrdered a -> ShowS
[TotallyOrdered a] -> ShowS
TotallyOrdered a -> String
(Int -> TotallyOrdered a -> ShowS)
-> (TotallyOrdered a -> String)
-> ([TotallyOrdered a] -> ShowS)
-> Show (TotallyOrdered a)
forall a. Show a => Int -> TotallyOrdered a -> ShowS
forall a. Show a => [TotallyOrdered a] -> ShowS
forall a. Show a => TotallyOrdered a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TotallyOrdered a] -> ShowS
$cshowList :: forall a. Show a => [TotallyOrdered a] -> ShowS
show :: TotallyOrdered a -> String
$cshow :: forall a. Show a => TotallyOrdered a -> String
showsPrec :: Int -> TotallyOrdered a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> TotallyOrdered a -> ShowS
Show)

instance RealFloatNaN a => Eq (TotallyOrdered a) where
  TotallyOrdered a
x == :: TotallyOrdered a -> TotallyOrdered a -> Bool
== TotallyOrdered a
y = a -> a -> Bool
forall a. RealFloatNaN a => a -> a -> Bool
equalByTotalOrder a
x a
y

instance RealFloatNaN a => Ord (TotallyOrdered a) where
  compare :: TotallyOrdered a -> TotallyOrdered a -> Ordering
compare (TotallyOrdered a
x) (TotallyOrdered a
y) = a -> a -> Ordering
forall a. RealFloatNaN a => a -> a -> Ordering
compareByTotalOrder a
x a
y