2 - Copyright (C) 2009 Nick Bowler.
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.
9 {-# LANGUAGE ForeignFunctionInterface, MagicHash, UnboxedTuples #-}
10 module Data
.Floating
.Double (
14 import Prelude
hiding (Double, Floating
(..), RealFloat
(..), Ord
(..))
15 import Control
.Applicative
21 import GHC
.Exts
hiding (Double(..))
27 import System
.IO.Unsafe
29 import Data
.Floating
.Types
30 import Data
.Floating
.Classes
31 import Data
.Floating
.CMath
33 foreign import ccall unsafe
"double_format"
34 double_format
:: CString
-> CChar
-> CInt
-> CDouble
-> IO CInt
35 foreign import ccall unsafe
"double_signum"
36 double_signum
:: CDouble
-> CDouble
37 foreign import ccall unsafe
"double_classify"
38 double_classify
:: CDouble
-> CInt
39 foreign import ccall unsafe
"double_compare"
40 double_compare
:: CDouble
-> CDouble
-> CInt
41 foreign import ccall unsafe
"strtod"
42 c_strtod
:: CString
-> Ptr CString
-> IO CDouble
44 instance Show Double where
45 show x
= unsafePerformIO
$ do
46 let format
= castCharToCChar
'a
'
47 size
<- double_format nullPtr format
(-1) (toFloating x
)
48 allocaArray0
(fromIntegral size
) $ \buf
-> do
49 double_format buf format
(-1) (toFloating x
)
52 instance Read Double where
53 readsPrec _ s
= unsafePerformIO
. withCString s
$ \str
-> do
54 alloca
$ \endbuf
-> do
55 val
<- toFloating
<$> c_strtod str endbuf
59 else peekCString end
>>= \rem
-> return [(val
, rem)]
61 instance Eq
Double where
62 D
# x
== D
# y
= x
==## y
63 D
# x
/= D
# y
= x
/=## y
65 instance Num
Double where
66 D
# x
+ D
# y
= D
# (x
+## y
)
67 D
# x
- D
# y
= D
# (x
-## y
)
68 D
# x
* D
# y
= D
# (x
*## y
)
69 negate (D
# x
) = D
# (negateDouble
# x
)
70 fromInteger = toFloating
71 signum = libmDouble double_signum
72 abs = libmDouble c_fabs
74 instance Enum
Double where
75 pred x
= nextafter x
(-infinity
)
76 succ x
= nextafter x infinity
78 fromEnum = fromJust . toIntegral
80 instance Poset
Double where
81 compare a b
= toEnum . fromIntegral $ double_compare a
' b
' where
85 D
# x
<= D
# y
= x
<=## y
86 D
# x
>= D
# y
= x
>=## y
89 instance Sortable
Double where
90 isOrdered
= not . ((== FPNaN
) . classify
)
91 max = libmDouble2 c_fmax
92 min = libmDouble2 c_fmin
94 instance Fractional
Double where
95 (D
# x
) / (D
# y
) = D
# (x
/## y
)
96 fromRational = liftM2 (/)
97 (fromInteger . numerator)
98 (fromInteger . denominator)
100 -- | Internal function which discards the fractional component of a Double.
101 -- The results are meaningful only for finite input.
102 dropFrac
:: Double -> Integer
105 |
otherwise = quot s
(2^
(negate e
))
107 !(# s
, e
# #) = decodeDoubleInteger x
110 instance Roundable
Double where
111 toIntegral x
= case classify x
of
112 FPInfinite
-> Nothing
114 otherwise -> Just
. fromInteger . dropFrac
$ x
115 floor = libmDouble c_floor
116 ceiling = libmDouble c_ceil
117 truncate = libmDouble c_trunc
118 round = libmDouble c_round
120 instance Floating
Double where
121 (D
# x
) ** (D
# y
) = D
# (x
**## y
)
122 sqrt (D
# x
) = D
# (sqrtDouble
# x
)
123 acos (D
# x
) = D
# (acosDouble
# x
)
124 asin (D
# x
) = D
# (asinDouble
# x
)
125 atan (D
# x
) = D
# (atanDouble
# x
)
126 cos (D
# x
) = D
# (cosDouble
# x
)
127 sin (D
# x
) = D
# (sinDouble
# x
)
128 tan (D
# x
) = D
# (tanDouble
# x
)
129 cosh (D
# x
) = D
# (coshDouble
# x
)
130 sinh (D
# x
) = D
# (sinhDouble
# x
)
131 tanh (D
# x
) = D
# (tanhDouble
# x
)
132 exp (D
# x
) = D
# (expDouble
# x
)
133 log (D
# x
) = D
# (logDouble
# x
)
134 acosh = libmDouble c_acosh
135 asinh = libmDouble c_asinh
136 atanh = libmDouble c_atanh
138 instance RealFloat
Double where
139 fma
= libmDouble3 c_fma
140 copysign
= libmDouble2 c_copysign
141 nextafter
= libmDouble2 c_nextafter
142 fmod
= libmDouble2 c_fmod
143 frem
= libmDouble2 c_remainder
144 atan2 = libmDouble2 c_atan2
145 hypot
= libmDouble2 c_hypot
146 cbrt
= libmDouble c_cbrt
147 exp2
= libmDouble c_exp2
148 expm1
= libmDouble c_expm1
149 log10
= libmDouble c_log10
150 log1p
= libmDouble c_log1p
151 log2
= libmDouble c_log2
152 logb
= libmDouble c_logb
153 erf
= libmDouble c_erf
154 erfc
= libmDouble c_erfc
155 lgamma
= libmDouble c_lgamma
156 tgamma
= libmDouble c_tgamma
157 nearbyint
= libmDouble c_nearbyint
158 classify
= toEnum . fromIntegral . double_classify
. toFloating
160 fquotRem x y
= unsafePerformIO
. alloca
$ \quotPtr
-> do
161 rem <- c_remquo
(toFloating x
) (toFloating y
) quotPtr
163 return (fromIntegral quot, toFloating
rem)