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