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_to_string"
  23     double_to_string :: 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 "hypot"
  38     c_hypot :: CDouble -> CDouble -> CDouble
  39 foreign import ccall unsafe "cbrt"
  40     c_cbrt :: CDouble -> CDouble
  41 foreign import ccall unsafe "atan2"
  42     c_atan2 :: CDouble -> CDouble -> CDouble
  43 foreign import ccall unsafe "acosh"
  44     c_acosh :: CDouble -> CDouble
  45 foreign import ccall unsafe "asinh"
  46     c_asinh :: CDouble -> CDouble
  47 foreign import ccall unsafe "atanh"
  48     c_atanh :: CDouble -> CDouble
  49 foreign import ccall unsafe "exp2"
  50     c_exp2 :: CDouble -> CDouble
  51 foreign import ccall unsafe "expm1"
  52     c_expm1 :: CDouble -> CDouble
  53 foreign import ccall unsafe "log10"
  54     c_log10 :: CDouble -> CDouble
  55 foreign import ccall unsafe "log1p"
  56     c_log1p :: CDouble -> CDouble
  57 foreign import ccall unsafe "log2"
  58     c_log2 :: CDouble -> CDouble
  59 foreign import ccall unsafe "logb"
  60     c_logb :: CDouble -> CDouble
  61 foreign import ccall unsafe "erf"
  62     c_erf :: CDouble -> CDouble
  63 foreign import ccall unsafe "erfc"
  64     c_erfc :: CDouble -> CDouble
  65 foreign import ccall unsafe "lgamma"
  66     c_lgamma :: CDouble -> CDouble
  67 foreign import ccall unsafe "tgamma"
  68     c_tgamma :: CDouble -> CDouble
  69
  70 libmDouble :: (CDouble -> CDouble) -> Double -> Double
  71 libmDouble f a = toFloating $ f (toFloating a)
  72
  73 libmDouble2 :: (CDouble -> CDouble -> CDouble) -> Double -> Double -> Double
  74 libmDouble2 f a b = toFloating $ f (toFloating a) (toFloating b)
  75
  76 instance Show Double where
  77     show x = unsafePerformIO $ do
  78         size <- double_to_string nullPtr (toFloating x)
  79         allocaArray0 (fromIntegral size) $ \buf -> do
  80             double_to_string buf (toFloating x)
  81             peekCString buf
  82
  83 instance Read Double where
  84     readsPrec _ s = unsafePerformIO . withCString s $ \str -> do
  85         alloca $ \endbuf -> do
  86             val <- toFloating <$> c_strtod str endbuf
  87             end <- peek endbuf
  88             if end == str
  89                 then return []
  90                 else peekCString end >>= \rem -> return [(val, rem)]
  91
  92 instance Eq Double where
  93     (D# x) == (D# y) = x ==## y
  94     (D# x) /= (D# y) = x /=## y
  95
  96 instance Num Double where
  97     (D# x) + (D# y) = D# (x +## y)
  98     (D# x) - (D# y) = D# (x -## y)
  99     (D# x) * (D# y) = D# (x *## y)
 100     negate (D# x) = D# (negateDouble# x)
 101     fromInteger = toFloating
 102     signum      = libmDouble double_signum
 103     abs         = libmDouble c_fabs
 104
 105 instance Fractional Double where
 106     (D# x) / (D# y) = D# (x /## y)
 107     fromRational = liftM2 (/)
 108         (fromInteger . numerator)
 109         (fromInteger . denominator)
 110
 111 instance Floating Double where
 112     (D# x) ** (D# y) = D# (x **## y)
 113     sqrt (D# x) = D# (sqrtDouble# x)
 114     acos (D# x) = D# (acosDouble# x)
 115     asin (D# x) = D# (asinDouble# x)
 116     atan (D# x) = D# (atanDouble# x)
 117     cos  (D# x) = D# (cosDouble#  x)
 118     sin  (D# x) = D# (sinDouble#  x)
 119     tan  (D# x) = D# (tanDouble#  x)
 120     cosh (D# x) = D# (coshDouble#  x)
 121     sinh (D# x) = D# (sinhDouble#  x)
 122     tanh (D# x) = D# (tanhDouble#  x)
 123     exp  (D# x) = D# (expDouble#  x)
 124     log  (D# x) = D# (logDouble#  x)
 125     acosh = libmDouble c_acosh
 126     asinh = libmDouble c_asinh
 127     atanh = libmDouble c_atanh
 128
 129 instance RealFloat Double where
 130     copysign  = libmDouble2 c_copysign
 131     nextafter = libmDouble2 c_nextafter
 132     atan2     = libmDouble2 c_atan2
 133     hypot     = libmDouble2 c_hypot
 134     cbrt      = libmDouble  c_cbrt
 135     exp2      = libmDouble  c_exp2
 136     expm1     = libmDouble  c_expm1
 137     log10     = libmDouble  c_log10
 138     log1p     = libmDouble  c_log1p
 139     log2      = libmDouble  c_log2
 140     logb      = libmDouble  c_logb
 141     erf       = libmDouble  c_erf
 142     erfc      = libmDouble  c_erfc
 143     lgamma    = libmDouble  c_lgamma
 144     tgamma    = libmDouble  c_tgamma
 145     classify  = toEnum . fromIntegral . double_classify . toFloating