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