Data/Floating/Double.hs

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