    {-# 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 ()

    -- |
    -- IEEE 754 @isNormal@ operation.
    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

    -- |
    -- Returns @True@ if the argument is normal, subnormal, or zero.
    --
    -- IEEE 754 @isFinite@ operation.
    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
      #-}

    -- |
    -- Returns @True@ if the argument is zero.
    --
    -- IEEE 754 @isZero@ operation.
    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

    -- |
    -- Returns @True@ if the argument is negative (including negative zero).
    --
    -- Since 'RealFloat' constraint is insufficient to query the sign of NaNs,
    -- this function treats all NaNs as positive.
    -- See also "Numeric.Floating.IEEE.NaN".
    --
    -- IEEE 754 @isSignMinus@ operation.
    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

    -- |
    -- Comparison with IEEE 754 @totalOrder@ predicate.
    --
    -- Floating-point numbers are ordered as,
    -- \(-\infty < \text{negative reals} < -0 < +0 < \text{positive reals} < +\infty < \mathrm{NaN}\).
    --
    -- Since 'RealFloat' constraint is insufficient to query the sign and payload of NaNs,
    -- this function treats all NaNs as positive and does not make distinction between them.
    -- See also "Numeric.Floating.IEEE.NaN".
    --
    -- Also, for the same reason, this function cannot distinguish the members of a cohort.
    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) -- The sign bit and payload of NaNs are ignored
    -- TODO: Specialize for Float, Double

    -- |
    -- Comparison with IEEE 754 @totalOrderMag@ predicate.
    --
    -- Equivalent to @'compareByTotalOrder' (abs x) (abs 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)

    -- isCanonical :: a -> Bool

    -- data PartialOrdering = LT | EQ | GT | UNORD

    -- |
    -- The classification of floating-point values.
    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)

    -- |
    -- Classifies a floating-point value.
    --
    -- Since 'RealFloat' constraint is insufficient to query signaling status of a NaN, this function treats all NaNs as quiet.
    -- See also "Numeric.Floating.IEEE.NaN".
    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 -- 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
    _) -> Class
    QuietNaN -- treat all NaNs as quiet
                            (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 -- 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
    _) -> Class
    QuietNaN -- treat all NaNs as quiet
                            (Bool
    True,  Word64
    _,     Word64
    _) -> Class
    NegativeNormal
                            (Bool
    False, Word64
    _,     Word64
    _) -> Class
    PositiveNormal