Data/Floating/Float.hs

   1 {-
   2  - Copyright (C) 2010 Nick Bowler.
   3  -
   4  - License BSD2:  2-clause BSD license.  See LICENSE for full terms.
   5  - This is free software: you are free to change and redistribute it.
   6  - There is NO WARRANTY, to the extent permitted by law.
   7  -}
   8
   9 {-# LANGUAGE ForeignFunctionInterface, MagicHash, UnboxedTuples #-}
  10 module Data.Floating.Float (
  11     Float
  12 ) where
  13
  14 import Prelude hiding (Float, Double, Floating(..), RealFloat(..), Ord(..))
  15 import Control.Applicative
  16 import Control.Monad
  17 import Data.Maybe
  18 import Data.Ratio
  19 import Data.Poset
  20
  21 import GHC.Exts hiding (Double(..), Float(..))
  22 import GHC.Prim
  23
  24 import Foreign
  25 import Foreign.C
  26 import System.IO.Unsafe
  27
  28 import Data.Floating.Types
  29 import Data.Floating.Double
  30 import Data.Floating.Classes
  31 import Data.Floating.CMath
  32
  33 foreign import ccall unsafe "float_signum"
  34     float_signum :: CFloat -> CFloat
  35 foreign import ccall unsafe "float_classify"
  36     float_classify :: CFloat -> CInt
  37 foreign import ccall unsafe "float_compare"
  38     float_compare :: CFloat -> CFloat -> CInt
  39 foreign import ccall unsafe "strtof"
  40     c_strtof :: CString -> Ptr CString -> IO CFloat
  41
  42 -- No point using a float-specific instance here, as the C code would just
  43 -- promote the float to double anyway.
  44 instance Show Float where
  45     show x = show (toFloating x :: Double)
  46
  47 instance Read Float where
  48     readsPrec _ s = unsafePerformIO . withCString s $ \str -> do
  49         alloca $ \endbuf -> do
  50             val <- toFloating <$> c_strtof str endbuf
  51             end <- peek endbuf
  52             if end == str
  53                 then return []
  54                 else peekCString end >>= \rem -> return [(val, rem)]
  55
  56 instance Eq Float where
  57     F# x == F# y = x `eqFloat#` y
  58     F# x /= F# y = x `neFloat#` y
  59
  60 instance Num Float where
  61     F# x + F# y = F# (x `plusFloat#`  y)
  62     F# x - F# y = F# (x `minusFloat#` y)
  63     F# x * F# y = F# (x `timesFloat#` y)
  64     negate (F# x) = F# (negateFloat# x)
  65     fromInteger = toFloating
  66     signum      = libmFloat float_signum
  67     abs         = libmFloat c_fabsf
  68
  69 instance Enum Float where
  70     pred x   = nextafter x (-infinity)
  71     succ x   = nextafter x infinity
  72     toEnum   = toFloating
  73     fromEnum = fromJust . toIntegral
  74
  75 instance Poset Float where
  76     compare a b = toEnum . fromIntegral $ float_compare a' b' where
  77         a' = toFloating a
  78         b' = toFloating b
  79     F# x <  F# y = x `ltFloat#` y
  80     F# x <= F# y = x `leFloat#` y
  81     F# x >= F# y = x `geFloat#` y
  82     F# x >  F# y = x `gtFloat#` y
  83
  84 instance Sortable Float where
  85     isOrdered = not . ((== FPNaN) . classify)
  86     max = libmFloat2 c_fmaxf
  87     min = libmFloat2 c_fminf
  88
  89 instance Fractional Float where
  90     (F# x) / (F# y) = F# (x `divideFloat#` y)
  91     fromRational = liftM2 (/)
  92         (fromInteger . numerator)
  93         (fromInteger . denominator)
  94
  95 -- | Internal function which discards the fractional component of a Float.
  96 -- The results are meaningful only for finite input.
  97 dropFrac :: Float -> Integer
  98 dropFrac (F# x)
  99     | e >= 0    = s * 2^e
 100     | otherwise = quot s (2^(negate e))
 101     where
 102         !(# s#, e# #) = decodeFloat_Int# x
 103         s = toInteger (I# s#)
 104         e = I# e#
 105
 106 instance Roundable Float where
 107     toIntegral x = case classify x of
 108         FPInfinite -> Nothing
 109         FPNaN      -> Nothing
 110         otherwise  -> Just . fromInteger . dropFrac $ x
 111     floor    = libmFloat c_floorf
 112     ceiling  = libmFloat c_ceilf
 113     truncate = libmFloat c_truncf
 114     round    = libmFloat c_roundf
 115
 116 instance Floating Float where
 117     (F# x) ** (F# y) = F# (x `powerFloat#` y)
 118     sqrt (F# x) = F# (sqrtFloat# x)
 119     acos (F# x) = F# (acosFloat# x)
 120     asin (F# x) = F# (asinFloat# x)
 121     atan (F# x) = F# (atanFloat# x)
 122     cos  (F# x) = F# (cosFloat#  x)
 123     sin  (F# x) = F# (sinFloat#  x)
 124     tan  (F# x) = F# (tanFloat#  x)
 125     cosh (F# x) = F# (coshFloat# x)
 126     sinh (F# x) = F# (sinhFloat# x)
 127     tanh (F# x) = F# (tanhFloat# x)
 128     exp  (F# x) = F# (expFloat#  x)
 129     log  (F# x) = F# (logFloat#  x)
 130     acosh = libmFloat c_acoshf
 131     asinh = libmFloat c_asinhf
 132     atanh = libmFloat c_atanhf
 133
 134 instance RealFloat Float where
 135     fma       = libmFloat3 c_fmaf
 136     copysign  = libmFloat2 c_copysignf
 137     nextafter = libmFloat2 c_nextafterf
 138     fmod      = libmFloat2 c_fmodf
 139     frem      = libmFloat2 c_remainderf
 140     atan2     = libmFloat2 c_atan2f
 141     hypot     = libmFloat2 c_hypotf
 142     cbrt      = libmFloat  c_cbrtf
 143     exp2      = libmFloat  c_exp2f
 144     expm1     = libmFloat  c_expm1f
 145     log10     = libmFloat  c_log10f
 146     log1p     = libmFloat  c_log1pf
 147     log2      = libmFloat  c_log2f
 148     logb      = libmFloat  c_logbf
 149     erf       = libmFloat  c_erff
 150     erfc      = libmFloat  c_erfcf
 151     lgamma    = libmFloat  c_lgammaf
 152     tgamma    = libmFloat  c_tgammaf
 153     nearbyint = libmFloat  c_nearbyintf
 154     rint      = libmFloat  c_rintf
 155
 156 instance PrimFloat Float where
 157     classify  = toEnum . fromIntegral . float_classify . toFloating