]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Model/Amount.hs
Ajout : Model.Filter : Test_Amount.
[comptalang.git] / lib / Hcompta / Model / Amount.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleInstances #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE TypeFamilies #-}
5 {-# LANGUAGE TypeSynonymInstances #-}
6 {-# OPTIONS_GHC -fno-warn-orphans #-}
7 module Hcompta.Model.Amount where
8
9 import Data.Data
10 import qualified Data.List
11 import qualified Data.Map.Strict as Data.Map
12 import qualified Data.Foldable
13 import Data.Typeable ()
14
15 import qualified Hcompta.Calc.Balance as Balance
16 import qualified Hcompta.Model.Amount.Quantity as Quantity
17 import qualified Hcompta.Model.Amount.Style as Style
18 import qualified Hcompta.Model.Amount.Unit as Unit
19
20 -- * Type synonyms to submodules
21
22 type Quantity = Quantity.Quantity
23 type Style = Style.Style
24 type Unit = Unit.Unit
25
26 -- * The 'Amount' type
27
28 data Amount
29 = Amount
30 { quantity :: Quantity
31 , style :: Style
32 , unit :: Unit
33 } deriving (Data, Show, Typeable)
34
35 instance Eq Amount where
36 (==)
37 Amount{quantity=q0, unit=u0}
38 Amount{quantity=q1, unit=u1} =
39 case compare u0 u1 of
40 LT -> False
41 GT -> False
42 EQ -> (==) q0 q1 -- NOTE: MUST already be rounded to Style.precision
43
44 instance Ord Amount where
45 compare
46 Amount{quantity=q0, unit=u0}
47 Amount{quantity=q1, unit=u1} =
48 case compare u0 u1 of
49 LT -> LT
50 GT -> GT
51 EQ -> compare q0 q1 -- NOTE: MUST already be rounded to Style.precision
52
53 instance Balance.Amount Amount where
54 type Amount_Unit Amount = Unit
55 amount_null = (==) Quantity.zero . quantity
56 amount_add = (+)
57 amount_negate = negate
58 amount_positive a =
59 case compare (quantity a) Quantity.zero of
60 LT -> Nothing
61 EQ -> Nothing
62 _ -> Just a
63 amount_negative a =
64 case compare (quantity a) Quantity.zero of
65 GT -> Nothing
66 EQ -> Nothing
67 _ -> Just a
68
69 -- | An 'Amount' is a partially valid 'Num' instance:
70 --
71 -- * (+) operator requires both operand to have the same 'Unit' (homogeneity constraint).
72 -- * (*) operator requires at least one operand with an empty 'Unit' ('scalar').
73 instance Num Amount where
74 abs a@Amount{quantity=q} = a{quantity=abs q}
75 fromInteger = scalar . fromInteger
76 negate a@Amount{quantity=q} = a{quantity=negate q}
77 signum a@Amount{quantity=q} = a{quantity=signum q}
78 (+) a b =
79 let s@(Style.Style{Style.precision=p}) = Style.union (style a) (style b) in
80 a{ quantity = Quantity.round p $ quantity a + quantity b
81 , style = s
82 , unit =
83 if unit a == unit b
84 then unit a
85 else error "(+) on non-homogeneous units"
86 }
87 (*) a b =
88 let Style.Style{Style.precision=p} = s in
89 a{ quantity = Quantity.round p $ quantity a * quantity b
90 , style = s
91 , unit = u
92 }
93 where (s, u) =
94 if unit a == ""
95 then
96 if unit b == ""
97 then (Style.union (style a) (style b), "")
98 else (style b, unit b)
99 else
100 if unit b == ""
101 then (style a, unit a)
102 else error "(*) by non-scalar unit"
103
104 -- ** Constructors
105
106 nil :: Amount
107 nil =
108 Amount
109 { quantity = Quantity.zero
110 , style = Style.nil
111 , unit = ""
112 }
113
114 -- *** From 'Quantity'
115
116 -- | Return an 'Amount' with 'unit' = Unit.'Unit.nil'.
117 scalar :: Quantity -> Amount
118 scalar q =
119 Amount
120 { quantity = q
121 , style = Style.Style
122 { Style.fractioning = Just '.'
123 , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
124 , Style.grouping_integral = Just $ Style.Grouping ',' [3]
125 , Style.precision = maxBound
126 , Style.unit_side = Just Style.Side_Right
127 , Style.unit_spaced = Just False
128 }
129 , unit = ""
130 }
131
132 -- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
133 chf :: Quantity -> Amount
134 chf q =
135 Amount
136 { quantity = q
137 , style = Style.Style
138 { Style.fractioning = Just ','
139 , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
140 , Style.grouping_integral = Just $ Style.Grouping '.' [3]
141 , Style.precision = 2
142 , Style.unit_side = Just Style.Side_Right
143 , Style.unit_spaced = Just False
144 }
145 , unit = "CHF"
146 }
147 -- | <https://en.wikipedia.org/wiki/Yuan Yuan> unit of currency.
148 cny :: Quantity -> Amount
149 cny q =
150 Amount
151 { quantity = q
152 , style = Style.Style
153 { Style.fractioning = Just ','
154 , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
155 , Style.grouping_integral = Just $ Style.Grouping '.' [3]
156 , Style.precision = 2
157 , Style.unit_side = Just Style.Side_Right
158 , Style.unit_spaced = Just False
159 }
160 , unit = "Ұ"
161 }
162 -- | <https://en.wikipedia.org/wiki/Euro Euro> unit of currency.
163 eur :: Quantity -> Amount
164 eur q =
165 Amount
166 { quantity = q
167 , style = Style.Style
168 { Style.fractioning = Just ','
169 , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
170 , Style.grouping_integral = Just $ Style.Grouping '.' [3]
171 , Style.precision = 2
172 , Style.unit_side = Just Style.Side_Right
173 , Style.unit_spaced = Just False
174 }
175 , unit = "€"
176 }
177 -- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> unit of currency.
178 gbp :: Quantity -> Amount
179 gbp q =
180 Amount
181 { quantity = q
182 , style = Style.Style
183 { Style.fractioning = Just '.'
184 , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
185 , Style.grouping_integral = Just $ Style.Grouping ',' [3]
186 , Style.precision = 2
187 , Style.unit_side = Just Style.Side_Left
188 , Style.unit_spaced = Just False
189 }
190 , unit = "£"
191 }
192 -- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> unit of currency.
193 inr :: Quantity -> Amount
194 inr q =
195 Amount
196 { quantity = q
197 , style = Style.Style
198 { Style.fractioning = Just ','
199 , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
200 , Style.grouping_integral = Just $ Style.Grouping '.' [3]
201 , Style.precision = 2
202 , Style.unit_side = Just Style.Side_Right
203 , Style.unit_spaced = Just False
204 }
205 , unit = "₹"
206 }
207 -- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> unit of currency.
208 jpy :: Quantity -> Amount
209 jpy q =
210 Amount
211 { quantity = q
212 , style = Style.Style
213 { Style.fractioning = Just '.'
214 , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
215 , Style.grouping_integral = Just $ Style.Grouping ',' [3]
216 , Style.precision = 2
217 , Style.unit_side = Just Style.Side_Left
218 , Style.unit_spaced = Just False
219 }
220 , unit = "¥"
221 }
222 -- | <https://en.wikipedia.org/wiki/Russian_ruble Russian ruble> unit of currency.
223 --
224 -- NOTE: Ꝑ (U+A750) is used as a replacement latin letter,
225 -- because GHC currently chokes on ₽ (U+20BD),
226 -- which is the recently (2014/02) assigned Unicode code-point
227 -- for this currency.
228 rub :: Quantity -> Amount
229 rub q =
230 Amount
231 { quantity = q
232 , style = Style.Style
233 { Style.fractioning = Just '.'
234 , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
235 , Style.grouping_integral = Just $ Style.Grouping ',' [3]
236 , Style.precision = 2
237 , Style.unit_side = Just Style.Side_Left
238 , Style.unit_spaced = Just False
239 }
240 , unit = "Ꝑ"
241 }
242 -- | <https://en.wikipedia.org/wiki/United_States_dollar United States dollar> unit of currency.
243 usd :: Quantity -> Amount
244 usd q =
245 Amount
246 { quantity = q
247 , style = Style.Style
248 { Style.fractioning = Just '.'
249 , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
250 , Style.grouping_integral = Just $ Style.Grouping ',' [3]
251 , Style.precision = 2
252 , Style.unit_side = Just Style.Side_Left
253 , Style.unit_spaced = Just False
254 }
255 , unit = "$"
256 }
257
258 -- ** Tests
259
260 -- | Return 'True' if and only if 'Amount'’s 'Quantity' is zero.
261 --
262 -- NOTE: the 'Amount'’s 'quantity' MUST be have been rounded at 'Amount'’s 'style'’s 'Style.precision'.
263 is_zero :: Amount -> Bool
264 is_zero = Quantity.is_zero . quantity
265
266 -- * The 'Amount_by_Unit' mapping
267
268 type Amount_by_Unit
269 = Data.Map.Map Unit Amount
270 type By_Unit = Amount_by_Unit
271
272 -- | 'Amount_by_Unit'’s is a partially valid 'Num' instance.
273 --
274 -- * (*) operator is not defined.
275 instance Num Amount_by_Unit where
276 abs = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=abs q})
277 fromInteger = Data.Map.singleton "" . fromInteger
278 negate = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=negate q})
279 signum = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=signum q})
280 (+) = Data.Map.unionWith (+)
281 (*) = error "(*) not-supported"
282
283 type Signs = (Int, Int)
284
285 signs :: Amount_by_Unit -> Signs
286 signs = Data.Map.foldl
287 (\(nega, plus) amt ->
288 case flip compare 0 $ quantity amt of
289 LT -> (nega - 1, plus)
290 EQ -> (nega, plus)
291 GT -> (nega, plus + 1))
292 (0, 0)
293
294 -- ** Constructors
295
296 nil_By_Unit :: Amount_by_Unit
297 nil_By_Unit =
298 Data.Map.empty
299
300 -- ** Tests
301
302 -- | Return 'True' if and only if all 'Amount's satisfy 'is_zero'.
303 are_zero :: Amount_by_Unit -> Bool
304 are_zero = Data.Foldable.all is_zero
305
306 -- | Return a tuple associating the given 'Amount' with its 'Unit'.
307 assoc_by_unit :: Amount -> (Unit, Amount)
308 assoc_by_unit amount = (unit amount, amount)
309
310 -- | Return a 'Data.Map.Map' associating the given 'Amount's with their respective 'Unit'.
311 from_List :: [Amount] -> Amount_by_Unit
312 from_List amounts =
313 Data.Map.fromListWith (flip (+)) $ -- NOTE: flip to propagate 'Style' first to last.
314 Data.List.map assoc_by_unit amounts