Data/Floating/Double.hs

   1 {-# INCLUDE stdlib.h math.h cfloat.h #-}
   2 {-# LANGUAGE ForeignFunctionInterface, MagicHash #-}
   3 module Data.Floating.Double (
   4     Double
   5 ) where
   6
   7 import Prelude hiding (Double, Floating(..), RealFloat(..))
   8 import Control.Applicative
   9 import Control.Monad
  10 import Data.Ratio
  11
  12 import GHC.Integer
  13 import GHC.Prim
  14
  15 import Foreign
  16 import Foreign.C
  17 import System.IO.Unsafe
  18
  19 import Data.Floating.Types
  20 import Data.Floating.Classes
  21
  22 foreign import ccall unsafe "double_format"
  23     double_format :: CString -> CString -> CDouble -> IO CInt
  24 foreign import ccall unsafe "double_signum"
  25     double_signum :: CDouble -> CDouble
  26 foreign import ccall unsafe "double_classify"
  27     double_classify :: CDouble -> CInt
  28 foreign import ccall unsafe "strtod"
  29     c_strtod :: CString -> Ptr CString -> IO CDouble
  30
  31 foreign import ccall unsafe "fabs"
  32     c_fabs :: CDouble -> CDouble
  33 foreign import ccall unsafe "copysign"
  34     c_copysign :: CDouble -> CDouble -> CDouble
  35 foreign import ccall unsafe "nextafter"
  36     c_nextafter :: CDouble -> CDouble -> CDouble
  37 foreign import ccall unsafe "fmod"
  38     c_fmod :: CDouble -> CDouble -> CDouble
  39 foreign import ccall unsafe "remainder"
  40     c_remainder :: CDouble -> CDouble -> CDouble
  41 foreign import ccall unsafe "hypot"
  42     c_hypot :: CDouble -> CDouble -> CDouble
  43 foreign import ccall unsafe "cbrt"
  44     c_cbrt :: CDouble -> CDouble
  45 foreign import ccall unsafe "atan2"
  46     c_atan2 :: CDouble -> CDouble -> CDouble
  47 foreign import ccall unsafe "acosh"
  48     c_acosh :: CDouble -> CDouble
  49 foreign import ccall unsafe "asinh"
  50     c_asinh :: CDouble -> CDouble
  51 foreign import ccall unsafe "atanh"
  52     c_atanh :: CDouble -> CDouble
  53 foreign import ccall unsafe "exp2"
  54     c_exp2 :: CDouble -> CDouble
  55 foreign import ccall unsafe "expm1"
  56     c_expm1 :: CDouble -> CDouble
  57 foreign import ccall unsafe "log10"
  58     c_log10 :: CDouble -> CDouble
  59 foreign import ccall unsafe "log1p"
  60     c_log1p :: CDouble -> CDouble
  61 foreign import ccall unsafe "log2"
  62     c_log2 :: CDouble -> CDouble
  63 foreign import ccall unsafe "logb"
  64     c_logb :: CDouble -> CDouble
  65 foreign import ccall unsafe "erf"
  66     c_erf :: CDouble -> CDouble
  67 foreign import ccall unsafe "erfc"
  68     c_erfc :: CDouble -> CDouble
  69 foreign import ccall unsafe "lgamma"
  70     c_lgamma :: CDouble -> CDouble
  71 foreign import ccall unsafe "tgamma"
  72     c_tgamma :: CDouble -> CDouble
  73
  74 libmDouble :: (CDouble -> CDouble) -> Double -> Double
  75 libmDouble f a = toFloating $ f (toFloating a)
  76
  77 libmDouble2 :: (CDouble -> CDouble -> CDouble) -> Double -> Double -> Double
  78 libmDouble2 f a b = toFloating $ f (toFloating a) (toFloating b)
  79
  80 instance Show Double where
  81     show x = unsafePerformIO . withCString "%a" $ \fmt -> do
  82         size <- double_format nullPtr fmt (toFloating x)
  83         allocaArray0 (fromIntegral size) $ \buf -> do
  84             double_format buf fmt (toFloating x)
  85             peekCString buf
  86
  87 instance Read Double where
  88     readsPrec _ s = unsafePerformIO . withCString s $ \str -> do
  89         alloca $ \endbuf -> do
  90             val <- toFloating <$> c_strtod str endbuf
  91             end <- peek endbuf
  92             if end == str
  93                 then return []
  94                 else peekCString end >>= \rem -> return [(val, rem)]
  95
  96 instance Eq Double where
  97     (D# x) == (D# y) = x ==## y
  98     (D# x) /= (D# y) = x /=## y
  99
 100 instance Num Double where
 101     (D# x) + (D# y) = D# (x +## y)
 102     (D# x) - (D# y) = D# (x -## y)
 103     (D# x) * (D# y) = D# (x *## y)
 104     negate (D# x) = D# (negateDouble# x)
 105     fromInteger = toFloating
 106     signum      = libmDouble double_signum
 107     abs         = libmDouble c_fabs
 108
 109 instance Fractional Double where
 110     (D# x) / (D# y) = D# (x /## y)
 111     fromRational = liftM2 (/)
 112         (fromInteger . numerator)
 113         (fromInteger . denominator)
 114
 115 instance Floating Double where
 116     (D# x) ** (D# y) = D# (x **## y)
 117     sqrt (D# x) = D# (sqrtDouble# x)
 118     acos (D# x) = D# (acosDouble# x)
 119     asin (D# x) = D# (asinDouble# x)
 120     atan (D# x) = D# (atanDouble# x)
 121     cos  (D# x) = D# (cosDouble#  x)
 122     sin  (D# x) = D# (sinDouble#  x)
 123     tan  (D# x) = D# (tanDouble#  x)
 124     cosh (D# x) = D# (coshDouble#  x)
 125     sinh (D# x) = D# (sinhDouble#  x)
 126     tanh (D# x) = D# (tanhDouble#  x)
 127     exp  (D# x) = D# (expDouble#  x)
 128     log  (D# x) = D# (logDouble#  x)
 129     acosh = libmDouble c_acosh
 130     asinh = libmDouble c_asinh
 131     atanh = libmDouble c_atanh
 132
 133 instance RealFloat Double where
 134     copysign  = libmDouble2 c_copysign
 135     nextafter = libmDouble2 c_nextafter
 136     fmod      = libmDouble2 c_fmod
 137     frem      = libmDouble2 c_remainder
 138     atan2     = libmDouble2 c_atan2
 139     hypot     = libmDouble2 c_hypot
 140     cbrt      = libmDouble  c_cbrt
 141     exp2      = libmDouble  c_exp2
 142     expm1     = libmDouble  c_expm1
 143     log10     = libmDouble  c_log10
 144     log1p     = libmDouble  c_log1p
 145     log2      = libmDouble  c_log2
 146     logb      = libmDouble  c_logb
 147     erf       = libmDouble  c_erf
 148     erfc      = libmDouble  c_erfc
 149     lgamma    = libmDouble  c_lgamma
 150     tgamma    = libmDouble  c_tgamma
 151     classify  = toEnum . fromIntegral . double_classify . toFloating