98d212defda15f778e4b6bdf69cc7cb957bee6a6
[packages/base.git] / Data / Fixed.hs
1 {-# OPTIONS -Wall -fno-warn-unused-binds #-}
2
3 -----------------------------------------------------------------------------
4 -- |
5 -- Module : Data.Fixed
6 -- Copyright : (c) Ashley Yakeley 2005, 2006, 2009
7 -- License : BSD-style (see the file libraries/base/LICENSE)
8 --
9 -- Maintainer : Ashley Yakeley <ashley@semantic.org>
10 -- Stability : experimental
11 -- Portability : portable
12 --
13 -- This module defines a \"Fixed\" type for fixed-precision arithmetic.
14 -- The parameter to Fixed is any type that's an instance of HasResolution.
15 -- HasResolution has a single method that gives the resolution of the Fixed type.
16 --
17 -- This module also contains generalisations of div, mod, and divmod to work
18 -- with any Real instance.
19 --
20 -----------------------------------------------------------------------------
21
22 module Data.Fixed
23 (
24 div',mod',divMod',
25
26 Fixed,HasResolution(..),
27 showFixed,
28 E0,Uni,
29 E1,Deci,
30 E2,Centi,
31 E3,Milli,
32 E6,Micro,
33 E9,Nano,
34 E12,Pico
35 ) where
36
37 import Prelude -- necessary to get dependencies right
38 import Data.Char
39 import Data.List
40 #ifndef __NHC__
41 import Data.Typeable
42 import Data.Data
43 #endif
44
45 #ifndef __NHC__
46 default () -- avoid any defaulting shenanigans
47 #endif
48
49 -- | generalisation of 'div' to any instance of Real
50 div' :: (Real a,Integral b) => a -> a -> b
51 div' n d = floor ((toRational n) / (toRational d))
52
53 -- | generalisation of 'divMod' to any instance of Real
54 divMod' :: (Real a,Integral b) => a -> a -> (b,a)
55 divMod' n d = (f,n - (fromIntegral f) * d) where
56 f = div' n d
57
58 -- | generalisation of 'mod' to any instance of Real
59 mod' :: (Real a) => a -> a -> a
60 mod' n d = n - (fromInteger f) * d where
61 f = div' n d
62
63 -- | The type parameter should be an instance of 'HasResolution'.
64 newtype Fixed a = MkFixed Integer
65 #ifndef __NHC__
66 deriving (Eq,Ord,Typeable)
67 #else
68 deriving (Eq,Ord)
69 #endif
70
71 #ifndef __NHC__
72 -- We do this because the automatically derived Data instance requires (Data a) context.
73 -- Our manual instance has the more general (Typeable a) context.
74 tyFixed :: DataType
75 tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed]
76 conMkFixed :: Constr
77 conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix
78 instance (Typeable a) => Data (Fixed a) where
79 gfoldl k z (MkFixed a) = k (z MkFixed) a
80 gunfold k z _ = k (z MkFixed)
81 dataTypeOf _ = tyFixed
82 toConstr _ = conMkFixed
83 #endif
84
85 class HasResolution a where
86 resolution :: p a -> Integer
87
88 withType :: (p a -> f a) -> f a
89 withType foo = foo undefined
90
91 withResolution :: (HasResolution a) => (Integer -> f a) -> f a
92 withResolution foo = withType (foo . resolution)
93
94 instance Enum (Fixed a) where
95 succ (MkFixed a) = MkFixed (succ a)
96 pred (MkFixed a) = MkFixed (pred a)
97 toEnum = MkFixed . toEnum
98 fromEnum (MkFixed a) = fromEnum a
99 enumFrom (MkFixed a) = fmap MkFixed (enumFrom a)
100 enumFromThen (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromThen a b)
101 enumFromTo (MkFixed a) (MkFixed b) = fmap MkFixed (enumFromTo a b)
102 enumFromThenTo (MkFixed a) (MkFixed b) (MkFixed c) = fmap MkFixed (enumFromThenTo a b c)
103
104 instance (HasResolution a) => Num (Fixed a) where
105 (MkFixed a) + (MkFixed b) = MkFixed (a + b)
106 (MkFixed a) - (MkFixed b) = MkFixed (a - b)
107 fa@(MkFixed a) * (MkFixed b) = MkFixed (div (a * b) (resolution fa))
108 negate (MkFixed a) = MkFixed (negate a)
109 abs (MkFixed a) = MkFixed (abs a)
110 signum (MkFixed a) = fromInteger (signum a)
111 fromInteger i = withResolution (\res -> MkFixed (i * res))
112
113 instance (HasResolution a) => Real (Fixed a) where
114 toRational fa@(MkFixed a) = (toRational a) / (toRational (resolution fa))
115
116 instance (HasResolution a) => Fractional (Fixed a) where
117 fa@(MkFixed a) / (MkFixed b) = MkFixed (div (a * (resolution fa)) b)
118 recip fa@(MkFixed a) = MkFixed (div (res * res) a) where
119 res = resolution fa
120 fromRational r = withResolution (\res -> MkFixed (floor (r * (toRational res))))
121
122 instance (HasResolution a) => RealFrac (Fixed a) where
123 properFraction a = (i,a - (fromIntegral i)) where
124 i = truncate a
125 truncate f = truncate (toRational f)
126 round f = round (toRational f)
127 ceiling f = ceiling (toRational f)
128 floor f = floor (toRational f)
129
130 chopZeros :: Integer -> String
131 chopZeros 0 = ""
132 chopZeros a | mod a 10 == 0 = chopZeros (div a 10)
133 chopZeros a = show a
134
135 -- only works for positive a
136 showIntegerZeros :: Bool -> Int -> Integer -> String
137 showIntegerZeros True _ 0 = ""
138 showIntegerZeros chopTrailingZeros digits a = replicate (digits - length s) '0' ++ s' where
139 s = show a
140 s' = if chopTrailingZeros then chopZeros a else s
141
142 withDot :: String -> String
143 withDot "" = ""
144 withDot s = '.':s
145
146 -- | First arg is whether to chop off trailing zeros
147 showFixed :: (HasResolution a) => Bool -> Fixed a -> String
148 showFixed chopTrailingZeros fa@(MkFixed a) | a < 0 = "-" ++ (showFixed chopTrailingZeros (asTypeOf (MkFixed (negate a)) fa))
149 showFixed chopTrailingZeros fa@(MkFixed a) = (show i) ++ (withDot (showIntegerZeros chopTrailingZeros digits fracNum)) where
150 res = resolution fa
151 (i,d) = divMod a res
152 -- enough digits to be unambiguous
153 digits = ceiling (logBase 10 (fromInteger res) :: Double)
154 maxnum = 10 ^ digits
155 fracNum = div (d * maxnum) res
156
157 readsFixed :: (HasResolution a) => ReadS (Fixed a)
158 readsFixed = readsSigned
159 where readsSigned ('-' : xs) = [ (negate x, rest)
160 | (x, rest) <- readsUnsigned xs ]
161 readsSigned xs = readsUnsigned xs
162 readsUnsigned xs = case span isDigit xs of
163 ([], _) -> []
164 (is, xs') ->
165 let i = fromInteger (read is)
166 in case xs' of
167 '.' : xs'' ->
168 case span isDigit xs'' of
169 ([], _) -> []
170 (js, xs''') ->
171 let j = fromInteger (read js)
172 l = genericLength js :: Integer
173 in [(i + (j / (10 ^ l)), xs''')]
174 _ -> [(i, xs')]
175
176 instance (HasResolution a) => Show (Fixed a) where
177 show = showFixed False
178
179 instance (HasResolution a) => Read (Fixed a) where
180 readsPrec _ = readsFixed
181
182 data E0 = E0
183 #ifndef __NHC__
184 deriving (Typeable)
185 #endif
186 instance HasResolution E0 where
187 resolution _ = 1
188 -- | resolution of 1, this works the same as Integer
189 type Uni = Fixed E0
190
191 data E1 = E1
192 #ifndef __NHC__
193 deriving (Typeable)
194 #endif
195 instance HasResolution E1 where
196 resolution _ = 10
197 -- | resolution of 10^-1 = .1
198 type Deci = Fixed E1
199
200 data E2 = E2
201 #ifndef __NHC__
202 deriving (Typeable)
203 #endif
204 instance HasResolution E2 where
205 resolution _ = 100
206 -- | resolution of 10^-2 = .01, useful for many monetary currencies
207 type Centi = Fixed E2
208
209 data E3 = E3
210 #ifndef __NHC__
211 deriving (Typeable)
212 #endif
213 instance HasResolution E3 where
214 resolution _ = 1000
215 -- | resolution of 10^-3 = .001
216 type Milli = Fixed E3
217
218 data E6 = E6
219 #ifndef __NHC__
220 deriving (Typeable)
221 #endif
222 instance HasResolution E6 where
223 resolution _ = 1000000
224 -- | resolution of 10^-6 = .000001
225 type Micro = Fixed E6
226
227 data E9 = E9
228 #ifndef __NHC__
229 deriving (Typeable)
230 #endif
231 instance HasResolution E9 where
232 resolution _ = 1000000000
233 -- | resolution of 10^-9 = .000000001
234 type Nano = Fixed E9
235
236 data E12 = E12
237 #ifndef __NHC__
238 deriving (Typeable)
239 #endif
240 instance HasResolution E12 where
241 resolution _ = 1000000000000
242 -- | resolution of 10^-12 = .000000000001
243 type Pico = Fixed E12