Data/Floating/Double.hs

   1 {-
   2  - Copyright (C) 2009 Nick Bowler.
   3  -
   4  - License BSD2:  2-clause BSD license.  See LICENSE for full terms.
   5  - This is free software: you are free to change and redistribute it.
   6  - There is NO WARRANTY, to the extent permitted by law.
   7  -}
   8
   9 {-# LANGUAGE ForeignFunctionInterface, MagicHash #-}
  10 {-# INCLUDE <stdlib.h> <math.h> "cfloat.h" #-}
  11 module Data.Floating.Double (
  12     Double
  13 ) where
  14
  15 import Prelude hiding (Double, Floating(..), RealFloat(..))
  16 import Control.Applicative
  17 import Control.Monad
  18 import Data.Ratio
  19 import Data.Poset
  20
  21 import GHC.Integer
  22 import GHC.Prim
  23
  24 import Foreign
  25 import Foreign.C
  26 import System.IO.Unsafe
  27
  28 import Data.Floating.Types
  29 import Data.Floating.Classes
  30 import Data.Floating.CMath
  31
  32 foreign import ccall unsafe "double_format"
  33     double_format :: CString -> CString -> CDouble -> IO CInt
  34 foreign import ccall unsafe "double_signum"
  35     double_signum :: CDouble -> CDouble
  36 foreign import ccall unsafe "double_classify"
  37     double_classify :: CDouble -> CInt
  38 foreign import ccall unsafe "double_compare"
  39     double_compare :: CDouble -> CDouble -> CInt
  40 foreign import ccall unsafe "strtod"
  41     c_strtod :: CString -> Ptr CString -> IO CDouble
  42
  43 instance Show Double where
  44     show x = unsafePerformIO . withCString "%a" $ \fmt -> do
  45         size <- double_format nullPtr fmt (toFloating x)
  46         allocaArray0 (fromIntegral size) $ \buf -> do
  47             double_format buf fmt (toFloating x)
  48             peekCString buf
  49
  50 instance Read Double where
  51     readsPrec _ s = unsafePerformIO . withCString s $ \str -> do
  52         alloca $ \endbuf -> do
  53             val <- toFloating <$> c_strtod str endbuf
  54             end <- peek endbuf
  55             if end == str
  56                 then return []
  57                 else peekCString end >>= \rem -> return [(val, rem)]
  58
  59 instance Eq Double where
  60     D# x == D# y = x ==## y
  61     D# x /= D# y = x /=## y
  62
  63 instance Num Double where
  64     D# x + D# y = D# (x +## y)
  65     D# x - D# y = D# (x -## y)
  66     D# x * D# y = D# (x *## y)
  67     negate (D# x) = D# (negateDouble# x)
  68     fromInteger = toFloating
  69     signum      = libmDouble double_signum
  70     abs         = libmDouble c_fabs
  71
  72 instance Poset Double where
  73     compare a b = toEnum . fromIntegral $ double_compare a' b' where
  74         a' = toFloating a
  75         b' = toFloating b
  76     D# x <  D# y = x <##  y
  77     D# x <= D# y = x <=## y
  78     D# x >= D# y = x >=## y
  79     D# x >  D# y = x >##  y
  80
  81 instance Sortable Double where
  82     isSignificant = not . ((== FPNaN) . classify)
  83     max = libmDouble2 c_fmax
  84     min = libmDouble2 c_fmin
  85
  86 instance Fractional Double where
  87     (D# x) / (D# y) = D# (x /## y)
  88     fromRational = liftM2 (/)
  89         (fromInteger . numerator)
  90         (fromInteger . denominator)
  91
  92 instance Floating Double where
  93     (D# x) ** (D# y) = D# (x **## y)
  94     sqrt (D# x) = D# (sqrtDouble# x)
  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     cosh (D# x) = D# (coshDouble#  x)
 102     sinh (D# x) = D# (sinhDouble#  x)
 103     tanh (D# x) = D# (tanhDouble#  x)
 104     exp  (D# x) = D# (expDouble#  x)
 105     log  (D# x) = D# (logDouble#  x)
 106     acosh = libmDouble c_acosh
 107     asinh = libmDouble c_asinh
 108     atanh = libmDouble c_atanh
 109
 110 instance RealFloat Double where
 111     fma       = libmDouble3 c_fma
 112     copysign  = libmDouble2 c_copysign
 113     nextafter = libmDouble2 c_nextafter
 114     fmod      = libmDouble2 c_fmod
 115     frem      = libmDouble2 c_remainder
 116     atan2     = libmDouble2 c_atan2
 117     hypot     = libmDouble2 c_hypot
 118     cbrt      = libmDouble  c_cbrt
 119     exp2      = libmDouble  c_exp2
 120     expm1     = libmDouble  c_expm1
 121     log10     = libmDouble  c_log10
 122     log1p     = libmDouble  c_log1p
 123     log2      = libmDouble  c_log2
 124     logb      = libmDouble  c_logb
 125     erf       = libmDouble  c_erf
 126     erfc      = libmDouble  c_erfc
 127     lgamma    = libmDouble  c_lgamma
 128     tgamma    = libmDouble  c_tgamma
 129     classify  = toEnum . fromIntegral . double_classify . toFloating
 130
 131     fquotRem x y = unsafePerformIO . alloca $ \quotPtr -> do
 132         rem  <- c_remquo (toFloating x) (toFloating y) quotPtr
 133         quot <- peek quotPtr
 134         return (fromIntegral quot, toFloating rem)