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