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