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