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, Floating(..), RealFloat(..), Ord(..))
  18 import Control.Applicative
  19 import Control.Monad
  20 import Data.Maybe
  21 import Data.Ratio
  22 import Data.Roundable
  23 import Data.Poset
  24
  25 import GHC.Exts hiding (Float(..))
  26 import GHC.Prim
  27
  28 import Foreign
  29 import Foreign.C
  30 import System.IO.Unsafe
  31
  32 import Data.Floating.Types.Core
  33 import Data.Floating.Helpers
  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 instance Show Float where
  46     show = formatDouble 'a' (-1) . toFloating
  47
  48 instance Read Float where
  49     readsPrec _ s = unsafePerformIO . withCString s $ \str -> do
  50         alloca $ \endbuf -> do
  51             val <- toFloating <$> c_strtof str endbuf
  52             end <- peek endbuf
  53             if end == str
  54                 then return []
  55                 else peekCString end >>= \rem -> return [(val, rem)]
  56
  57 instance Eq Float where
  58     F# x == F# y = x `eqFloat#` y
  59     F# x /= F# y = x `neFloat#` y
  60
  61 instance Num Float where
  62     F# x + F# y = F# (x `plusFloat#`  y)
  63     F# x - F# y = F# (x `minusFloat#` y)
  64     F# x * F# y = F# (x `timesFloat#` y)
  65     negate (F# x) = F# (negateFloat# x)
  66     fromInteger = toFloating
  67     signum      = libmFloat float_signum
  68     abs         = libmFloat c_fabsf
  69
  70 instance Enum Float where
  71     pred x   = nextafter x (-infinity)
  72     succ x   = nextafter x infinity
  73     toEnum   = toFloating
  74     fromEnum = fromJust . toIntegral
  75
  76 instance Poset Float where
  77     compare a b = toEnum . fromIntegral $ float_compare a' b' where
  78         a' = toFloating a
  79         b' = toFloating b
  80     F# x <  F# y = x `ltFloat#` y
  81     F# x <= F# y = x `leFloat#` y
  82     F# x >= F# y = x `geFloat#` y
  83     F# x >  F# y = x `gtFloat#` y
  84
  85 instance Sortable Float where
  86     isOrdered = not . ((== FPNaN) . classify)
  87     max = libmFloat2 c_fmaxf
  88     min = libmFloat2 c_fminf
  89
  90 instance Fractional Float where
  91     (F# x) / (F# y) = F# (x `divideFloat#` y)
  92     fromRational x = scalb (toFloating s) (negate e) where
  93         scale  = scaleRational (undefined :: Float)
  94         (s, e) = scale x
  95
  96 -- | Internal function which discards the fractional component of a Float.
  97 -- The results are meaningful only for finite input.
  98 dropFrac :: Float -> Integer
  99 dropFrac (F# x)
 100     | e >= 0    = s * 2^e
 101     | otherwise = quot s (2^(negate e))
 102     where
 103         !(# s#, e# #) = decodeFloat_Int# x
 104         s = toInteger (I# s#)
 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     erf       = libmFloat  c_erff
 150     erfc      = libmFloat  c_erfcf
 151     gamma     = libmFloat  c_tgammaf
 152     lgamma    = libmFloat  c_lgammaf
 153     nearbyint = libmFloat  c_nearbyintf
 154     rint      = libmFloat  c_rintf
 155
 156 instance PrimFloat Float where
 157     floatRadix     = const FLT_RADIX_VAL
 158     floatPrecision = const FLT_MANT_DIG_VAL
 159     floatRange     = const (FLT_MIN_EXP_VAL, FLT_MAX_EXP_VAL)
 160     classify       = toEnum . fromIntegral . float_classify . toFloating
 161     logb           = libmFloat c_logbf
 162     scalb x e      = toFloating $ c_scalblnf (toFloating x) (fromIntegral e)