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