]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Amount.hs
stack: bump to lts-12.25
[comptalang.git] / lcc / Hcompta / LCC / Amount.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE NamedFieldPuns #-}
7 {-# LANGUAGE OverloadedStrings #-}
8 {-# LANGUAGE TupleSections #-}
9 {-# LANGUAGE TypeFamilies #-}
10 {-# LANGUAGE TypeOperators #-}
11 {-# OPTIONS_GHC -fno-warn-orphans #-}
12 module Hcompta.LCC.Amount where
13
14 import Control.DeepSeq
15 import Data.Bool
16 import Data.Char (Char)
17 import Data.Data
18 import Data.Decimal (Decimal, roundTo)
19 import Data.Eq (Eq(..))
20 import Data.Function (($), (.), const, flip)
21 import Data.Map.Strict (Map)
22 import Data.Monoid (Monoid(..))
23 import Data.Ord (Ord(..))
24 import Data.Semigroup (Semigroup(..))
25 import Data.Strict.Maybe
26 import Data.String (IsString)
27 import Data.Text (Text)
28 import Data.Typeable ()
29 import Data.Word (Word8)
30 import Prelude (Int, seq)
31 import Text.Show (Show(..))
32 import qualified Data.Map.Strict as Map
33 import qualified Data.MonoTraversable as MT
34 import qualified Data.Strict as S
35 import qualified Data.Text as T
36
37 import qualified Hcompta as H
38
39 -- * Type 'Amount'
40 data Amount
41 = Amount
42 { amount_unit :: !Unit
43 , amount_quantity :: !Quantity
44 } deriving (Data, Eq, Ord, Show, Typeable)
45
46 -- type instance H.UnitFor Amount = Unit
47 -- type instance H.QuantityFor Amount = H.Polarized Quantity
48
49 instance NFData Amount where
50 rnf (Amount q u) = rnf q `seq` rnf u
51 -- instance H.Amount Amount
52
53 {-
54 type instance H.Unit H.:@ Amount = Unit
55 instance H.GetI H.Unit Amount where
56 getI = amount_unit
57 instance H.SetI H.Unit Amount where
58 setI amount_unit a = a{amount_unit}
59
60 type instance H.Quantity H.:@ Amount = Quantity
61 instance H.GetI H.Quantity Amount where
62 getI = amount_quantity
63 instance H.SetI H.Quantity Amount where
64 setI amount_quantity a = a{amount_quantity}
65 -}
66
67 instance H.Zeroable Amount where
68 zero = Amount "" H.zero
69 instance H.Nullable Amount where
70 null = H.null . amount_quantity
71 -- NOTE: the 'Amount'’s 'amount_quantity' MUST already be rounded
72 -- at 'Amount'’s 'amount_style'’s 'style_amount_precision'.
73 instance H.Signable Amount where
74 sign = H.sign . amount_quantity
75
76 amount :: Amount
77 amount =
78 Amount
79 { amount_unit = ""
80 , amount_quantity = H.zero
81 }
82
83 amount_style :: Style_Amounts -> Amount -> Style_Amount
84 amount_style styles = style_amount_find styles . amount_unit
85
86 -- * Type 'Quantity'
87 type Quantity = Decimal
88
89 quantity_round :: Word8 -> Quantity -> Quantity
90 quantity_round = Data.Decimal.roundTo
91
92 -- * Type 'Unit'
93 newtype Unit
94 = Unit Text
95 deriving (Data, Eq, IsString, Ord, Show, Typeable)
96 instance H.Zeroable Unit where
97 zero = Unit ""
98 instance H.Nullable Unit where
99 null (Unit x) = T.null x
100 {-
101 instance H.Unit Unit where
102 noUnit = Unit ""
103 textUnit (Unit t) = t
104 -}
105 instance NFData Unit where
106 rnf (Unit t) = rnf t
107
108 -- ** Example 'Unit's
109
110 -- | 'H.noUnit'.
111 unit_scalar :: Unit
112 unit_scalar = ""
113
114 -- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
115 unit_chf :: Unit
116 unit_chf = Unit "CHF"
117
118 -- | <https://en.wikipedia.org/wiki/Yuan Yuan> unit of currency.
119 unit_cny :: Unit
120 unit_cny = Unit "Ұ"
121
122 -- | <https://en.wikipedia.org/wiki/Euro Euro> unit of currency.
123 unit_eur :: Unit
124 unit_eur = Unit "€"
125
126 -- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> unit of currency.
127 unit_gbp :: Unit
128 unit_gbp = Unit "£"
129
130 -- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> unit of currency.
131 unit_inr :: Unit
132 unit_inr = Unit "₹"
133
134 -- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> unit of currency.
135 unit_jpy :: Unit
136 unit_jpy = Unit "¥"
137
138 -- | <https://en.wikipedia.org/wiki/Russian_ruble Russian ruble> unit of currency.
139 --
140 -- NOTE: Ꝑ (U+A750) is used as a replacement latin letter,
141 -- because GHC currently chokes on ₽ (U+20BD),
142 -- which is the recently (2014/02) assigned Unicode code-point
143 -- for this currency.
144 unit_rub :: Unit
145 unit_rub = Unit "Ꝑ"
146
147 -- | <https://en.wikipedia.org/wiki/United_States_dollar United States dollar> unit of currency.
148 unit_usd :: Unit
149 unit_usd = Unit "$"
150
151 -- * Type 'Style_Amount'
152 data Style_Amount
153 = Style_Amount
154 { style_amount_fractioning :: !(S.Maybe Style_Amount_Fractioning)
155 , style_amount_grouping_integral :: !(S.Maybe Style_Amount_Grouping)
156 , style_amount_grouping_fractional :: !(S.Maybe Style_Amount_Grouping)
157 , style_amount_unit_side :: !(S.Maybe LR)
158 , style_amount_unit_spaced :: !(S.Maybe Style_Amount_Spacing)
159 -- TODO: , style_amount_sign_plus :: S.Maybe Bool
160 } deriving (Data, Eq, Ord, Show, Typeable)
161 instance NFData Style_Amount where
162 rnf (Style_Amount f gi gf ui up) =
163 rnf f `seq`
164 rnf gi `seq`
165 rnf gf `seq`
166 rnf ui `seq`
167 rnf up
168 instance Semigroup Style_Amount where
169 (<>) = style_amount_union
170 instance Monoid Style_Amount where
171 mempty = style_amount
172 mappend = (<>)
173
174 style_amount :: Style_Amount
175 style_amount =
176 Style_Amount
177 { style_amount_fractioning = Nothing
178 , style_amount_grouping_integral = Nothing
179 , style_amount_grouping_fractional = Nothing
180 , style_amount_unit_side = Nothing
181 , style_amount_unit_spaced = Nothing
182 }
183
184 style_amount_union
185 :: Style_Amount
186 -> Style_Amount
187 -> Style_Amount
188 style_amount_union
189 sty@Style_Amount
190 { style_amount_fractioning=f
191 , style_amount_grouping_integral=gi
192 , style_amount_grouping_fractional=gf
193 , style_amount_unit_side=side
194 , style_amount_unit_spaced=spaced
195 }
196 sty'@Style_Amount
197 { style_amount_fractioning=f'
198 , style_amount_grouping_integral=gi'
199 , style_amount_grouping_fractional=gf'
200 , style_amount_unit_side=side'
201 , style_amount_unit_spaced=spaced'
202 } =
203 if sty == sty'
204 then sty'
205 else
206 Style_Amount
207 { style_amount_fractioning = S.maybe f' (const f) f
208 , style_amount_grouping_integral = S.maybe gi' (const gi) gi
209 , style_amount_grouping_fractional = S.maybe gf' (const gf) gf
210 , style_amount_unit_side = S.maybe side' (const side) side
211 , style_amount_unit_spaced = S.maybe spaced' (const spaced) spaced
212 }
213
214 -- ** Type 'Style_Amount_Fractioning'
215 type Style_Amount_Fractioning
216 = Char
217
218 -- ** Type 'Style_Amount_Grouping'
219 data Style_Amount_Grouping
220 = Style_Amount_Grouping Char [Int]
221 deriving (Data, Eq, Ord, Show, Typeable)
222 instance NFData Style_Amount_Grouping where
223 rnf (Style_Amount_Grouping s d) = rnf s `seq` rnf d
224
225 -- ** Type 'Style_Amount_Precision'
226 type Style_Amount_Precision
227 = Word8
228
229 -- ** Type 'Style_Amount_Spacing'
230 type Style_Amount_Spacing
231 = Bool
232
233 -- ** Type 'LR'
234 data LR = L | R
235 deriving (Data, Eq, Ord, Show, Typeable)
236 instance NFData LR where
237 rnf L = ()
238 rnf R = ()
239
240 -- ** Type 'Style_Amounts'
241 newtype Style_Amounts
242 = Style_Amounts (Map Unit Style_Amount)
243 deriving (Data, Eq, NFData, Ord, Show, Typeable)
244
245 -- type instance H.UnitFor Amounts = Unit
246 -- type instance H.QuantityFor Amounts = Quantity
247
248 instance Semigroup Style_Amounts where
249 Style_Amounts x <> Style_Amounts y =
250 Style_Amounts (Map.unionWith (flip (<>)) x y)
251 instance Monoid Style_Amounts where
252 mempty = Style_Amounts mempty
253 mappend = (<>)
254 instance H.Zeroable Style_Amounts where
255 zero = Style_Amounts mempty
256 instance H.Sumable Style_Amounts (Unit, Style_Amount) where
257 Style_Amounts ss += (u, s) = Style_Amounts $ Map.insertWith (flip (<>)) u s ss
258
259 unStyle_Amounts :: Style_Amounts -> Map Unit Style_Amount
260 unStyle_Amounts (Style_Amounts fp) = fp
261
262 style_amount_find :: Style_Amounts -> Unit -> Style_Amount
263 style_amount_find (Style_Amounts s) u = Map.findWithDefault mempty u s
264
265 -- *** Example 'Style_Amounts'
266 style_amounts :: Style_Amounts
267 style_amounts = Style_Amounts $ Map.fromList
268 [ (unit_scalar,) Style_Amount
269 { style_amount_fractioning = Just '.'
270 , style_amount_grouping_fractional = Just $ Style_Amount_Grouping ',' [3]
271 , style_amount_grouping_integral = Just $ Style_Amount_Grouping ',' [3]
272 , style_amount_unit_side = Just R
273 , style_amount_unit_spaced = Just False
274 }
275 , (unit_chf,) Style_Amount
276 { style_amount_fractioning = Just ','
277 , style_amount_grouping_fractional = Just $ Style_Amount_Grouping '.' [3]
278 , style_amount_grouping_integral = Just $ Style_Amount_Grouping '.' [3]
279 , style_amount_unit_side = Just R
280 , style_amount_unit_spaced = Just False
281 }
282 , (unit_cny,) Style_Amount
283 { style_amount_fractioning = Just ','
284 , style_amount_grouping_fractional = Just $ Style_Amount_Grouping '.' [3]
285 , style_amount_grouping_integral = Just $ Style_Amount_Grouping '.' [3]
286 , style_amount_unit_side = Just R
287 , style_amount_unit_spaced = Just False
288 }
289 , (unit_eur,) Style_Amount
290 { style_amount_fractioning = Just ','
291 , style_amount_grouping_fractional = Just $ Style_Amount_Grouping '.' [3]
292 , style_amount_grouping_integral = Just $ Style_Amount_Grouping '.' [3]
293 , style_amount_unit_side = Just R
294 , style_amount_unit_spaced = Just False
295 }
296 , (unit_gbp,) Style_Amount
297 { style_amount_fractioning = Just '.'
298 , style_amount_grouping_fractional = Just $ Style_Amount_Grouping ',' [3]
299 , style_amount_grouping_integral = Just $ Style_Amount_Grouping ',' [3]
300 , style_amount_unit_side = Just L
301 , style_amount_unit_spaced = Just False
302 }
303 , (unit_inr,) Style_Amount
304 { style_amount_fractioning = Just ','
305 , style_amount_grouping_fractional = Just $ Style_Amount_Grouping '.' [3]
306 , style_amount_grouping_integral = Just $ Style_Amount_Grouping '.' [3]
307 , style_amount_unit_side = Just R
308 , style_amount_unit_spaced = Just False
309 }
310 , (unit_jpy,) Style_Amount
311 { style_amount_fractioning = Just '.'
312 , style_amount_grouping_fractional = Just $ Style_Amount_Grouping ',' [3]
313 , style_amount_grouping_integral = Just $ Style_Amount_Grouping ',' [3]
314 , style_amount_unit_side = Just L
315 , style_amount_unit_spaced = Just False
316 }
317 , (unit_rub,) Style_Amount
318 { style_amount_fractioning = Just '.'
319 , style_amount_grouping_fractional = Just $ Style_Amount_Grouping ',' [3]
320 , style_amount_grouping_integral = Just $ Style_Amount_Grouping ',' [3]
321 , style_amount_unit_side = Just L
322 , style_amount_unit_spaced = Just False
323 }
324 , (unit_usd,) Style_Amount
325 { style_amount_fractioning = Just '.'
326 , style_amount_grouping_fractional = Just $ Style_Amount_Grouping ',' [3]
327 , style_amount_grouping_integral = Just $ Style_Amount_Grouping ',' [3]
328 , style_amount_unit_side = Just L
329 , style_amount_unit_spaced = Just False
330 }
331 ]
332
333 -- ** Type 'Styled_Amount'
334 type Styled_Amount t = (Style_Amount, t)
335
336 styled_amount :: Style_Amounts -> Amount -> Styled_Amount Amount
337 styled_amount styles amt = (amount_style styles amt, amt)
338
339 -- * Type 'Amounts'
340 newtype Amounts = Amounts (Map Unit Quantity)
341 deriving (Data, Eq, NFData, Ord, Show, Typeable
342 , H.Addable, H.Negable, H.Subable)
343 unAmounts :: Amounts -> Map Unit Quantity
344 unAmounts (Amounts a) = a
345 instance H.Zeroable Amounts where
346 zero = Amounts H.zero
347 instance H.Nullable Amounts where
348 null (Amounts x) = H.null x
349 instance Semigroup Amounts where
350 Amounts x <> Amounts y = Amounts (Map.unionWith (flip (H.+)) x y)
351 instance Monoid Amounts where
352 mempty = Amounts mempty
353 mappend = (<>)
354
355 type instance MT.Element Amounts = Amount
356 -- instance H.Amounts Amounts
357
358 -- instance H.Get (H.Balance_Amounts Unit Quantity) Amounts where
359 -- get (Amounts a) = a