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 "strtod"
  27     c_strtod :: CString -> Ptr CString -> IO CDouble
  28
  29 foreign import ccall unsafe "fabs"
  30     c_fabs :: CDouble -> CDouble
  31 foreign import ccall unsafe "copysign"
  32     c_copysign :: CDouble -> CDouble -> CDouble
  33 foreign import ccall unsafe "atan2"
  34     c_atan2 :: CDouble -> CDouble -> CDouble
  35 foreign import ccall unsafe "exp2"
  36     c_exp2 :: CDouble -> CDouble
  37 foreign import ccall unsafe "expm1"
  38     c_expm1 :: CDouble -> CDouble
  39 foreign import ccall unsafe "log10"
  40     c_log10 :: CDouble -> CDouble
  41 foreign import ccall unsafe "log1p"
  42     c_log1p :: CDouble -> CDouble
  43 foreign import ccall unsafe "log2"
  44     c_log2 :: CDouble -> CDouble
  45 foreign import ccall unsafe "logb"
  46     c_logb :: CDouble -> CDouble
  47
  48 libmDouble :: (CDouble -> CDouble) -> Double -> Double
  49 libmDouble f a = toFloating $ f (toFloating a)
  50
  51 libmDouble2 :: (CDouble -> CDouble -> CDouble) -> Double -> Double -> Double
  52 libmDouble2 f a b = toFloating $ f (toFloating a) (toFloating b)
  53
  54 instance Show Double where
  55     show x = unsafePerformIO $ do
  56         size <- double_to_string nullPtr (toFloating x)
  57         allocaArray0 (fromIntegral size) $ \buf -> do
  58             double_to_string buf (toFloating x)
  59             peekCString buf
  60
  61 instance Read Double where
  62     readsPrec _ s = unsafePerformIO . withCString s $ \str -> do
  63         alloca $ \endbuf -> do
  64             val <- toFloating <$> c_strtod str endbuf
  65             end <- peek endbuf
  66             if end == str
  67                 then return []
  68                 else peekCString end >>= \rem -> return [(val, rem)]
  69
  70 instance Eq Double where
  71     (D# x) == (D# y) = x ==## y
  72     (D# x) /= (D# y) = x /=## y
  73
  74 instance Num Double where
  75     (D# x) + (D# y) = D# (x +## y)
  76     (D# x) - (D# y) = D# (x -## y)
  77     (D# x) * (D# y) = D# (x *## y)
  78     negate (D# x) = D# (negateDouble# x)
  79     fromInteger x = D# (doubleFromInteger x)
  80     signum = libmDouble double_signum
  81     abs    = libmDouble c_fabs
  82
  83 instance Fractional Double where
  84     (D# x) / (D# y) = D# (x /## y)
  85     fromRational = liftM2 (/)
  86         (fromInteger . numerator)
  87         (fromInteger . denominator)
  88
  89 instance Floating Double where
  90     (D# x) ** (D# y) = D# (x **## y)
  91     acos (D# x) = D# (acosDouble# x)
  92     asin (D# x) = D# (asinDouble# x)
  93     atan (D# x) = D# (atanDouble# x)
  94     cos  (D# x) = D# (cosDouble#  x)
  95     sin  (D# x) = D# (sinDouble#  x)
  96     tan  (D# x) = D# (tanDouble#  x)
  97     exp  (D# x) = D# (expDouble#  x)
  98     log  (D# x) = D# (logDouble#  x)
  99
 100 instance RealFloat Double where
 101     copysign = libmDouble2 c_copysign
 102     atan2    = libmDouble2 c_atan2
 103     exp2     = libmDouble  c_exp2
 104     expm1    = libmDouble  c_expm1
 105     log10    = libmDouble  c_log10
 106     log1p    = libmDouble  c_log1p
 107     log2     = libmDouble  c_log2
 108     logb     = libmDouble  c_logb