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
  31 foreign import ccall unsafe "double_format"
  32     double_format :: CString -> CString -> CDouble -> IO CInt
  33 foreign import ccall unsafe "double_signum"
  34     double_signum :: CDouble -> CDouble
  35 foreign import ccall unsafe "double_classify"
  36     double_classify :: CDouble -> CInt
  37 foreign import ccall unsafe "double_compare"
  38     double_compare :: CDouble -> CDouble -> CInt
  39 foreign import ccall unsafe "strtod"
  40     c_strtod :: CString -> Ptr CString -> IO CDouble
  41
  42 foreign import ccall unsafe "fabs"
  43     c_fabs :: CDouble -> CDouble
  44 foreign import ccall unsafe "fma"
  45     c_fma :: CDouble -> CDouble -> CDouble -> CDouble
  46 foreign import ccall unsafe "copysign"
  47     c_copysign :: CDouble -> CDouble -> CDouble
  48 foreign import ccall unsafe "nextafter"
  49     c_nextafter :: CDouble -> CDouble -> CDouble
  50 foreign import ccall unsafe "fmod"
  51     c_fmod :: CDouble -> CDouble -> CDouble
  52 foreign import ccall unsafe "remainder"
  53     c_remainder :: CDouble -> CDouble -> CDouble
  54 foreign import ccall unsafe "fmax"
  55     c_fmax :: CDouble -> CDouble -> CDouble
  56 foreign import ccall unsafe "fmin"
  57     c_fmin :: CDouble -> CDouble -> CDouble
  58 foreign import ccall unsafe "hypot"
  59     c_hypot :: CDouble -> CDouble -> CDouble
  60 foreign import ccall unsafe "cbrt"
  61     c_cbrt :: CDouble -> CDouble
  62 foreign import ccall unsafe "atan2"
  63     c_atan2 :: CDouble -> CDouble -> CDouble
  64 foreign import ccall unsafe "acosh"
  65     c_acosh :: CDouble -> CDouble
  66 foreign import ccall unsafe "asinh"
  67     c_asinh :: CDouble -> CDouble
  68 foreign import ccall unsafe "atanh"
  69     c_atanh :: CDouble -> CDouble
  70 foreign import ccall unsafe "exp2"
  71     c_exp2 :: CDouble -> CDouble
  72 foreign import ccall unsafe "expm1"
  73     c_expm1 :: CDouble -> CDouble
  74 foreign import ccall unsafe "log10"
  75     c_log10 :: CDouble -> CDouble
  76 foreign import ccall unsafe "log1p"
  77     c_log1p :: CDouble -> CDouble
  78 foreign import ccall unsafe "log2"
  79     c_log2 :: CDouble -> CDouble
  80 foreign import ccall unsafe "logb"
  81     c_logb :: CDouble -> CDouble
  82 foreign import ccall unsafe "erf"
  83     c_erf :: CDouble -> CDouble
  84 foreign import ccall unsafe "erfc"
  85     c_erfc :: CDouble -> CDouble
  86 foreign import ccall unsafe "lgamma"
  87     c_lgamma :: CDouble -> CDouble
  88 foreign import ccall unsafe "tgamma"
  89     c_tgamma :: CDouble -> CDouble
  90
  91 libmDouble :: (CDouble -> CDouble) -> Double -> Double
  92 libmDouble f a = toFloating $ f (toFloating a)
  93
  94 libmDouble2 :: (CDouble -> CDouble -> CDouble) -> Double -> Double -> Double
  95 libmDouble2 f a b = toFloating $ f (toFloating a) (toFloating b)
  96
  97 libmDouble3 :: (CDouble -> CDouble -> CDouble -> CDouble)
  98     -> Double -> Double -> Double -> Double
  99 libmDouble3 f a b c = toFloating
 100     $ f (toFloating a) (toFloating b) (toFloating c)
 101
 102 instance Show Double where
 103     show x = unsafePerformIO . withCString "%a" $ \fmt -> do
 104         size <- double_format nullPtr fmt (toFloating x)
 105         allocaArray0 (fromIntegral size) $ \buf -> do
 106             double_format buf fmt (toFloating x)
 107             peekCString buf
 108
 109 instance Read Double where
 110     readsPrec _ s = unsafePerformIO . withCString s $ \str -> do
 111         alloca $ \endbuf -> do
 112             val <- toFloating <$> c_strtod str endbuf
 113             end <- peek endbuf
 114             if end == str
 115                 then return []
 116                 else peekCString end >>= \rem -> return [(val, rem)]
 117
 118 instance Eq Double where
 119     D# x == D# y = x ==## y
 120     D# x /= D# y = x /=## y
 121
 122 instance Num Double where
 123     D# x + D# y = D# (x +## y)
 124     D# x - D# y = D# (x -## y)
 125     D# x * D# y = D# (x *## y)
 126     negate (D# x) = D# (negateDouble# x)
 127     fromInteger = toFloating
 128     signum      = libmDouble double_signum
 129     abs         = libmDouble c_fabs
 130
 131 instance Fractional Double where
 132     (D# x) / (D# y) = D# (x /## y)
 133     fromRational = liftM2 (/)
 134         (fromInteger . numerator)
 135         (fromInteger . denominator)
 136
 137 instance Floating Double where
 138     (D# x) ** (D# y) = D# (x **## y)
 139     sqrt (D# x) = D# (sqrtDouble# x)
 140     acos (D# x) = D# (acosDouble# x)
 141     asin (D# x) = D# (asinDouble# x)
 142     atan (D# x) = D# (atanDouble# x)
 143     cos  (D# x) = D# (cosDouble#  x)
 144     sin  (D# x) = D# (sinDouble#  x)
 145     tan  (D# x) = D# (tanDouble#  x)
 146     cosh (D# x) = D# (coshDouble#  x)
 147     sinh (D# x) = D# (sinhDouble#  x)
 148     tanh (D# x) = D# (tanhDouble#  x)
 149     exp  (D# x) = D# (expDouble#  x)
 150     log  (D# x) = D# (logDouble#  x)
 151     acosh = libmDouble c_acosh
 152     asinh = libmDouble c_asinh
 153     atanh = libmDouble c_atanh
 154
 155 instance RealFloat Double where
 156     fma       = libmDouble3 c_fma
 157     copysign  = libmDouble2 c_copysign
 158     nextafter = libmDouble2 c_nextafter
 159     fmod      = libmDouble2 c_fmod
 160     frem      = libmDouble2 c_remainder
 161     atan2     = libmDouble2 c_atan2
 162     hypot     = libmDouble2 c_hypot
 163     cbrt      = libmDouble  c_cbrt
 164     exp2      = libmDouble  c_exp2
 165     expm1     = libmDouble  c_expm1
 166     log10     = libmDouble  c_log10
 167     log1p     = libmDouble  c_log1p
 168     log2      = libmDouble  c_log2
 169     logb      = libmDouble  c_logb
 170     erf       = libmDouble  c_erf
 171     erfc      = libmDouble  c_erfc
 172     lgamma    = libmDouble  c_lgamma
 173     tgamma    = libmDouble  c_tgamma
 174     classify  = toEnum . fromIntegral . double_classify . toFloating
 175
 176 instance Poset Double where
 177     compare a b = toEnum . fromIntegral $ double_compare a' b' where
 178         a' = toFloating a
 179         b' = toFloating b
 180     D# x <  D# y = x <##  y
 181     D# x <= D# y = x <=## y
 182     D# x >= D# y = x >=## y
 183     D# x >  D# y = x >##  y
 184
 185 instance Sortable Double where
 186     isSignificant = not . ((== FPNaN) . classify)
 187     max = libmDouble2 c_fmax
 188     min = libmDouble2 c_fmin