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, UnboxedTuples #-}
  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(..), Ord(..))
  16 import Control.Applicative
  17 import Control.Monad
  18 import Data.Maybe
  19 import Data.Ratio
  20 import Data.Poset
  21
  22 import GHC.Exts hiding (Double(..))
  23 import GHC.Integer
  24 import GHC.Prim
  25
  26 import Foreign
  27 import Foreign.C
  28 import System.IO.Unsafe
  29
  30 import Data.Floating.Types
  31 import Data.Floating.Classes
  32 import Data.Floating.CMath
  33
  34 foreign import ccall unsafe "double_format"
  35     double_format :: CString -> CChar -> CInt -> CDouble -> IO CInt
  36 foreign import ccall unsafe "double_signum"
  37     double_signum :: CDouble -> CDouble
  38 foreign import ccall unsafe "double_classify"
  39     double_classify :: CDouble -> CInt
  40 foreign import ccall unsafe "double_compare"
  41     double_compare :: CDouble -> CDouble -> CInt
  42 foreign import ccall unsafe "strtod"
  43     c_strtod :: CString -> Ptr CString -> IO CDouble
  44
  45 instance Show Double where
  46     show x = unsafePerformIO $ do
  47         let format = castCharToCChar 'a'
  48         size <- double_format nullPtr format (-1) (toFloating x)
  49         allocaArray0 (fromIntegral size) $ \buf -> do
  50             double_format buf format (-1) (toFloating x)
  51             peekCString buf
  52
  53 instance Read Double where
  54     readsPrec _ s = unsafePerformIO . withCString s $ \str -> do
  55         alloca $ \endbuf -> do
  56             val <- toFloating <$> c_strtod str endbuf
  57             end <- peek endbuf
  58             if end == str
  59                 then return []
  60                 else peekCString end >>= \rem -> return [(val, rem)]
  61
  62 instance Eq Double where
  63     D# x == D# y = x ==## y
  64     D# x /= D# y = x /=## y
  65
  66 instance Num Double where
  67     D# x + D# y = D# (x +## y)
  68     D# x - D# y = D# (x -## y)
  69     D# x * D# y = D# (x *## y)
  70     negate (D# x) = D# (negateDouble# x)
  71     fromInteger = toFloating
  72     signum      = libmDouble double_signum
  73     abs         = libmDouble c_fabs
  74
  75 instance Enum Double where
  76     pred x   = nextafter x (-infinity)
  77     succ x   = nextafter x infinity
  78     toEnum   = toFloating
  79     fromEnum = fromJust . toIntegral
  80
  81 instance Poset Double where
  82     compare a b = toEnum . fromIntegral $ double_compare a' b' where
  83         a' = toFloating a
  84         b' = toFloating b
  85     D# x <  D# y = x <##  y
  86     D# x <= D# y = x <=## y
  87     D# x >= D# y = x >=## y
  88     D# x >  D# y = x >##  y
  89
  90 instance Sortable Double where
  91     isOrdered = not . ((== FPNaN) . classify)
  92     max = libmDouble2 c_fmax
  93     min = libmDouble2 c_fmin
  94
  95 instance Fractional Double where
  96     (D# x) / (D# y) = D# (x /## y)
  97     fromRational = liftM2 (/)
  98         (fromInteger . numerator)
  99         (fromInteger . denominator)
 100
 101 -- | Internal function which discards the fractional component of a Double.
 102 -- The results are meaningful only for finite input.
 103 dropFrac :: Double -> Integer
 104 dropFrac (D# x)
 105     | e >= 0    = s * 2^e
 106     | otherwise = quot s (2^(negate e))
 107     where
 108         (# s, e# #) = decodeDoubleInteger x
 109         e = I# e#
 110
 111 instance Roundable Double where
 112     toIntegral x = case classify x of
 113         FPInfinite -> Nothing
 114         FPNaN      -> Nothing
 115         otherwise  -> Just . fromInteger . dropFrac $ x
 116     floor    = libmDouble c_floor
 117     ceiling  = libmDouble c_ceil
 118     truncate = libmDouble c_trunc
 119     round    = libmDouble c_round
 120
 121 instance Floating Double where
 122     (D# x) ** (D# y) = D# (x **## y)
 123     sqrt (D# x) = D# (sqrtDouble# x)
 124     acos (D# x) = D# (acosDouble# x)
 125     asin (D# x) = D# (asinDouble# x)
 126     atan (D# x) = D# (atanDouble# x)
 127     cos  (D# x) = D# (cosDouble#  x)
 128     sin  (D# x) = D# (sinDouble#  x)
 129     tan  (D# x) = D# (tanDouble#  x)
 130     cosh (D# x) = D# (coshDouble#  x)
 131     sinh (D# x) = D# (sinhDouble#  x)
 132     tanh (D# x) = D# (tanhDouble#  x)
 133     exp  (D# x) = D# (expDouble#  x)
 134     log  (D# x) = D# (logDouble#  x)
 135     acosh = libmDouble c_acosh
 136     asinh = libmDouble c_asinh
 137     atanh = libmDouble c_atanh
 138
 139 instance RealFloat Double where
 140     fma       = libmDouble3 c_fma
 141     copysign  = libmDouble2 c_copysign
 142     nextafter = libmDouble2 c_nextafter
 143     fmod      = libmDouble2 c_fmod
 144     frem      = libmDouble2 c_remainder
 145     atan2     = libmDouble2 c_atan2
 146     hypot     = libmDouble2 c_hypot
 147     cbrt      = libmDouble  c_cbrt
 148     exp2      = libmDouble  c_exp2
 149     expm1     = libmDouble  c_expm1
 150     log10     = libmDouble  c_log10
 151     log1p     = libmDouble  c_log1p
 152     log2      = libmDouble  c_log2
 153     logb      = libmDouble  c_logb
 154     erf       = libmDouble  c_erf
 155     erfc      = libmDouble  c_erfc
 156     lgamma    = libmDouble  c_lgamma
 157     tgamma    = libmDouble  c_tgamma
 158     classify  = toEnum . fromIntegral . double_classify . toFloating
 159
 160     fquotRem x y = unsafePerformIO . alloca $ \quotPtr -> do
 161         rem  <- c_remquo (toFloating x) (toFloating y) quotPtr
 162         quot <- peek quotPtr
 163         return (fromIntegral quot, toFloating rem)