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