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.Poset
  23
  24 import GHC.Exts hiding (Float(..))
  25 import GHC.Prim
  26
  27 import Foreign
  28 import Foreign.C
  29 import System.IO.Unsafe
  30
  31 import Data.Floating.Types.Core
  32 import Data.Floating.Helpers
  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 instance Show Float where
  45     show = formatDouble 'a' (-1) . toFloating
  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 x = scalb (toFloating s) (negate e) where
  92         scale  = scaleRational (undefined :: Float)
  93         (s, e) = scale x
  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     erf       = libmFloat  c_erff
 149     erfc      = libmFloat  c_erfcf
 150     gamma     = libmFloat  c_tgammaf
 151     lgamma    = libmFloat  c_lgammaf
 152     nearbyint = libmFloat  c_nearbyintf
 153     rint      = libmFloat  c_rintf
 154
 155 instance PrimFloat Float where
 156     floatRadix     = const FLT_RADIX_VAL
 157     floatPrecision = const FLT_MANT_DIG_VAL
 158     floatRange     = const (FLT_MIN_EXP_VAL, FLT_MAX_EXP_VAL)
 159     classify       = toEnum . fromIntegral . float_classify . toFloating
 160     logb           = libmFloat c_logbf
 161     scalb x e      = toFloating $ c_scalblnf (toFloating x) (fromIntegral e)