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