]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Model/Amount.hs
Ajout : Hcompta.Format.Text : couleurs ANSI.
[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 at 'Style'’s precision.
243 is_zero :: Amount -> Bool
244 is_zero = Quantity.is_zero . quantity
245
246 -- * The 'By_Unit' mapping
247
248 type By_Unit
249 = Data.Map.Map Unit Amount
250
251 -- | 'By_Unit'’s is a partially valid 'Num' instance.
252 --
253 -- * (*) operator is not defined.
254 instance Num By_Unit where
255 abs = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=abs q})
256 fromInteger = Data.Map.singleton "" . fromInteger
257 negate = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=negate q})
258 signum = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=signum q})
259 (+) = Data.Map.unionWith (+)
260 (*) = error "(*) not-supported"
261
262 type Signs = (Int, Int)
263
264 signs :: By_Unit -> Signs
265 signs = Data.Map.foldl
266 (\(nega, plus) amt ->
267 case flip compare 0 $ quantity amt of
268 LT -> (nega - 1, plus)
269 EQ -> (nega, plus)
270 GT -> (nega, plus + 1))
271 (0, 0)
272
273 -- ** Constructors
274
275 nil_By_Unit :: By_Unit
276 nil_By_Unit =
277 Data.Map.empty
278
279 -- ** Tests
280
281 -- | Return 'True' if and only if all 'Amount's are zero at their 'Style'’s precision.
282 are_zero :: By_Unit -> Bool
283 are_zero = Data.Foldable.all is_zero
284
285 -- | Return a tuple associating the given 'Amount' with its 'Unit'.
286 assoc_by_unit :: Amount -> (Unit, Amount)
287 assoc_by_unit amount = (unit amount, amount)
288
289 -- | Return a 'Data.Map.Map' associating the given 'Amount's with their respective 'Unit'.
290 from_List :: [Amount] -> By_Unit
291 from_List amounts =
292 Data.Map.fromListWith (flip (+)) $ -- NOTE: flip to propagate 'Style' first to last.
293 Data.List.map assoc_by_unit amounts