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.Helpers
  33 import Data.Floating.Types.Double
  34 import Data.Floating.Classes
  35 import Data.Floating.CMath
  36
  37 foreign import ccall unsafe "float_signum"
  38     float_signum :: CFloat -> CFloat
  39 foreign import ccall unsafe "float_classify"
  40     float_classify :: CFloat -> CInt
  41 foreign import ccall unsafe "float_compare"
  42     float_compare :: CFloat -> CFloat -> CInt
  43 foreign import ccall unsafe "strtof"
  44     c_strtof :: CString -> Ptr CString -> IO CFloat
  45
  46 -- No point using a float-specific instance here, as the C code would just
  47 -- promote the float to double anyway.
  48 instance Show Float where
  49     show x = show (toFloating x :: Double)
  50
  51 instance Read Float where
  52     readsPrec _ s = unsafePerformIO . withCString s $ \str -> do
  53         alloca $ \endbuf -> do
  54             val <- toFloating <$> c_strtof str endbuf
  55             end <- peek endbuf
  56             if end == str
  57                 then return []
  58                 else peekCString end >>= \rem -> return [(val, rem)]
  59
  60 instance Eq Float where
  61     F# x == F# y = x `eqFloat#` y
  62     F# x /= F# y = x `neFloat#` y
  63
  64 instance Num Float where
  65     F# x + F# y = F# (x `plusFloat#`  y)
  66     F# x - F# y = F# (x `minusFloat#` y)
  67     F# x * F# y = F# (x `timesFloat#` y)
  68     negate (F# x) = F# (negateFloat# x)
  69     fromInteger = toFloating
  70     signum      = libmFloat float_signum
  71     abs         = libmFloat c_fabsf
  72
  73 instance Enum Float where
  74     pred x   = nextafter x (-infinity)
  75     succ x   = nextafter x infinity
  76     toEnum   = toFloating
  77     fromEnum = fromJust . toIntegral
  78
  79 instance Poset Float where
  80     compare a b = toEnum . fromIntegral $ float_compare a' b' where
  81         a' = toFloating a
  82         b' = toFloating b
  83     F# x <  F# y = x `ltFloat#` y
  84     F# x <= F# y = x `leFloat#` y
  85     F# x >= F# y = x `geFloat#` y
  86     F# x >  F# y = x `gtFloat#` y
  87
  88 instance Sortable Float where
  89     isOrdered = not . ((== FPNaN) . classify)
  90     max = libmFloat2 c_fmaxf
  91     min = libmFloat2 c_fminf
  92
  93 instance Fractional Float where
  94     (F# x) / (F# y) = F# (x `divideFloat#` y)
  95     fromRational x = scalb (toFloating s) (negate e) where
  96         scale  = scaleRational (undefined :: Float)
  97         (s, e) = scale x
  98
  99 -- | Internal function which discards the fractional component of a Float.
 100 -- The results are meaningful only for finite input.
 101 dropFrac :: Float -> Integer
 102 dropFrac (F# x)
 103     | e >= 0    = s * 2^e
 104     | otherwise = quot s (2^(negate e))
 105     where
 106         !(# s#, e# #) = decodeFloat_Int# x
 107         s = toInteger (I# s#)
 108         e = I# e#
 109
 110 instance Roundable Float where
 111     toIntegral x = case classify x of
 112         FPInfinite -> Nothing
 113         FPNaN      -> Nothing
 114         otherwise  -> Just . fromInteger . dropFrac $ x
 115     floor    = libmFloat c_floorf
 116     ceiling  = libmFloat c_ceilf
 117     truncate = libmFloat c_truncf
 118     round    = libmFloat c_roundf
 119
 120 instance Floating Float where
 121     (F# x) ** (F# y) = F# (x `powerFloat#` y)
 122     sqrt (F# x) = F# (sqrtFloat# x)
 123     acos (F# x) = F# (acosFloat# x)
 124     asin (F# x) = F# (asinFloat# x)
 125     atan (F# x) = F# (atanFloat# x)
 126     cos  (F# x) = F# (cosFloat#  x)
 127     sin  (F# x) = F# (sinFloat#  x)
 128     tan  (F# x) = F# (tanFloat#  x)
 129     cosh (F# x) = F# (coshFloat# x)
 130     sinh (F# x) = F# (sinhFloat# x)
 131     tanh (F# x) = F# (tanhFloat# x)
 132     exp  (F# x) = F# (expFloat#  x)
 133     log  (F# x) = F# (logFloat#  x)
 134     acosh = libmFloat c_acoshf
 135     asinh = libmFloat c_asinhf
 136     atanh = libmFloat c_atanhf
 137
 138 instance RealFloat Float where
 139     fma       = libmFloat3 c_fmaf
 140     copysign  = libmFloat2 c_copysignf
 141     nextafter = libmFloat2 c_nextafterf
 142     fmod      = libmFloat2 c_fmodf
 143     frem      = libmFloat2 c_remainderf
 144     atan2     = libmFloat2 c_atan2f
 145     hypot     = libmFloat2 c_hypotf
 146     cbrt      = libmFloat  c_cbrtf
 147     exp2      = libmFloat  c_exp2f
 148     expm1     = libmFloat  c_expm1f
 149     log10     = libmFloat  c_log10f
 150     log1p     = libmFloat  c_log1pf
 151     log2      = libmFloat  c_log2f
 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     floatRange     = const (FLT_MIN_EXP_VAL, FLT_MAX_EXP_VAL)
 163     classify       = toEnum . fromIntegral . float_classify . toFloating
 164     logb           = libmFloat c_logbf
 165     scalb x e      = toFloating $ c_scalblnf (toFloating x) (fromIntegral e)