Data/Floating/Float.hs

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