]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Amount.hs
Ajout : GNUmakefile : stats.
[comptalang.git] / lib / Hcompta / Amount.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE TypeFamilies #-}
6 {-# LANGUAGE TypeSynonymInstances #-}
7 {-# OPTIONS_GHC -fno-warn-orphans #-}
8 module Hcompta.Amount where
9
10 import Control.DeepSeq
11 import Data.Data
12 import qualified Data.List
13 import qualified Data.Map.Strict as Data.Map
14 import Data.Map.Strict (Map)
15 import qualified Data.Foldable
16 import Data.Typeable ()
17
18 import qualified Hcompta.Balance as Balance
19 import qualified Hcompta.GL as GL
20 import qualified Hcompta.Amount.Quantity as Quantity
21 import qualified Hcompta.Amount.Style as Style
22 import qualified Hcompta.Amount.Unit as Unit
23
24 -- * Type synonyms to submodules
25
26 type Quantity = Quantity.Quantity
27 type Style = Style.Style
28 type Unit = Unit.Unit
29
30 -- * The 'Amount' type
31
32 data Amount
33 = Amount
34 { quantity :: !Quantity
35 , style :: !Style
36 , unit :: !Unit
37 } deriving (Data, Show, Typeable)
38 instance NFData (Amount) where
39 rnf (Amount q s u) = rnf q `seq` rnf s `seq` rnf u
40
41 instance Eq Amount where
42 (==)
43 Amount{quantity=q0, unit=u0}
44 Amount{quantity=q1, unit=u1} =
45 case compare u0 u1 of
46 LT -> False
47 GT -> False
48 EQ -> (==) q0 q1 -- NOTE: MUST already be rounded to Style.precision
49
50 instance Ord Amount where
51 compare
52 Amount{quantity=q0, unit=u0}
53 Amount{quantity=q1, unit=u1} =
54 case compare u0 u1 of
55 LT -> LT
56 GT -> GT
57 EQ -> compare q0 q1 -- NOTE: MUST already be rounded to Style.precision
58
59 instance Balance.Amount Amount where
60 type Amount_Unit Amount = Unit
61 amount_null = (==) Quantity.zero . quantity
62 amount_add = (+)
63 amount_negate = negate
64
65 instance Balance.Amount (Map Unit Amount) where
66 type Amount_Unit (Map Unit Amount) = Unit
67 amount_null = Data.Foldable.all ((==) Quantity.zero . quantity)
68 amount_add = Data.Map.unionWith (+)
69 amount_negate = Data.Map.map negate
70
71 instance GL.Amount Amount where
72 type Amount_Unit Amount = Unit
73 amount_add = (+)
74
75 instance GL.Amount (Map Unit Amount) where
76 type Amount_Unit (Map Unit Amount) = Unit
77 amount_add = Data.Map.unionWith (+)
78
79 -- | An 'Amount' is a partially valid 'Num' instance:
80 --
81 -- * (+) operator requires both operand to have the same 'Unit' (homogeneity constraint).
82 -- * (*) operator requires at least one operand with an empty 'Unit' ('scalar').
83 instance Num Amount where
84 abs a@Amount{quantity=q} = a{quantity=abs q}
85 fromInteger = scalar . fromInteger
86 negate a@Amount{quantity=q} = a{quantity=negate q}
87 signum a@Amount{quantity=q} = a{quantity=signum q}
88 (+) a b =
89 let s@(Style.Style{Style.precision=p}) = Style.union (style a) (style b) in
90 a{ quantity = Quantity.round p $ quantity a + quantity b
91 , style = s
92 , unit =
93 if unit a == unit b
94 then unit a
95 else error "(+) on non-homogeneous units"
96 }
97 (*) a b =
98 let Style.Style{Style.precision=p} = s in
99 a{ quantity = Quantity.round p $ quantity a * quantity b
100 , style = s
101 , unit = u
102 }
103 where (s, u) =
104 if unit a == ""
105 then
106 if unit b == ""
107 then (Style.union (style a) (style b), "")
108 else (style b, unit b)
109 else
110 if unit b == ""
111 then (style a, unit a)
112 else error "(*) by non-scalar unit"
113
114 -- ** Constructors
115
116 nil :: Amount
117 nil =
118 Amount
119 { quantity = Quantity.zero
120 , style = Style.nil
121 , unit = ""
122 }
123
124 -- *** From 'Quantity'
125
126 -- | Return an 'Amount' with 'unit' = Unit.'Unit.nil'.
127 scalar :: Quantity -> Amount
128 scalar q =
129 Amount
130 { quantity = q
131 , style = Style.Style
132 { Style.fractioning = Just '.'
133 , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
134 , Style.grouping_integral = Just $ Style.Grouping ',' [3]
135 , Style.precision = maxBound
136 , Style.unit_side = Just Style.Side_Right
137 , Style.unit_spaced = Just False
138 }
139 , unit = ""
140 }
141
142 -- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
143 chf :: Quantity -> Amount
144 chf q =
145 Amount
146 { quantity = q
147 , style = Style.Style
148 { Style.fractioning = Just ','
149 , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
150 , Style.grouping_integral = Just $ Style.Grouping '.' [3]
151 , Style.precision = 2
152 , Style.unit_side = Just Style.Side_Right
153 , Style.unit_spaced = Just False
154 }
155 , unit = "CHF"
156 }
157 -- | <https://en.wikipedia.org/wiki/Yuan Yuan> unit of currency.
158 cny :: Quantity -> Amount
159 cny q =
160 Amount
161 { quantity = q
162 , style = Style.Style
163 { Style.fractioning = Just ','
164 , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
165 , Style.grouping_integral = Just $ Style.Grouping '.' [3]
166 , Style.precision = 2
167 , Style.unit_side = Just Style.Side_Right
168 , Style.unit_spaced = Just False
169 }
170 , unit = "Ұ"
171 }
172 -- | <https://en.wikipedia.org/wiki/Euro Euro> unit of currency.
173 eur :: Quantity -> Amount
174 eur q =
175 Amount
176 { quantity = q
177 , style = Style.Style
178 { Style.fractioning = Just ','
179 , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
180 , Style.grouping_integral = Just $ Style.Grouping '.' [3]
181 , Style.precision = 2
182 , Style.unit_side = Just Style.Side_Right
183 , Style.unit_spaced = Just False
184 }
185 , unit = "€"
186 }
187 -- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> unit of currency.
188 gbp :: Quantity -> Amount
189 gbp q =
190 Amount
191 { quantity = q
192 , style = Style.Style
193 { Style.fractioning = Just '.'
194 , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
195 , Style.grouping_integral = Just $ Style.Grouping ',' [3]
196 , Style.precision = 2
197 , Style.unit_side = Just Style.Side_Left
198 , Style.unit_spaced = Just False
199 }
200 , unit = "£"
201 }
202 -- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> unit of currency.
203 inr :: Quantity -> Amount
204 inr q =
205 Amount
206 { quantity = q
207 , style = Style.Style
208 { Style.fractioning = Just ','
209 , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
210 , Style.grouping_integral = Just $ Style.Grouping '.' [3]
211 , Style.precision = 2
212 , Style.unit_side = Just Style.Side_Right
213 , Style.unit_spaced = Just False
214 }
215 , unit = "₹"
216 }
217 -- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> unit of currency.
218 jpy :: Quantity -> Amount
219 jpy q =
220 Amount
221 { quantity = q
222 , style = Style.Style
223 { Style.fractioning = Just '.'
224 , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
225 , Style.grouping_integral = Just $ Style.Grouping ',' [3]
226 , Style.precision = 2
227 , Style.unit_side = Just Style.Side_Left
228 , Style.unit_spaced = Just False
229 }
230 , unit = "¥"
231 }
232 -- | <https://en.wikipedia.org/wiki/Russian_ruble Russian ruble> unit of currency.
233 --
234 -- NOTE: Ꝑ (U+A750) is used as a replacement latin letter,
235 -- because GHC currently chokes on ₽ (U+20BD),
236 -- which is the recently (2014/02) assigned Unicode code-point
237 -- for this currency.
238 rub :: Quantity -> Amount
239 rub q =
240 Amount
241 { quantity = q
242 , style = Style.Style
243 { Style.fractioning = Just '.'
244 , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
245 , Style.grouping_integral = Just $ Style.Grouping ',' [3]
246 , Style.precision = 2
247 , Style.unit_side = Just Style.Side_Left
248 , Style.unit_spaced = Just False
249 }
250 , unit = "Ꝑ"
251 }
252 -- | <https://en.wikipedia.org/wiki/United_States_dollar United States dollar> unit of currency.
253 usd :: Quantity -> Amount
254 usd q =
255 Amount
256 { quantity = q
257 , style = Style.Style
258 { Style.fractioning = Just '.'
259 , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
260 , Style.grouping_integral = Just $ Style.Grouping ',' [3]
261 , Style.precision = 2
262 , Style.unit_side = Just Style.Side_Left
263 , Style.unit_spaced = Just False
264 }
265 , unit = "$"
266 }
267
268 -- ** Tests
269
270 -- | Return 'True' if and only if 'Amount'’s 'Quantity' is zero.
271 --
272 -- NOTE: the 'Amount'’s 'quantity' MUST be have been rounded at 'Amount'’s 'style'’s 'Style.precision'.
273 is_zero :: Amount -> Bool
274 is_zero = Quantity.is_zero . quantity
275
276 -- * The 'Amount_by_Unit' mapping
277
278 type Amount_by_Unit
279 = Data.Map.Map Unit Amount
280 type By_Unit = Amount_by_Unit
281
282 -- | 'Amount_by_Unit'’s is a partially valid 'Num' instance.
283 --
284 -- * (*) operator is not defined.
285 instance Num Amount_by_Unit where
286 abs = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=abs q})
287 fromInteger = Data.Map.singleton "" . fromInteger
288 negate = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=negate q})
289 signum = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=signum q})
290 (+) = Data.Map.unionWith (+)
291 (*) = error "(*) not-supported"
292
293 type Signs = (Int, Int)
294
295 signs :: Amount_by_Unit -> Signs
296 signs = Data.Map.foldl
297 (\(nega, plus) amt ->
298 case flip compare 0 $ quantity amt of
299 LT -> (nega - 1, plus)
300 EQ -> (nega, plus)
301 GT -> (nega, plus + 1))
302 (0, 0)
303
304 -- ** Constructors
305
306 nil_By_Unit :: Amount_by_Unit
307 nil_By_Unit =
308 Data.Map.empty
309
310 -- ** Tests
311
312 -- | Return 'True' if and only if all 'Amount's satisfy 'is_zero'.
313 are_zero :: Amount_by_Unit -> Bool
314 are_zero = Data.Foldable.all is_zero
315
316 -- | Return a tuple associating the given 'Amount' with its 'Unit'.
317 assoc_by_unit :: Amount -> (Unit, Amount)
318 assoc_by_unit amount = (unit amount, amount)
319
320 -- | Return a 'Data.Map.Map' associating the given 'Amount's with their respective 'Unit'.
321 from_List :: [Amount] -> Amount_by_Unit
322 from_List amounts =
323 Data.Map.fromListWith (flip (+)) $ -- NOTE: flip to propagate 'Style' first to last.
324 Data.List.map assoc_by_unit amounts
325
326 -- * Type 'Sum'
327
328 -- ** Class 'Sumable'
329 class
330 ( Data (Sumable_Unit a)
331 , Data a
332 , Eq a
333 , Ord (Sumable_Unit a)
334 , Show (Sumable_Unit a)
335 , Show a
336 , Typeable (Sumable_Unit a)
337 , Typeable a
338 ) => Sumable a where
339 type Sumable_Unit a
340 -- sumable_add :: a -> a -> a
341 sumable_positive :: a -> Maybe a
342 sumable_negative :: a -> Maybe a
343
344 instance Sumable Amount where
345 type Sumable_Unit Amount = Unit
346 -- sumable_add = (+)
347 sumable_positive a =
348 case compare (quantity a) Quantity.zero of
349 LT -> Nothing
350 EQ -> Nothing
351 _ -> Just a
352 sumable_negative a =
353 case compare (quantity a) Quantity.zero of
354 GT -> Nothing
355 EQ -> Nothing
356 _ -> Just a
357
358 instance Sumable (Map Unit Amount) where
359 type Sumable_Unit (Map Unit Amount) = Unit
360 -- sumable_add = (+)
361 sumable_positive a =
362 let r = Data.Map.mapMaybe sumable_positive a in
363 if Data.Map.null r
364 then Nothing
365 else Just r
366 sumable_negative a =
367 let r = Data.Map.mapMaybe sumable_negative a in
368 if Data.Map.null r
369 then Nothing
370 else Just r
371
372 instance Sumable amount => Sumable (Sum amount) where
373 type Sumable_Unit (Sum amount) = Sumable_Unit amount
374 sumable_negative amt =
375 case amt of
376 Sum_Negative _ -> Just $ amt
377 Sum_Positive _ -> Nothing
378 Sum_Both n _ -> Just $ Sum_Negative n
379 sumable_positive amt =
380 case amt of
381 Sum_Negative _ -> Nothing
382 Sum_Positive _ -> Just $ amt
383 Sum_Both _ p -> Just $ Sum_Positive p
384
385 -- | Sum separately keeping track of negative and positive 'amount's.
386 data Sum amount
387 = Sum_Negative !amount
388 | Sum_Positive !amount
389 | Sum_Both !amount !amount
390 deriving (Data, Eq, Show, Typeable)
391 instance NFData amount => NFData (Sum amount) where
392 rnf (Sum_Negative a) = rnf a
393 rnf (Sum_Positive a) = rnf a
394 rnf (Sum_Both a0 a1) = rnf a0 `seq` rnf a1
395
396 instance Functor Sum where
397 fmap f (Sum_Negative a) = Sum_Negative (f a)
398 fmap f (Sum_Positive a) = Sum_Positive (f a)
399 fmap f (Sum_Both a0 a1) = Sum_Both (f a0) (f a1)
400
401 instance Balance.Amount a
402 => Balance.Amount (Sum a) where
403 type Amount_Unit (Sum a) = Balance.Amount_Unit a
404 amount_null amt =
405 case amt of
406 Sum_Negative n -> Balance.amount_null n
407 Sum_Positive p -> Balance.amount_null p
408 Sum_Both n p -> Balance.amount_null (Balance.amount_add n p)
409 amount_add a0 a1 =
410 case (a0, a1) of
411 (Sum_Negative n0, Sum_Negative n1) -> Sum_Negative (Balance.amount_add n0 n1)
412 (Sum_Negative n , Sum_Positive p) -> Sum_Both n p
413 (Sum_Negative n0, Sum_Both n1 p) -> Sum_Both (Balance.amount_add n0 n1) p
414
415 (Sum_Positive p , Sum_Negative n) -> Sum_Both n p
416 (Sum_Positive p0, Sum_Positive p1) -> Sum_Positive (Balance.amount_add p0 p1)
417 (Sum_Positive p , Sum_Both n1 p1) -> Sum_Both n1 (Balance.amount_add p p1)
418
419 (Sum_Both n0 p0, Sum_Negative n) -> Sum_Both (Balance.amount_add n0 n) p0
420 (Sum_Both n0 p0, Sum_Positive p1) -> Sum_Both n0 (Balance.amount_add p0 p1)
421 (Sum_Both n0 p0, Sum_Both n1 p1) -> Sum_Both (Balance.amount_add n0 n1) (Balance.amount_add p0 p1)
422 amount_negate amt =
423 case amt of
424 Sum_Negative n -> Sum_Positive $ Balance.amount_negate n
425 Sum_Positive p -> Sum_Negative $ Balance.amount_negate p
426 Sum_Both n p -> Sum_Both (Balance.amount_negate p) (Balance.amount_negate n)
427
428 instance GL.Amount (Sum (Map Unit Amount)) where
429 type Amount_Unit (Sum (Map Unit Amount)) = Unit
430 amount_add a0 a1 =
431 case (a0, a1) of
432 (Sum_Negative n0, Sum_Negative n1) -> Sum_Negative (GL.amount_add n0 n1)
433 (Sum_Negative n , Sum_Positive p) -> Sum_Both n p
434 (Sum_Negative n0, Sum_Both n1 p) -> Sum_Both (GL.amount_add n0 n1) p
435
436 (Sum_Positive p , Sum_Negative n) -> Sum_Both n p
437 (Sum_Positive p0, Sum_Positive p1) -> Sum_Positive (GL.amount_add p0 p1)
438 (Sum_Positive p , Sum_Both n1 p1) -> Sum_Both n1 (GL.amount_add p p1)
439
440 (Sum_Both n0 p0, Sum_Negative n) -> Sum_Both (GL.amount_add n0 n) p0
441 (Sum_Both n0 p0, Sum_Positive p1) -> Sum_Both n0 (GL.amount_add p0 p1)
442 (Sum_Both n0 p0, Sum_Both n1 p1) -> Sum_Both (GL.amount_add n0 n1) (GL.amount_add p0 p1)
443
444 sum
445 :: Sumable amount
446 => amount -> Sum amount
447 sum amt =
448 case ( sumable_negative amt
449 , sumable_positive amt ) of
450 (Just n, Nothing) -> Sum_Negative n
451 (Nothing, Just p) -> Sum_Positive p
452 (Just n, Just p) -> Sum_Both n p
453 (Nothing, Nothing) -> Sum_Both amt amt
454
455 sum_negative
456 :: Sum amount -> Maybe amount
457 sum_negative amt =
458 case amt of
459 Sum_Negative n -> Just n
460 Sum_Positive _ -> Nothing
461 Sum_Both n _ -> Just n
462
463 sum_positive
464 :: Sum amount -> Maybe amount
465 sum_positive amt =
466 case amt of
467 Sum_Negative _ -> Nothing
468 Sum_Positive p -> Just p
469 Sum_Both _ p -> Just p
470
471 sum_balance
472 :: GL.Amount amount
473 => Sum amount -> amount
474 sum_balance amt =
475 case amt of
476 Sum_Negative n -> n
477 Sum_Positive p -> p
478 Sum_Both n p -> GL.amount_add n p