content: -- Copyright 2025 Lennart Augustsson
  -- See LICENSE file for full license.
  module Data.Float(Float) where
  import qualified Prelude()              -- do not import Prelude
  import Primitives
  import Control.Error
  import Data.Bits.Base
  import Data.Bool
  import Data.Char
  import Data.Enum
  import Data.Eq
  import Data.Floating
  import Data.Fractional
  import Data.Function
  import Data.Integer
  import Data.Integer.Internal(_integerToFloat, _wordToInteger)
  import Data.Integral
  import Data.List
  import Data.Ord
  import Data.Ratio
  import Data.Real
  import Data.RealFloat
  import Data.RealFrac
  import Data.Num
  import Data.Word.Word
  import {-# SOURCE #-} Numeric.FormatFloat(showFloat)
  import Numeric.Show(showSignedNeg)
  import Text.Show
  
  instance Num Float where
    (+)  = primFloatAdd
    (-)  = primFloatSub
    (*)  = primFloatMul
    negate = primFloatNeg
    abs x = if x < 0.0 then - x else x
    signum x =
      case compare x 0.0 of
        LT -> -1.0
        EQ ->  0.0
        GT ->  1.0
    fromInteger = _integerToFloat
  
  instance Fractional Float where
    (/) = primFloatDiv
    fromRational x =
      let n = numerator x
          d = denominator x
          maxVal = 2 ^ (127::Int)  -- actually bigger, but this converts correctly
      in  if abs n <= maxVal && d < maxVal then
            fromInteger n / fromInteger d
          else
            let (ne, nm) = scaleToMax maxVal n
                (de, dm) = scaleToMax maxVal d
            in  scaleFloat32 (ne - de) (fromInteger nm / fromInteger dm)
  
  -- XXX Very inefficient scaling
  -- If we get here the number has > 127 bits, so shifting by 64 is fine.
  scaleToMax :: Integer -> Integer -> (Int, Integer)
  scaleToMax m = f 0
    where f e x = if abs x < m then (e, x) else f (e+64) (x `shiftR` 64)
  
  instance Eq Float where
    (==) = primFloatEQ
    (/=) = primFloatNE
  
  instance Ord Float where
    (<)  = primFloatLT
    (<=) = primFloatLE
    (>)  = primFloatGT
    (>=) = primFloatGE
  
  instance Show Float where
    showsPrec = showSignedNeg (\ x -> x < 0 || isNegZeroFloat32 x) showFloat
  
  {- in Text.Read.Internal
  instance Read Float where
    readsPrec _ = readSigned $ \ r -> [ (primFloatRead s, t) | (s@(c:_), t) <- lex r, isDigit c ]
  -}
  
  instance Enum Float where
    succ x = x + 1
    pred x = x - 1
    toEnum n = fromIntegral n
    fromEnum = fromInteger . truncate
    enumFrom = numericEnumFrom
    enumFromThen = numericEnumFromThen
    enumFromTo = numericEnumFromTo
    enumFromThenTo = numericEnumFromThenTo
  
  instance Real Float where
    toRational x | isNaN x = rationalNaN
                 | isInfinite x = if x < 0 then -rationalInfinity else rationalInfinity
                 | isNegativeZero x = rationalNegativeZero
                 | otherwise =
      case decodeFloat x of
        (m, e) -> toRational m * 2^^e
  
  instance RealFrac Float where
    properFraction x =
      case decodeFloat x of
        (m, e) ->   -- x = m * 2^e
          let m' | e < 0     = m `quot` 2^(-e)
                 | otherwise = m * 2^e
          in  (fromInteger m', x - fromInteger m')
  
  instance Floating Float where
    pi     = 3.141592653589793
    log  x = clog x
    exp  x = cexp x
    sqrt x = csqrt x
    sin  x = csin x
    cos  x = ccos x
    tan  x = ctan x
    asin x = casin x
    acos x = cacos x
    atan x = catan x
  
  foreign import ccall "logf"  clog  :: Float -> Float
  foreign import ccall "expf"  cexp  :: Float -> Float
  foreign import ccall "sqrtf" csqrt :: Float -> Float
  foreign import ccall "sinf"  csin  :: Float -> Float
  foreign import ccall "cosf"  ccos  :: Float -> Float
  foreign import ccall "tanf"  ctan  :: Float -> Float
  foreign import ccall "asinf" casin :: Float -> Float
  foreign import ccall "acosf" cacos :: Float -> Float
  foreign import ccall "atanf" catan :: Float -> Float
  foreign import ccall "atan2f" catan2 :: Float -> Float -> Float
  foreign import ccall "scalbnf" cscalbn :: Float -> Int -> Float
  
  -- Assumes 32/64 bit floats
  instance RealFloat Float where
    floatRadix     _ = 2
    floatDigits    _ = 24
    floatRange     _ = (-125,128)
    decodeFloat      = decodeFloat32
    encodeFloat      = encodeFloat32
    isNaN            = isNaNFloat32
    isInfinite       = isInfFloat32
    isDenormalized   = isDenFloat32
    isNegativeZero   = isNegZeroFloat32
    isIEEE         _ = True
    atan2 x y        = catan2 x y
    scaleFloat       = scaleFloat32
  
  decodeFloat32 :: Float -> (Integer, Int)
  decodeFloat32 x =
    let xw   = primWordFromFloatRaw x
        sign =  xw .&. 0x80000000
        expn = (xw .&. 0x7fffffff) `shiftR` 23
        mant =  xw .&. 0x007fffff
        neg  = if sign /= 0 then negate else id
        -- Haskell promises that the mantissa is normalized
        adjDenorm m e | abs m < (1 `shiftL` 23) = adjDenorm (2 * m) (e - 1)
                      | otherwise = (m, e)
    in  if expn == 0 then
          -- denormalized or 0
          if mant == 0 then
            (0, 0)  -- 0
          else
            adjDenorm (neg (_wordToInteger mant)) (-149)  -- denormalized
        else if expn == 0xff then
          -- infinity or NaN
          error "decodeFloat32: inf or NaN"
        else
          -- ordinary number, add hidden bit
          -- mant is offset-127, and assumes scaled mantissa (thus -23)
          (neg (_wordToInteger (mant .|. 0x00800000)),
           primWordToInt expn - 127 - 23)
  
  isNaNFloat32 :: Float -> Bool
  isNaNFloat32 x =
    let xw   = primWordFromFloatRaw x
        expn = (xw .&. 0x7fffffff) `shiftR` 23
        mant =  xw .&. 0x007fffff
    in  expn == 0xff && mant /= 0
  
  isInfFloat32 :: Float -> Bool
  isInfFloat32 x =
    let xw   = primWordFromFloatRaw x
        expn = (xw .&. 0x7fffffff) `shiftR` 23
        mant =  xw .&. 0x007fffff
    in  expn == 0xff && mant == 0
  
  isDenFloat32 :: Float -> Bool
  isDenFloat32 x =
    let xw   = primWordFromFloatRaw x
        expn = (xw .&. 0x7fffffff) `shiftR` 23
        mant =  xw .&. 0x007fffff
    in  expn == 0 && mant /= 0
  
  isNegZeroFloat32 :: Float -> Bool
  isNegZeroFloat32 x =
    primWordFromFloatRaw x == 0x80000000
  
  scaleFloat32 :: Int -> Float -> Float
  scaleFloat32 n x = cscalbn x n
  
  encodeFloat32 :: Integer -> Int -> Float
  encodeFloat32 mant expn = scaleFloat32 expn (fromInteger mant)
  