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