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