{-
 - Copyright (C) 2010 Nick Bowler.
 -
 - License BSD2:  2-clause BSD license.  See LICENSE for full terms.
 - This is free software: you are free to change and redistribute it.
 - There is NO WARRANTY, to the extent permitted by law.
 -}

{-# LANGUAGE ForeignFunctionInterface, MagicHash, UnboxedTuples #-}
module Data.Floating.Types.Float (
    Float
) where

import Prelude hiding (Float, Double, Floating(..), RealFloat(..), Ord(..))
import Control.Applicative
import Control.Monad
import Data.Maybe
import Data.Ratio
import Data.Poset

import GHC.Exts hiding (Double(..), Float(..))
import GHC.Prim

import Foreign
import Foreign.C
import System.IO.Unsafe

import Data.Floating.Types
import Data.Floating.Types.Double
import Data.Floating.Classes
import Data.Floating.CMath

foreign import ccall unsafe "float_signum"
    float_signum :: CFloat -> CFloat
foreign import ccall unsafe "float_classify"
    float_classify :: CFloat -> CInt
foreign import ccall unsafe "float_compare"
    float_compare :: CFloat -> CFloat -> CInt
foreign import ccall unsafe "strtof"
    c_strtof :: CString -> Ptr CString -> IO CFloat

-- No point using a float-specific instance here, as the C code would just
-- promote the float to double anyway.
instance Show Float where
    show x = show (toFloating x :: Double)

instance Read Float where
    readsPrec _ s = unsafePerformIO . withCString s $ \str -> do
        alloca $ \endbuf -> do
            val <- toFloating <$> c_strtof str endbuf
            end <- peek endbuf
            if end == str
                then return []
                else peekCString end >>= \rem -> return [(val, rem)]

instance Eq Float where
    F# x == F# y = x `eqFloat#` y
    F# x /= F# y = x `neFloat#` y

instance Num Float where
    F# x + F# y = F# (x `plusFloat#`  y)
    F# x - F# y = F# (x `minusFloat#` y)
    F# x * F# y = F# (x `timesFloat#` y)
    negate (F# x) = F# (negateFloat# x)
    fromInteger = toFloating
    signum      = libmFloat float_signum
    abs         = libmFloat c_fabsf

instance Enum Float where
    pred x   = nextafter x (-infinity)
    succ x   = nextafter x infinity
    toEnum   = toFloating
    fromEnum = fromJust . toIntegral

instance Poset Float where
    compare a b = toEnum . fromIntegral $ float_compare a' b' where
        a' = toFloating a
        b' = toFloating b
    F# x <  F# y = x `ltFloat#` y
    F# x <= F# y = x `leFloat#` y
    F# x >= F# y = x `geFloat#` y
    F# x >  F# y = x `gtFloat#` y

instance Sortable Float where
    isOrdered = not . ((== FPNaN) . classify)
    max = libmFloat2 c_fmaxf
    min = libmFloat2 c_fminf

instance Fractional Float where
    (F# x) / (F# y) = F# (x `divideFloat#` y)
    fromRational = liftM2 (/)
        (fromInteger . numerator)
        (fromInteger . denominator)

-- | Internal function which discards the fractional component of a Float.
-- The results are meaningful only for finite input.
dropFrac :: Float -> Integer
dropFrac (F# x)
    | e >= 0    = s * 2^e
    | otherwise = quot s (2^(negate e))
    where
        !(# s#, e# #) = decodeFloat_Int# x
        s = toInteger (I# s#)
        e = I# e#

instance Roundable Float where
    toIntegral x = case classify x of
        FPInfinite -> Nothing
        FPNaN      -> Nothing
        otherwise  -> Just . fromInteger . dropFrac $ x
    floor    = libmFloat c_floorf
    ceiling  = libmFloat c_ceilf
    truncate = libmFloat c_truncf
    round    = libmFloat c_roundf

instance Floating Float where
    (F# x) ** (F# y) = F# (x `powerFloat#` y)
    sqrt (F# x) = F# (sqrtFloat# x)
    acos (F# x) = F# (acosFloat# x)
    asin (F# x) = F# (asinFloat# x)
    atan (F# x) = F# (atanFloat# x)
    cos  (F# x) = F# (cosFloat#  x)
    sin  (F# x) = F# (sinFloat#  x)
    tan  (F# x) = F# (tanFloat#  x)
    cosh (F# x) = F# (coshFloat# x)
    sinh (F# x) = F# (sinhFloat# x)
    tanh (F# x) = F# (tanhFloat# x)
    exp  (F# x) = F# (expFloat#  x)
    log  (F# x) = F# (logFloat#  x)
    acosh = libmFloat c_acoshf
    asinh = libmFloat c_asinhf
    atanh = libmFloat c_atanhf

instance RealFloat Float where
    fma       = libmFloat3 c_fmaf
    copysign  = libmFloat2 c_copysignf
    nextafter = libmFloat2 c_nextafterf
    fmod      = libmFloat2 c_fmodf
    frem      = libmFloat2 c_remainderf
    atan2     = libmFloat2 c_atan2f
    hypot     = libmFloat2 c_hypotf
    cbrt      = libmFloat  c_cbrtf
    exp2      = libmFloat  c_exp2f
    expm1     = libmFloat  c_expm1f
    log10     = libmFloat  c_log10f
    log1p     = libmFloat  c_log1pf
    log2      = libmFloat  c_log2f
    logb      = libmFloat  c_logbf
    erf       = libmFloat  c_erff
    erfc      = libmFloat  c_erfcf
    gamma     = libmFloat  c_tgammaf
    lgamma    = libmFloat  c_lgammaf
    nearbyint = libmFloat  c_nearbyintf
    rint      = libmFloat  c_rintf

instance PrimFloat Float where
    classify  = toEnum . fromIntegral . float_classify . toFloating