{-# LANGUAGE FunctionalDependencies #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2015 Anselm Jonas Scholl, (C) 2023 Julia Longtin
-- License     :  BSD3
-- Maintainer  :  Julia Longtin <Julia.Longtin@gmail.com>
-- Stability   :  experimental
-- Portability :  GHC-specific
--
-- Functions for performing conversions between floating point values and
-- Integral values, for retrieving the Unit of Least Precision of a floating
-- point value, and for incrementing / decrementing a value by one ULP..
----------------------------------------------------------------------------
module Data.Bits.Floating (

    -- * Bitwise operations
     FloatingBits(..)

    -- * Printing
    ,ShowFloat(..)

    -- * Utility functions
    ,fromCFloat
    ,fromCDouble
    ) where

-- Our base library.
import Prelude (Double, Float, Floating, Integral, ShowS, String, (.), (/=), (++), id, isNaN, otherwise, shows)

-- Our bitwise and operator.
import Data.Bits ((.&.))

-- Conversion wrappers.
import Data.Bits.Floating.Prim (double2WordBitwise, float2WordBitwise, word2DoubleBitwise, word2FloatBitwise)

-- Functions for getting ULPs.
import Data.Bits.Floating.Ulp (doubleNextUlp, doublePrevUlp, doubleUlp, floatNextUlp, floatPrevUlp, floatUlp)

-- Our byte formats.
import Data.Word (Word32, Word64)

-- A function to dump hexidecimal.
import Numeric (showHex)

-- Types corresponding to C's Double and Float.
import Foreign.C.Types (CDouble(CDouble), CFloat(CFloat))

class (Floating f, Integral w) => FloatingBits f w | f -> w where
    -- | Coerce a floating point number to an integral number preserving the
    --   bitwise representation.
    coerceToWord :: f -> w
    -- | Coerce a integral number to an floating point number preserving the
    --   bitwise representation.
    --
    --   Note: It is not always possible to do this. In particular, if we coerce
    --   the bit pattern of a NaN value, we might get a NaN value with a different
    --   bit pattern than we wanted, so it is possible that
    --   @'coerceToWord' ('coerceToFloat' w) /= w@.
    coerceToFloat :: w -> f
    -- | Return the next floating point value in the direction of +INF.
    --   If the argument is NaN, NaN is returned.
    --   If the argument is +INF, +INF is returned.
    --   If the argument is 0.0, the minimum value greater than 0.0 is returned.
    --   If the argument is -INF, -INF is returned.
    nextUp :: f -> f
    -- | Return the next floating point value in the direction of -INF.
    --   If the argument is NaN, NaN is returned.
    --   If the argument is +INF, +INF is returned.
    --   If the argument is 0.0, the maximum value smaller than 0.0 is returned.
    --   If the argument is -INF, -INF is returned.
    nextDown :: f -> f
    -- | Return the size of the Unit of Least Precision of the argument.
    --   If the argument is NaN, NaN is returned.
    --   If the argument is +INF or -INF, +INF is returned.
    --   If the argument is 0.0, the minimum value greater than 0.0 is returned.
    --
    --   If @x@ is not NaN or one of the infinities, @'ulp' x == 'ulp' (-x)@ holds.
    ulp :: f -> f

class ShowFloat f where
    {-# MINIMAL showsFloat | showFloat #-}
    -- | Like 'showFloat', but prepends the value to another string.
    showsFloat :: f -> ShowS
    showsFloat f
f String
s = forall f. ShowFloat f => f -> String
showFloat f
f forall a. [a] -> [a] -> [a]
++ String
s
    -- | Convert a float to a string, but show additional information if it is
    --   a NaN value.
    showFloat :: f -> String
    showFloat f
f = forall f. ShowFloat f => f -> ShowS
showsFloat f
f String
""

-- {-# RULES "showFloat/++" forall f s . showFloat f ++ s = showsFloat f s #-}

instance FloatingBits Float Word32 where
    {-# INLINE coerceToWord #-}
    coerceToWord :: Float -> Word32
coerceToWord  = Float -> Word32
float2WordBitwise
    {-# INLINE coerceToFloat #-}
    coerceToFloat :: Word32 -> Float
coerceToFloat = Word32 -> Float
word2FloatBitwise
    {-# INLINE nextUp #-}
    nextUp :: Float -> Float
nextUp        = Float -> Float
floatNextUlp
    {-# INLINE nextDown #-}
    nextDown :: Float -> Float
nextDown      = Float -> Float
floatPrevUlp
    {-# INLINE ulp #-}
    ulp :: Float -> Float
ulp           = Float -> Float
floatUlp

instance FloatingBits Double Word64 where
    {-# INLINE coerceToWord #-}
    coerceToWord :: Double -> Word64
coerceToWord  = Double -> Word64
double2WordBitwise
    {-# INLINE coerceToFloat #-}
    coerceToFloat :: Word64 -> Double
coerceToFloat = Word64 -> Double
word2DoubleBitwise
    {-# INLINE nextUp #-}
    nextUp :: Double -> Double
nextUp        = Double -> Double
doubleNextUlp
    {-# INLINE nextDown #-}
    nextDown :: Double -> Double
nextDown      = Double -> Double
doublePrevUlp
    {-# INLINE ulp #-}
    ulp :: Double -> Double
ulp           = Double -> Double
doubleUlp

instance FloatingBits CFloat Word32 where
    {-# INLINE coerceToWord #-}
    coerceToWord :: CFloat -> Word32
coerceToWord  = forall f w. FloatingBits f w => f -> w
coerceToWord forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFloat -> Float
fromCFloat
    {-# INLINE coerceToFloat #-}
    coerceToFloat :: Word32 -> CFloat
coerceToFloat = Float -> CFloat
CFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f w. FloatingBits f w => w -> f
coerceToFloat
    {-# INLINE nextUp #-}
    nextUp :: CFloat -> CFloat
nextUp        = Float -> CFloat
CFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f w. FloatingBits f w => f -> f
nextUp forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFloat -> Float
fromCFloat
    {-# INLINE nextDown #-}
    nextDown :: CFloat -> CFloat
nextDown      = Float -> CFloat
CFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f w. FloatingBits f w => f -> f
nextDown forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFloat -> Float
fromCFloat
    {-# INLINE ulp #-}
    ulp :: CFloat -> CFloat
ulp           = Float -> CFloat
CFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f w. FloatingBits f w => f -> f
ulp forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFloat -> Float
fromCFloat

instance FloatingBits CDouble Word64 where
    {-# INLINE coerceToWord #-}
    coerceToWord :: CDouble -> Word64
coerceToWord  = forall f w. FloatingBits f w => f -> w
coerceToWord forall b c a. (b -> c) -> (a -> b) -> a -> c
. CDouble -> Double
fromCDouble
    {-# INLINE coerceToFloat #-}
    coerceToFloat :: Word64 -> CDouble
coerceToFloat = Double -> CDouble
CDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f w. FloatingBits f w => w -> f
coerceToFloat
    {-# INLINE nextUp #-}
    nextUp :: CDouble -> CDouble
nextUp        = Double -> CDouble
CDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f w. FloatingBits f w => f -> f
nextUp forall b c a. (b -> c) -> (a -> b) -> a -> c
. CDouble -> Double
fromCDouble
    {-# INLINE nextDown #-}
    nextDown :: CDouble -> CDouble
nextDown      = Double -> CDouble
CDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f w. FloatingBits f w => f -> f
nextDown forall b c a. (b -> c) -> (a -> b) -> a -> c
. CDouble -> Double
fromCDouble
    {-# INLINE ulp #-}
    ulp :: CDouble -> CDouble
ulp           = Double -> CDouble
CDouble forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall f w. FloatingBits f w => f -> f
ulp forall b c a. (b -> c) -> (a -> b) -> a -> c
. CDouble -> Double
fromCDouble

-- | Cast a 'CFloat' to a 'Float'.
{-# INLINE fromCFloat #-}
fromCFloat :: CFloat -> Float
fromCFloat :: CFloat -> Float
fromCFloat (CFloat Float
f) = Float
f

-- | Cast a 'CDouble' to a 'Double'.
{-# INLINE fromCDouble #-}
fromCDouble :: CDouble -> Double
fromCDouble :: CDouble -> Double
fromCDouble (CDouble Double
d) = Double
d

instance ShowFloat Float where
    showsFloat :: Float -> ShowS
showsFloat Float
f | forall a. RealFloat a => a -> Bool
isNaN Float
f   = Float -> ShowS
showsFloatNaN Float
f
                 | Bool
otherwise = forall a. Show a => a -> ShowS
shows Float
f

instance ShowFloat Double where
    showsFloat :: Double -> ShowS
showsFloat Double
f | forall a. RealFloat a => a -> Bool
isNaN Double
f   = Double -> ShowS
showsDoubleNaN Double
f
                 | Bool
otherwise = forall a. Show a => a -> ShowS
shows Double
f

instance ShowFloat CFloat where
    showsFloat :: CFloat -> ShowS
showsFloat = forall f. ShowFloat f => f -> ShowS
showsFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. CFloat -> Float
fromCFloat

instance ShowFloat CDouble where
    showsFloat :: CDouble -> ShowS
showsFloat = forall f. ShowFloat f => f -> ShowS
showsFloat forall b c a. (b -> c) -> (a -> b) -> a -> c
. CDouble -> Double
fromCDouble

-- | Show a 'Float' NaN value.
showsFloatNaN :: Float -> ShowS
showsFloatNaN :: Float -> ShowS
showsFloatNaN Float
f = ShowS
sign forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
nan forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ String
s -> Char
'('forall a. a -> [a] -> [a]
:Char
'0'forall a. a -> [a] -> [a]
:Char
'x'forall a. a -> [a] -> [a]
:String
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Integral a, Show a) => a -> ShowS
showHex (Word32
w forall a. Bits a => a -> a -> a
.&. Word32
0x3FFFFF) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
')'forall a. a -> [a] -> [a]
:)
    where
        w :: Word32
w = forall f w. FloatingBits f w => f -> w
coerceToWord Float
f
        sign :: ShowS
sign | Word32
w forall a. Bits a => a -> a -> a
.&. Word32
0x80000000 forall a. Eq a => a -> a -> Bool
/= Word32
0 = (Char
'-'forall a. a -> [a] -> [a]
:)
             | Bool
otherwise             = forall a. a -> a
id
        nan :: ShowS
nan String
s | Word32
w forall a. Bits a => a -> a -> a
.&. Word32
0x00400000 forall a. Eq a => a -> a -> Bool
/= Word32
0 = String
"qNaN" forall a. [a] -> [a] -> [a]
++ String
s
              | Bool
otherwise             = String
"sNaN" forall a. [a] -> [a] -> [a]
++ String
s

-- | Show a 'Double' NaN value.
showsDoubleNaN :: Double -> ShowS
showsDoubleNaN :: Double -> ShowS
showsDoubleNaN Double
f = ShowS
sign forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
nan forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ String
s -> Char
'('forall a. a -> [a] -> [a]
:Char
'0'forall a. a -> [a] -> [a]
:Char
'x'forall a. a -> [a] -> [a]
:String
s) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Integral a, Show a) => a -> ShowS
showHex (Word64
w forall a. Bits a => a -> a -> a
.&. Word64
0x0007FFFFFFFFFFFF) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
')'forall a. a -> [a] -> [a]
:)
    where
        w :: Word64
w = forall f w. FloatingBits f w => f -> w
coerceToWord Double
f
        sign :: ShowS
sign | Word64
w forall a. Bits a => a -> a -> a
.&. Word64
0x8000000000000000 forall a. Eq a => a -> a -> Bool
/= Word64
0 = (Char
'-'forall a. a -> [a] -> [a]
:)
             | Bool
otherwise                     = forall a. a -> a
id
        nan :: ShowS
nan String
s | Word64
w forall a. Bits a => a -> a -> a
.&. Word64
0x0008000000000000 forall a. Eq a => a -> a -> Bool
/= Word64
0 = String
"qNaN" forall a. [a] -> [a] -> [a]
++ String
s
              | Bool
otherwise                     = String
"sNaN" forall a. [a] -> [a] -> [a]
++ String
s