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