module Data.Floating.Types.Double (
Double
) where
import Prelude hiding (Double, Floating(..), RealFloat(..), Ord(..))
import Control.Applicative
import Control.Monad
import Data.Maybe
import Data.Ratio
import Data.Poset
import GHC.Exts hiding (Double(..))
import GHC.Integer
import GHC.Prim
import Foreign
import Foreign.C
import System.IO.Unsafe
import Data.Floating.Types
import Data.Floating.Classes
import Data.Floating.CMath
foreign import ccall unsafe "double_format"
double_format :: CString -> CChar -> CInt -> CDouble -> IO CInt
foreign import ccall unsafe "double_signum"
double_signum :: CDouble -> CDouble
foreign import ccall unsafe "double_classify"
double_classify :: CDouble -> CInt
foreign import ccall unsafe "double_compare"
double_compare :: CDouble -> CDouble -> CInt
foreign import ccall unsafe "strtod"
c_strtod :: CString -> Ptr CString -> IO CDouble
instance Show Double where
show x = unsafePerformIO $ do
let format = castCharToCChar 'a'
size <- double_format nullPtr format (1) (toFloating x)
allocaArray0 (fromIntegral size) $ \buf -> do
double_format buf format (1) (toFloating x)
peekCString buf
instance Read Double where
readsPrec _ s = unsafePerformIO . withCString s $ \str -> do
alloca $ \endbuf -> do
val <- toFloating <$> c_strtod str endbuf
end <- peek endbuf
if end == str
then return []
else peekCString end >>= \rem -> return [(val, rem)]
instance Eq Double where
D# x == D# y = x ==## y
D# x /= D# y = x /=## y
instance Num Double where
D# x + D# y = D# (x +## y)
D# x D# y = D# (x -## y)
D# x * D# y = D# (x *## y)
negate (D# x) = D# (negateDouble# x)
fromInteger = toFloating
signum = libmDouble double_signum
abs = libmDouble c_fabs
instance Enum Double where
pred x = nextafter x (infinity)
succ x = nextafter x infinity
toEnum = toFloating
fromEnum = fromJust . toIntegral
instance Poset Double where
compare a b = toEnum . fromIntegral $ double_compare a' b' where
a' = toFloating a
b' = toFloating b
D# x < D# y = x <## y
D# x <= D# y = x <=## y
D# x >= D# y = x >=## y
D# x > D# y = x >## y
instance Sortable Double where
isOrdered = not . ((== FPNaN) . classify)
max = libmDouble2 c_fmax
min = libmDouble2 c_fmin
instance Fractional Double where
(D# x) / (D# y) = D# (x /## y)
fromRational = liftM2 (/)
(fromInteger . numerator)
(fromInteger . denominator)
dropFrac :: Double -> Integer
dropFrac (D# x)
| e >= 0 = s * 2^e
| otherwise = quot s (2^(negate e))
where
!(# s, e# #) = decodeDoubleInteger x
e = I# e#
instance Roundable Double where
toIntegral x = case classify x of
FPInfinite -> Nothing
FPNaN -> Nothing
otherwise -> Just . fromInteger . dropFrac $ x
floor = libmDouble c_floor
ceiling = libmDouble c_ceil
truncate = libmDouble c_trunc
round = libmDouble c_round
instance Floating Double where
(D# x) ** (D# y) = D# (x **## y)
sqrt (D# x) = D# (sqrtDouble# x)
acos (D# x) = D# (acosDouble# x)
asin (D# x) = D# (asinDouble# x)
atan (D# x) = D# (atanDouble# x)
cos (D# x) = D# (cosDouble# x)
sin (D# x) = D# (sinDouble# x)
tan (D# x) = D# (tanDouble# x)
cosh (D# x) = D# (coshDouble# x)
sinh (D# x) = D# (sinhDouble# x)
tanh (D# x) = D# (tanhDouble# x)
exp (D# x) = D# (expDouble# x)
log (D# x) = D# (logDouble# x)
acosh = libmDouble c_acosh
asinh = libmDouble c_asinh
atanh = libmDouble c_atanh
instance RealFloat Double where
fma = libmDouble3 c_fma
copysign = libmDouble2 c_copysign
nextafter = libmDouble2 c_nextafter
fmod = libmDouble2 c_fmod
frem = libmDouble2 c_remainder
atan2 = libmDouble2 c_atan2
hypot = libmDouble2 c_hypot
cbrt = libmDouble c_cbrt
exp2 = libmDouble c_exp2
expm1 = libmDouble c_expm1
log10 = libmDouble c_log10
log1p = libmDouble c_log1p
log2 = libmDouble c_log2
logb = libmDouble c_logb
erf = libmDouble c_erf
erfc = libmDouble c_erfc
gamma = libmDouble c_tgamma
lgamma = libmDouble c_lgamma
nearbyint = libmDouble c_nearbyint
rint = libmDouble c_rint
instance PrimFloat Double where
classify = toEnum . fromIntegral . double_classify . toFloating