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