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