1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
|
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE ScopedTypeVariables #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Fixed
-- Copyright : (c) Ashley Yakeley 2005, 2006, 2009
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : Ashley Yakeley <ashley@semantic.org>
-- Stability : experimental
-- Portability : portable
--
-- This module defines a \"Fixed\" type for fixed-precision arithmetic.
-- The parameter to Fixed is any type that's an instance of HasResolution.
-- HasResolution has a single method that gives the resolution of the Fixed type.
--
-- This module also contains generalisations of div, mod, and divmod to work
-- with any Real instance.
--
-----------------------------------------------------------------------------
module Data.Fixed
(
div',mod',divMod',
Fixed(..), HasResolution(..),
showFixed,
E0,Uni,
E1,Deci,
E2,Centi,
E3,Milli,
E6,Micro,
E9,Nano,
E12,Pico
) where
import Data.Data
import GHC.Read
import Text.ParserCombinators.ReadPrec
import Text.Read.Lex
default () -- avoid any defaulting shenanigans
-- | generalisation of 'div' to any instance of Real
div' :: (Real a,Integral b) => a -> a -> b
div' n d = floor ((toRational n) / (toRational d))
-- | generalisation of 'divMod' to any instance of Real
divMod' :: (Real a,Integral b) => a -> a -> (b,a)
divMod' n d = (f,n - (fromIntegral f) * d) where
f = div' n d
-- | generalisation of 'mod' to any instance of Real
mod' :: (Real a) => a -> a -> a
mod' n d = n - (fromInteger f) * d where
f = div' n d
-- | The type parameter should be an instance of 'HasResolution'.
newtype Fixed a = MkFixed Integer -- ^ @since 4.7.0.0
deriving (Eq,Ord)
-- We do this because the automatically derived Data instance requires (Data a) context.
-- Our manual instance has the more general (Typeable a) context.
tyFixed :: DataType
tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed]
conMkFixed :: Constr
conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix
instance (Typeable a) => Data (Fixed a) where
gfoldl k z (MkFixed a) = k (z MkFixed) a
gunfold k z _ = k (z MkFixed)
dataTypeOf _ = tyFixed
toConstr _ = conMkFixed
class HasResolution a where
resolution :: p a -> Integer
withType :: (p a -> f a) -> f a
withType foo = foo undefined
withResolution :: (HasResolution a) => (Integer -> f a) -> f a
withResolution foo = withType (foo . resolution)
instance Enum (Fixed a) where
succ (MkFixed a) = MkFixed (succ a)
pred (MkFixed a) = MkFixed (pred a)
toEnum = MkFixed . toEnum
fromEnum (MkFixed a) = fromEnum a
enumFrom (MkFixed a) = fmap MkFixed (enumFrom a)
enumFromThen (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromThen a b)
enumFromTo (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromTo a b)
enumFromThenTo (MkFixed a) (MkFixed b) (MkFixed c) = fmap MkFixed (enumFromThenTo a b c)
instance (HasResolution a) => Num (Fixed a) where
(MkFixed a) + (MkFixed b) = MkFixed (a + b)
(MkFixed a) - (MkFixed b) = MkFixed (a - b)
fa@(MkFixed a) * (MkFixed b) = MkFixed (div (a * b) (resolution fa))
negate (MkFixed a) = MkFixed (negate a)
abs (MkFixed a) = MkFixed (abs a)
signum (MkFixed a) = fromInteger (signum a)
fromInteger i = withResolution (\res -> MkFixed (i * res))
instance (HasResolution a) => Real (Fixed a) where
toRational fa@(MkFixed a) = (toRational a) / (toRational (resolution fa))
instance (HasResolution a) => Fractional (Fixed a) where
fa@(MkFixed a) / (MkFixed b) = MkFixed (div (a * (resolution fa)) b)
recip fa@(MkFixed a) = MkFixed (div (res * res) a) where
res = resolution fa
fromRational r = withResolution (\res -> MkFixed (floor (r * (toRational res))))
instance (HasResolution a) => RealFrac (Fixed a) where
properFraction a = (i,a - (fromIntegral i)) where
i = truncate a
truncate f = truncate (toRational f)
round f = round (toRational f)
ceiling f = ceiling (toRational f)
floor f = floor (toRational f)
chopZeros :: Integer -> String
chopZeros 0 = ""
chopZeros a | mod a 10 == 0 = chopZeros (div a 10)
chopZeros a = show a
-- only works for positive a
showIntegerZeros :: Bool -> Int -> Integer -> String
showIntegerZeros True _ 0 = ""
showIntegerZeros chopTrailingZeros digits a = replicate (digits - length s) '0' ++ s' where
s = show a
s' = if chopTrailingZeros then chopZeros a else s
withDot :: String -> String
withDot "" = ""
withDot s = '.':s
-- | First arg is whether to chop off trailing zeros
showFixed :: (HasResolution a) => Bool -> Fixed a -> String
showFixed chopTrailingZeros fa@(MkFixed a) | a < 0 = "-" ++ (showFixed chopTrailingZeros (asTypeOf (MkFixed (negate a)) fa))
showFixed chopTrailingZeros fa@(MkFixed a) = (show i) ++ (withDot (showIntegerZeros chopTrailingZeros digits fracNum)) where
res = resolution fa
(i,d) = divMod a res
-- enough digits to be unambiguous
digits = ceiling (logBase 10 (fromInteger res) :: Double)
maxnum = 10 ^ digits
-- read floors, so show must ceil for `read . show = id` to hold. See #9240
fracNum = divCeil (d * maxnum) res
divCeil x y = (x + y - 1) `div` y
instance (HasResolution a) => Show (Fixed a) where
show = showFixed False
instance (HasResolution a) => Read (Fixed a) where
readPrec = readNumber convertFixed
readListPrec = readListPrecDefault
readList = readListDefault
convertFixed :: forall a . HasResolution a => Lexeme -> ReadPrec (Fixed a)
convertFixed (Number n)
| Just (i, f) <- numberToFixed e n =
return (fromInteger i + (fromInteger f / (10 ^ e)))
where r = resolution (undefined :: Fixed a)
-- round 'e' up to help make the 'read . show == id' property
-- possible also for cases where 'resolution' is not a
-- power-of-10, such as e.g. when 'resolution = 128'
e = ceiling (logBase 10 (fromInteger r) :: Double)
convertFixed _ = pfail
data E0
instance HasResolution E0 where
resolution _ = 1
-- | resolution of 1, this works the same as Integer
type Uni = Fixed E0
data E1
instance HasResolution E1 where
resolution _ = 10
-- | resolution of 10^-1 = .1
type Deci = Fixed E1
data E2
instance HasResolution E2 where
resolution _ = 100
-- | resolution of 10^-2 = .01, useful for many monetary currencies
type Centi = Fixed E2
data E3
instance HasResolution E3 where
resolution _ = 1000
-- | resolution of 10^-3 = .001
type Milli = Fixed E3
data E6
instance HasResolution E6 where
resolution _ = 1000000
-- | resolution of 10^-6 = .000001
type Micro = Fixed E6
data E9
instance HasResolution E9 where
resolution _ = 1000000000
-- | resolution of 10^-9 = .000000001
type Nano = Fixed E9
data E12
instance HasResolution E12 where
resolution _ = 1000000000000
-- | resolution of 10^-12 = .000000000001
type Pico = Fixed E12
|
