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)
   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
  34 libmDouble :: (CDouble -> CDouble) -> Double -> Double
  35 libmDouble f a = toFloating $ f (toFloating a)
  36
  37 libmDouble2 :: (CDouble -> CDouble -> CDouble) -> Double -> Double -> Double
  38 libmDouble2 f a b = toFloating $ f (toFloating a) (toFloating b)
  39
  40 instance Show Double where
  41     show x = unsafePerformIO $ do
  42         size <- double_to_string nullPtr (toFloating x)
  43         allocaArray0 (fromIntegral size) $ \buf -> do
  44             double_to_string buf (toFloating x)
  45             peekCString buf
  46
  47 instance Read Double where
  48     readsPrec _ s = unsafePerformIO . withCString s $ \str -> do
  49         alloca $ \endbuf -> do
  50             val <- toFloating <$> c_strtod str endbuf
  51             end <- peek endbuf
  52             if end == str
  53                 then return []
  54                 else peekCString end >>= \rem -> return [(val, rem)]
  55
  56 instance Eq Double where
  57     (D# x) == (D# y) = x ==## y
  58     (D# x) /= (D# y) = x /=## y
  59
  60 instance Num Double where
  61     (D# x) + (D# y) = D# (x +## y)
  62     (D# x) - (D# y) = D# (x -## y)
  63     (D# x) * (D# y) = D# (x *## y)
  64     negate (D# x) = D# (negateDouble# x)
  65     fromInteger x = D# (doubleFromInteger x)
  66     signum = libmDouble double_signum
  67     abs    = libmDouble c_fabs
  68
  69 instance Fractional Double where
  70     (D# x) / (D# y) = D# (x /## y)
  71     fromRational = liftM2 (/)
  72         (fromInteger . numerator)
  73         (fromInteger . denominator)
  74
  75 instance Floating Double where
  76     (D# x) ** (D# y) = D# (x **## y)
  77     copysign = libmDouble2 c_copysign