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 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     compare a b = toEnum . fromIntegral $ float_compare a' b' where
  74         a' = toFloating a
  75         b' = toFloating b
  76     F# x <  F# y = x `ltFloat#` y
  77     F# x <= F# y = x `leFloat#` y
  78     F# x >= F# y = x `geFloat#` y
  79     F# x >  F# y = x `gtFloat#` y
  80
  81 instance Sortable Float where
  82     isOrdered = not . ((== FPNaN) . classify)
  83     max = libmFloat2 c_fmaxf
  84     min = libmFloat2 c_fminf
  85
  86 instance Fractional Float where
  87     (F# x) / (F# y) = F# (x `divideFloat#` y)
  88     fromRational x = scalb (toFloating s) (negate e) where
  89         scale  = scaleRational (undefined :: Float)
  90         (s, e) = scale x
  91
  92 -- | Internal function which discards the fractional component of a Float.
  93 -- The results are meaningful only for finite input.
  94 dropFrac :: Float -> Integer
  95 dropFrac (F# x)
  96     | e >= 0    = s * 2^e
  97     | otherwise = quot s (2^(negate e))
  98     where
  99         !(# s#, e# #) = decodeFloat_Int# x
 100         s = toInteger (I# s#)
 101         e = I# e#
 102
 103 instance Roundable Float where
 104     toIntegral x = case classify x of
 105         FPInfinite -> Nothing
 106         FPNaN      -> Nothing
 107         _          -> Just . fromInteger . dropFrac $ x
 108     floor    = libmFloat c_floorf
 109     ceiling  = libmFloat c_ceilf
 110     truncate = libmFloat c_truncf
 111     round    = libmFloat c_roundf
 112
 113 instance Floating Float where
 114     (F# x) ** (F# y) = F# (x `powerFloat#` y)
 115     sqrt (F# x) = F# (sqrtFloat# x)
 116     acos (F# x) = F# (acosFloat# x)
 117     asin (F# x) = F# (asinFloat# x)
 118     atan (F# x) = F# (atanFloat# x)
 119     cos  (F# x) = F# (cosFloat#  x)
 120     sin  (F# x) = F# (sinFloat#  x)
 121     tan  (F# x) = F# (tanFloat#  x)
 122     cosh (F# x) = F# (coshFloat# x)
 123     sinh (F# x) = F# (sinhFloat# x)
 124     tanh (F# x) = F# (tanhFloat# x)
 125     exp  (F# x) = F# (expFloat#  x)
 126     log  (F# x) = F# (logFloat#  x)
 127     acosh = libmFloat c_acoshf
 128     asinh = libmFloat c_asinhf
 129     atanh = libmFloat c_atanhf
 130
 131 instance RealFloat Float where
 132     fma       = libmFloat3 c_fmaf
 133     copysign  = libmFloat2 c_copysignf
 134     nextafter = libmFloat2 c_nextafterf
 135     fmod      = libmFloat2 c_fmodf
 136     frem      = libmFloat2 c_remainderf
 137     atan2     = libmFloat2 c_atan2f
 138     hypot     = libmFloat2 c_hypotf
 139     cbrt      = libmFloat  c_cbrtf
 140     exp2      = libmFloat  c_exp2f
 141     expm1     = libmFloat  c_expm1f
 142     log10     = libmFloat  c_log10f
 143     log1p     = libmFloat  c_log1pf
 144     log2      = libmFloat  c_log2f
 145     erf       = libmFloat  c_erff
 146     erfc      = libmFloat  c_erfcf
 147     gamma     = libmFloat  c_tgammaf
 148     lgamma    = libmFloat  c_lgammaf
 149     nearbyint = libmFloat  c_nearbyintf
 150     rint      = libmFloat  c_rintf
 151
 152 instance PrimFloat Float where
 153     floatRadix     = const FLT_RADIX_VAL
 154     floatPrecision = const FLT_MANT_DIG_VAL
 155     floatRange     = const (FLT_MIN_EXP_VAL, FLT_MAX_EXP_VAL)
 156     classify       = toEnum . fromIntegral . float_classify . toFloating
 157     logb           = libmFloat c_logbf
 158     scalb x e      = toFloating $ c_scalblnf (toFloating x) (fromIntegral e)