]> Git — Sourcephile - comptalang.git/blob - jcc/Hcompta/Format/JCC/Amount.hs
Correction : Calculus.Lambda.Omega.Explicit.REPL : broutille administrative.
[comptalang.git] / jcc / Hcompta / Format / JCC / Amount.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
5 {-# LANGUAGE OverloadedStrings #-}
6 {-# LANGUAGE StandaloneDeriving #-}
7 {-# LANGUAGE TupleSections #-}
8 {-# LANGUAGE TypeFamilies #-}
9 {-# OPTIONS_GHC -fno-warn-orphans #-}
10 module Hcompta.Format.JCC.Amount where
11
12 import Control.DeepSeq
13 import Data.Bool
14 import Data.Char (Char)
15 import Data.Data
16 import Data.Decimal
17 import Data.Eq (Eq(..))
18 import Data.Function (($), (.), const)
19 import Data.Map.Strict (Map)
20 import qualified Data.Map.Strict as Map
21 import Data.Maybe (Maybe(..), maybe)
22 import Data.Monoid (Monoid(..))
23 import Data.Ord (Ord(..), Ordering(..))
24 import Data.Text (Text)
25 import Data.String (IsString)
26 import Data.Typeable ()
27 import Data.Word (Word8)
28 import Prelude (Int, seq)
29 import Text.Show (Show(..))
30
31 import qualified Hcompta.Amount as Amount
32 import qualified Hcompta.Filter as Filter
33 import qualified Hcompta.Filter.Amount as Filter.Amount
34 import qualified Hcompta.Polarize as Polarize
35 import qualified Hcompta.Quantity as Quantity
36 import qualified Hcompta.Unit as Unit
37
38
39 -- * Type 'Quantity'
40
41 type Quantity = Filter.Amount.Quantity
42
43 -- ** Operators
44
45 quantity_round :: Word8 -> Quantity -> Quantity
46 quantity_round = Data.Decimal.roundTo
47
48 -- * Type 'Unit'
49
50 newtype Unit
51 = Unit Text
52 deriving (Data, Eq, IsString, Ord, Show, Typeable)
53 instance Unit.Unit Unit where
54 unit_empty = Unit ""
55 unit_text (Unit t) = t
56 instance NFData Unit where
57 rnf (Unit t) = rnf t
58
59 -- ** Example 'Unit's
60
61 -- | 'Unit.unit_empty'.
62 unit_scalar :: Unit
63 unit_scalar = Unit.unit_empty
64
65 -- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
66 unit_chf :: Unit
67 unit_chf = Unit "CHF"
68
69 -- | <https://en.wikipedia.org/wiki/Yuan Yuan> unit of currency.
70 unit_cny :: Unit
71 unit_cny = Unit "Ұ"
72
73 -- | <https://en.wikipedia.org/wiki/Euro Euro> unit of currency.
74 unit_eur :: Unit
75 unit_eur = Unit "€"
76
77 -- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> unit of currency.
78 unit_gbp :: Unit
79 unit_gbp = Unit "£"
80
81 -- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> unit of currency.
82 unit_inr :: Unit
83 unit_inr = Unit "₹"
84
85 -- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> unit of currency.
86 unit_jpy :: Unit
87 unit_jpy = Unit "¥"
88
89 -- | <https://en.wikipedia.org/wiki/Russian_ruble Russian ruble> unit of currency.
90 --
91 -- NOTE: Ꝑ (U+A750) is used as a replacement latin letter,
92 -- because GHC currently chokes on ₽ (U+20BD),
93 -- which is the recently (2014/02) assigned Unicode code-point
94 -- for this currency.
95 unit_rub :: Unit
96 unit_rub = Unit "Ꝑ"
97
98 -- | <https://en.wikipedia.org/wiki/United_States_dollar United States dollar> unit of currency.
99 unit_usd :: Unit
100 unit_usd = Unit "$"
101
102 -- * Type 'Amount_Style'
103
104 data Amount_Style
105 = Amount_Style
106 { amount_style_fractioning :: Maybe Amount_Style_Fractioning
107 , amount_style_grouping_integral :: Maybe Amount_Style_Grouping
108 , amount_style_grouping_fractional :: Maybe Amount_Style_Grouping
109 -- TODO: , amount_style_sign_plus :: Maybe Bool
110 , amount_style_unit_side :: Maybe Amount_Style_Side
111 , amount_style_unit_spaced :: Maybe Amount_Style_Spacing
112 } deriving (Data, Eq, Ord, Show, Typeable)
113 instance NFData Amount_Style where
114 rnf (Amount_Style f gi gf ui up) =
115 rnf f `seq`
116 rnf gi `seq`
117 rnf gf `seq`
118 rnf ui `seq`
119 rnf up
120 instance Monoid Amount_Style where
121 mempty = amount_style
122 mappend = amount_style_union
123
124 amount_style :: Amount_Style
125 amount_style =
126 Amount_Style
127 { amount_style_fractioning = Nothing
128 , amount_style_grouping_integral = Nothing
129 , amount_style_grouping_fractional = Nothing
130 , amount_style_unit_side = Nothing
131 , amount_style_unit_spaced = Nothing
132 }
133
134 amount_style_union :: Amount_Style -> Amount_Style -> Amount_Style
135 amount_style_union
136 sty@Amount_Style
137 { amount_style_fractioning=f
138 , amount_style_grouping_integral=gi
139 , amount_style_grouping_fractional=gf
140 , amount_style_unit_side=side
141 , amount_style_unit_spaced=spaced
142 }
143 sty'@Amount_Style
144 { amount_style_fractioning=f'
145 , amount_style_grouping_integral=gi'
146 , amount_style_grouping_fractional=gf'
147 , amount_style_unit_side=side'
148 , amount_style_unit_spaced=spaced'
149 } =
150 if sty == sty'
151 then sty'
152 else
153 Amount_Style
154 { amount_style_fractioning = maybe f' (const f) f
155 , amount_style_grouping_integral = maybe gi' (const gi) gi
156 , amount_style_grouping_fractional = maybe gf' (const gf) gf
157 , amount_style_unit_side = maybe side' (const side) side
158 , amount_style_unit_spaced = maybe spaced' (const spaced) spaced
159 }
160
161 -- ** Type 'Amount_Style_Fractioning'
162
163 type Amount_Style_Fractioning
164 = Char
165
166 -- ** Type 'Amount_Style_Grouping'
167
168 data Amount_Style_Grouping
169 = Amount_Style_Grouping Char [Int]
170 deriving (Data, Eq, Ord, Show, Typeable)
171 instance NFData Amount_Style_Grouping where
172 rnf (Amount_Style_Grouping s d) = rnf s `seq` rnf d
173
174 -- ** Type 'Amount_Style_Precision'
175
176 type Amount_Style_Precision
177 = Word8
178
179 -- ** Type 'Amount_Style_Spacing'
180
181 type Amount_Style_Spacing
182 = Bool
183
184 -- ** Type 'Amount_Style_Side'
185
186 data Amount_Style_Side
187 = Amount_Style_Side_Left
188 | Amount_Style_Side_Right
189 deriving (Data, Eq, Ord, Show, Typeable)
190 instance NFData Amount_Style_Side where
191 rnf Amount_Style_Side_Left = ()
192 rnf Amount_Style_Side_Right = ()
193
194 -- ** Type 'Amount_Styles'
195
196 newtype Amount_Styles
197 = Amount_Styles (Map Unit Amount_Style)
198 deriving (Data, Eq, NFData, Show, Typeable)
199 instance Monoid Amount_Styles where
200 mempty = Amount_Styles mempty
201 mappend (Amount_Styles x) (Amount_Styles y) =
202 Amount_Styles (Map.unionWith mappend x y)
203
204 -- ** Operators
205
206 amount_style_cons :: (Unit, Amount_Style) -> Amount_Styles -> Amount_Styles
207 amount_style_cons (u, s) (Amount_Styles ss) =
208 Amount_Styles $
209 Map.insertWith mappend u s ss
210
211 amount_style_find :: Amount_Styles -> Unit -> Amount_Style
212 amount_style_find (Amount_Styles s) u = Map.findWithDefault mempty u s
213
214 -- *** Example 'Amount_Styles'
215
216 amount_styles :: Amount_Styles
217 amount_styles = Amount_Styles $ Map.fromList
218 [ (unit_scalar,) Amount_Style
219 { amount_style_fractioning = Just '.'
220 , amount_style_grouping_fractional = Just $ Amount_Style_Grouping ',' [3]
221 , amount_style_grouping_integral = Just $ Amount_Style_Grouping ',' [3]
222 , amount_style_unit_side = Just Amount_Style_Side_Right
223 , amount_style_unit_spaced = Just False
224 }
225 , (unit_chf,) Amount_Style
226 { amount_style_fractioning = Just ','
227 , amount_style_grouping_fractional = Just $ Amount_Style_Grouping '.' [3]
228 , amount_style_grouping_integral = Just $ Amount_Style_Grouping '.' [3]
229 , amount_style_unit_side = Just Amount_Style_Side_Right
230 , amount_style_unit_spaced = Just False
231 }
232 , (unit_cny,) Amount_Style
233 { amount_style_fractioning = Just ','
234 , amount_style_grouping_fractional = Just $ Amount_Style_Grouping '.' [3]
235 , amount_style_grouping_integral = Just $ Amount_Style_Grouping '.' [3]
236 , amount_style_unit_side = Just Amount_Style_Side_Right
237 , amount_style_unit_spaced = Just False
238 }
239 , (unit_eur,) Amount_Style
240 { amount_style_fractioning = Just ','
241 , amount_style_grouping_fractional = Just $ Amount_Style_Grouping '.' [3]
242 , amount_style_grouping_integral = Just $ Amount_Style_Grouping '.' [3]
243 , amount_style_unit_side = Just Amount_Style_Side_Right
244 , amount_style_unit_spaced = Just False
245 }
246 , (unit_gbp,) Amount_Style
247 { amount_style_fractioning = Just '.'
248 , amount_style_grouping_fractional = Just $ Amount_Style_Grouping ',' [3]
249 , amount_style_grouping_integral = Just $ Amount_Style_Grouping ',' [3]
250 , amount_style_unit_side = Just Amount_Style_Side_Left
251 , amount_style_unit_spaced = Just False
252 }
253 , (unit_inr,) Amount_Style
254 { amount_style_fractioning = Just ','
255 , amount_style_grouping_fractional = Just $ Amount_Style_Grouping '.' [3]
256 , amount_style_grouping_integral = Just $ Amount_Style_Grouping '.' [3]
257 , amount_style_unit_side = Just Amount_Style_Side_Right
258 , amount_style_unit_spaced = Just False
259 }
260 , (unit_jpy,) Amount_Style
261 { amount_style_fractioning = Just '.'
262 , amount_style_grouping_fractional = Just $ Amount_Style_Grouping ',' [3]
263 , amount_style_grouping_integral = Just $ Amount_Style_Grouping ',' [3]
264 , amount_style_unit_side = Just Amount_Style_Side_Left
265 , amount_style_unit_spaced = Just False
266 }
267 , (unit_rub,) Amount_Style
268 { amount_style_fractioning = Just '.'
269 , amount_style_grouping_fractional = Just $ Amount_Style_Grouping ',' [3]
270 , amount_style_grouping_integral = Just $ Amount_Style_Grouping ',' [3]
271 , amount_style_unit_side = Just Amount_Style_Side_Left
272 , amount_style_unit_spaced = Just False
273 }
274 , (unit_usd,) Amount_Style
275 { amount_style_fractioning = Just '.'
276 , amount_style_grouping_fractional = Just $ Amount_Style_Grouping ',' [3]
277 , amount_style_grouping_integral = Just $ Amount_Style_Grouping ',' [3]
278 , amount_style_unit_side = Just Amount_Style_Side_Left
279 , amount_style_unit_spaced = Just False
280 }
281 ]
282
283 -- ** Type 'Amount_Styled'
284
285 type Amount_Styled t = (Amount_Style, t)
286
287 amount_styled :: Amount_Styles -> Amount -> Amount_Styled Amount
288 amount_styled styles amt = (amount_amount_style styles amt, amt)
289
290 -- * Type 'Amount'
291
292 data Amount
293 = Amount
294 { amount_unit :: !Unit
295 , amount_quantity :: !Quantity
296 } deriving (Data, Show, Typeable)
297 instance Amount.Amount Amount where
298 type Amount_Quantity Amount = Quantity
299 type Amount_Unit Amount = Unit
300 amount_quantity = amount_quantity
301 amount_unit = amount_unit
302 instance Filter.Amount Amount where
303 type Amount_Quantity Amount = Quantity
304 type Amount_Unit Amount = Unit
305 amount_quantity = Polarize.polarize . amount_quantity
306 amount_unit = amount_unit
307 instance NFData Amount where
308 rnf (Amount q u) = rnf q `seq` rnf u
309 instance Quantity.Zero Amount where
310 quantity_zero = Amount Unit.unit_empty Quantity.quantity_zero
311 quantity_null = (==) Quantity.quantity_zero . amount_quantity
312
313 amount :: Amount
314 amount =
315 Amount
316 { amount_quantity = Quantity.quantity_zero
317 , amount_unit = ""
318 }
319
320 -- ** Extractors
321
322 amount_amount_style :: Amount_Styles -> Amount -> Amount_Style
323 amount_amount_style styles = amount_style_find styles . amount_unit
324
325 amount_sign :: Amount -> Ordering
326 amount_sign a =
327 case amount_quantity a of
328 0 -> EQ
329 q | q < 0 -> LT
330 _ -> GT
331
332 -- | Return 'True' if and only if 'Amount'’s 'Quantity' is zero.
333 --
334 -- NOTE: the 'Amount'’s 'amount_quantity' MUST already be rounded
335 -- at 'Amount'’s 'amount_amount_style'’s 'amount_style_precision'.
336 amount_null :: Amount -> Bool
337 amount_null = Quantity.quantity_null . amount_quantity
338
339 {-
340 instance Eq Amount where
341 (==)
342 Amount{amount_quantity=q0, amount_unit=u0}
343 Amount{amount_quantity=q1, amount_unit=u1} =
344 case compare u0 u1 of
345 LT -> False
346 GT -> False
347 EQ -> (==) q0 q1 -- NOTE: MUST already be rounded to amount_style_precision
348 instance Ord Amount where
349 compare
350 Amount{amount_quantity=q0, amount_unit=u0}
351 Amount{amount_quantity=q1, amount_unit=u1} =
352 case compare u0 u1 of
353 LT -> LT
354 GT -> GT
355 EQ -> compare q0 q1 -- NOTE: MUST already be rounded to amount_style_precision
356 -}
357 {-
358 instance GL.Amount Amount where
359 type Amount_Unit Amount = Unit
360 amount_add = (+)
361 instance GL.Amount (Map Unit Amount) where
362 type Amount_Unit (Map Unit Amount) = Unit
363 amount_add = Data.Map.unionWith (+)
364 -}
365
366 {-
367 -- | An 'Amount' is a partially valid 'Num' instance:
368 --
369 -- * (+) operator requires both operand to have the same 'Unit' (homogeneity constraint).
370 -- * (*) operator requires at least one operand with an empty 'Unit' ('scalar').
371 instance Num Amount where
372 abs a@Amount{amount_quantity=q} = a{amount_quantity=abs q}
373 fromInteger = scalar . fromInteger
374 negate a@Amount{amount_quantity=q} = a{amount_quantity=negate q}
375 signum a@Amount{amount_quantity=q} = a{amount_quantity=signum q}
376 (+) a b =
377 let s@(Style.Style{Style.precision=p}) = Style.union (amount_style a) (amount_style b) in
378 a{ amount_quantity = quantity_round p $ amount_quantity a + amount_quantity b
379 , amount_style = s
380 , amount_unit =
381 if amount_unit a == amount_unit b
382 then amount_unit a
383 else error "(+) on non-homogeneous units"
384 }
385 (*) a b =
386 let Style.Style{Style.precision=p} = s in
387 a{ amount_quantity = quantity_round p $ amount_quantity a * amount_quantity b
388 , amount_style = s
389 , amount_unit = u
390 }
391 where (s, u)
392 | amount_unit a == "" =
393 if amount_unit b == ""
394 then (Style.union (amount_style a) (amount_style b), "")
395 else (amount_style b, amount_unit b)
396 | amount_unit b == "" = (amount_style a, amount_unit a)
397 | otherwise = error "(*) by non-scalar amount_unit"
398 -}
399
400 {-
401 -- * Type 'Amount_by_Unit' mapping
402
403 type Amount_by_Unit
404 = Map Unit Amount
405 type By_Unit = Amount_by_Unit
406
407 -- | 'Amount_by_Unit'’s is a partially valid 'Num' instance.
408 --
409 -- * (*) operator is not defined.
410 instance Num Amount_by_Unit where
411 abs = Data.Map.map (\a@Amount{amount_quantity=q} -> a{amount_quantity=abs q})
412 fromInteger = Data.Map.singleton "" . fromInteger
413 negate = Data.Map.map (\a@Amount{amount_quantity=q} -> a{amount_quantity=negate q})
414 signum = Data.Map.map (\a@Amount{amount_quantity=q} -> a{amount_quantity=signum q})
415 (+) = Data.Map.unionWith (+)
416 (*) = error "(*) not-supported"
417
418 type Signs = (Int, Int)
419
420 signs :: Amount_by_Unit -> Signs
421 signs = Data.Map.foldl'
422 (\(nega, plus) amt ->
423 case flip compare 0 $ amount_quantity amt of
424 LT -> (nega - 1, plus)
425 EQ -> (nega, plus)
426 GT -> (nega, plus + 1))
427 (0, 0)
428
429 -- ** Constructors
430
431 nil_By_Unit :: Amount_by_Unit
432 nil_By_Unit =
433 Data.Map.empty
434
435 -- ** Tests
436
437 -- | Return 'True' if and only if all 'Amount's satisfy 'null'.
438 amount_nulls :: Amount_by_Unit -> Bool
439 amount_nulls = all amount_null
440
441 -- | Return a tuple associating the given 'Amount' with its 'Unit'.
442 assoc_by_unit :: Amount -> (Unit, Amount)
443 assoc_by_unit amt = (amount_unit amt, amt)
444
445 -- | Return a 'Data.Map.Map' associating the given 'Amount's with their respective 'Unit'.
446 from_List :: [Amount] -> Amount_by_Unit
447 from_List amounts =
448 Data.Map.fromListWith (flip (+)) $ -- NOTE: flip to propagate 'Style' first to last.
449 Data.List.map assoc_by_unit amounts
450
451 -}