{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NumericUnderscores #-}
module Numeric.Floating.IEEE.Internal.Classify where
import Data.Bits
import GHC.Float.Compat (castDoubleToWord64, castFloatToWord32,
isDoubleFinite, isFloatFinite)
import MyPrelude
default ()
isNormal :: RealFloat a => a -> Bool
isNormal :: forall a. RealFloat a => a -> Bool
isNormal a
x = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0 Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x) Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
x) Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isDenormalized a
x)
{-# NOINLINE [1] isNormal #-}
{-# RULES
"isNormal/Float" isNormal = isFloatNormal
"isNormal/Double" isNormal = isDoubleNormal
#-}
isFloatNormal :: Float -> Bool
isFloatNormal :: Float -> Bool
isFloatNormal Float
x = let w :: Word32
w = Float -> Word32
castFloatToWord32 Float
x Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x7f80_0000
in Word32
w Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0 Bool -> Bool -> Bool
&& Word32
w Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0x7f80_0000
isDoubleNormal :: Double -> Bool
isDoubleNormal :: Double -> Bool
isDoubleNormal Double
x = let w :: Word64
w = Double -> Word64
castDoubleToWord64 Double
x Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x7ff0_0000_0000_0000
in Word64
w Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0 Bool -> Bool -> Bool
&& Word64
w Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0x7ff0_0000_0000_0000
isFinite :: RealFloat a => a -> Bool
isFinite :: forall a. RealFloat a => a -> Bool
isFinite a
x = Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x) Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
x)
{-# NOINLINE [1] isFinite #-}
{-# RULES
"isFinite/Float"
isFinite = \x -> isFloatFinite x /= 0
"isFinite/Double"
isFinite = \x -> isDoubleFinite x /= 0
#-}
isZero :: RealFloat a => a -> Bool
isZero :: forall a. RealFloat a => a -> Bool
isZero a
x = a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
isSignMinus :: RealFloat a => a -> Bool
isSignMinus :: forall a. RealFloat a => a -> Bool
isSignMinus a
x = a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 Bool -> Bool -> Bool
|| a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero a
x
compareByTotalOrder :: RealFloat a => a -> a -> Ordering
compareByTotalOrder :: forall a. RealFloat a => a -> a -> Ordering
compareByTotalOrder 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
| Bool
otherwise = 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)
compareByTotalOrderMag :: RealFloat a => a -> a -> Ordering
compareByTotalOrderMag :: forall a. RealFloat a => a -> a -> Ordering
compareByTotalOrderMag a
x a
y = a -> a -> Ordering
forall a. RealFloat a => a -> a -> Ordering
compareByTotalOrder (a -> a
forall a. Num a => a -> a
abs a
x) (a -> a
forall a. Num a => a -> a
abs a
y)
data Class = SignalingNaN
| QuietNaN
| NegativeInfinity
| NegativeNormal
| NegativeSubnormal
| NegativeZero
| PositiveZero
| PositiveSubnormal
| PositiveNormal
| PositiveInfinity
deriving (Class -> Class -> Bool
(Class -> Class -> Bool) -> (Class -> Class -> Bool) -> Eq Class
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Class -> Class -> Bool
== :: Class -> Class -> Bool
$c/= :: Class -> Class -> Bool
/= :: Class -> Class -> Bool
Eq, Eq Class
Eq Class =>
(Class -> Class -> Ordering)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Bool)
-> (Class -> Class -> Class)
-> (Class -> Class -> Class)
-> Ord Class
Class -> Class -> Bool
Class -> Class -> Ordering
Class -> Class -> Class
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Class -> Class -> Ordering
compare :: Class -> Class -> Ordering
$c< :: Class -> Class -> Bool
< :: Class -> Class -> Bool
$c<= :: Class -> Class -> Bool
<= :: Class -> Class -> Bool
$c> :: Class -> Class -> Bool
> :: Class -> Class -> Bool
$c>= :: Class -> Class -> Bool
>= :: Class -> Class -> Bool
$cmax :: Class -> Class -> Class
max :: Class -> Class -> Class
$cmin :: Class -> Class -> Class
min :: Class -> Class -> Class
Ord, Int -> Class -> ShowS
[Class] -> ShowS
Class -> String
(Int -> Class -> ShowS)
-> (Class -> String) -> ([Class] -> ShowS) -> Show Class
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Class -> ShowS
showsPrec :: Int -> Class -> ShowS
$cshow :: Class -> String
show :: Class -> String
$cshowList :: [Class] -> ShowS
showList :: [Class] -> ShowS
Show, ReadPrec [Class]
ReadPrec Class
Int -> ReadS Class
ReadS [Class]
(Int -> ReadS Class)
-> ReadS [Class]
-> ReadPrec Class
-> ReadPrec [Class]
-> Read Class
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS Class
readsPrec :: Int -> ReadS Class
$creadList :: ReadS [Class]
readList :: ReadS [Class]
$creadPrec :: ReadPrec Class
readPrec :: ReadPrec Class
$creadListPrec :: ReadPrec [Class]
readListPrec :: ReadPrec [Class]
Read, Int -> Class
Class -> Int
Class -> [Class]
Class -> Class
Class -> Class -> [Class]
Class -> Class -> Class -> [Class]
(Class -> Class)
-> (Class -> Class)
-> (Int -> Class)
-> (Class -> Int)
-> (Class -> [Class])
-> (Class -> Class -> [Class])
-> (Class -> Class -> [Class])
-> (Class -> Class -> Class -> [Class])
-> Enum Class
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: Class -> Class
succ :: Class -> Class
$cpred :: Class -> Class
pred :: Class -> Class
$ctoEnum :: Int -> Class
toEnum :: Int -> Class
$cfromEnum :: Class -> Int
fromEnum :: Class -> Int
$cenumFrom :: Class -> [Class]
enumFrom :: Class -> [Class]
$cenumFromThen :: Class -> Class -> [Class]
enumFromThen :: Class -> Class -> [Class]
$cenumFromTo :: Class -> Class -> [Class]
enumFromTo :: Class -> Class -> [Class]
$cenumFromThenTo :: Class -> Class -> Class -> [Class]
enumFromThenTo :: Class -> Class -> Class -> [Class]
Enum)
classify :: RealFloat a => a -> Class
classify :: forall a. RealFloat a => a -> Class
classify a
x | a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
x = 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
{-# NOINLINE [1] classify #-}
{-# RULES
"classify/Float" classify = classifyFloat
"classify/Double" classify = classifyDouble
#-}
classifyFloat :: Float -> Class
classifyFloat :: Float -> Class
classifyFloat 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
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
m :: Word32
m = Word32
w Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0x007f_ffff
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
_) -> Class
QuietNaN
(Bool
True, Word32
_, Word32
_) -> Class
NegativeNormal
(Bool
False, Word32
_, Word32
_) -> Class
PositiveNormal
classifyDouble :: Double -> Class
classifyDouble :: Double -> Class
classifyDouble 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
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
m :: Word64
m = Word64
w Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x000f_ffff_ffff_ffff
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
_) -> Class
QuietNaN
(Bool
True, Word64
_, Word64
_) -> Class
NegativeNormal
(Bool
False, Word64
_, Word64
_) -> Class
PositiveNormal