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