]> Git — Sourcephile - comptalang.git/blob - jcc/Hcompta/JCC/Amount.hs
Simplify hcompta-lib.
[comptalang.git] / jcc / Hcompta / JCC / 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.JCC.Amount where
10
11 import Control.DeepSeq
12 import Data.Bool
13 import Data.Char (Char)
14 import Data.Data
15 import Data.Decimal (Decimal, roundTo)
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.Amount as H
31 import qualified Hcompta.Quantity as H
32 import qualified Hcompta.Unit as H
33 -- import qualified Hcompta.Polarize as Polarize
34 -- import qualified Hcompta.Quantity as Quantity
35
36 -- * Type 'Quantity'
37
38 type Quantity = Decimal
39
40 -- ** Operators
41
42 quantity_round :: Word8 -> Quantity -> Quantity
43 quantity_round = Data.Decimal.roundTo
44
45 -- * Type 'Unit'
46
47 newtype Unit
48 = Unit Text
49 deriving (Data, Eq, IsString, Ord, Show, Typeable)
50 instance H.Unit Unit where
51 unit_empty = Unit ""
52 unit_text (Unit t) = t
53 instance NFData Unit where
54 rnf (Unit t) = rnf t
55
56 -- ** Example 'Unit's
57
58 -- | 'H.unit_empty'.
59 unit_scalar :: Unit
60 unit_scalar = H.unit_empty
61
62 -- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
63 unit_chf :: Unit
64 unit_chf = Unit "CHF"
65
66 -- | <https://en.wikipedia.org/wiki/Yuan Yuan> unit of currency.
67 unit_cny :: Unit
68 unit_cny = Unit "Ұ"
69
70 -- | <https://en.wikipedia.org/wiki/Euro Euro> unit of currency.
71 unit_eur :: Unit
72 unit_eur = Unit "€"
73
74 -- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> unit of currency.
75 unit_gbp :: Unit
76 unit_gbp = Unit "£"
77
78 -- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> unit of currency.
79 unit_inr :: Unit
80 unit_inr = Unit "₹"
81
82 -- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> unit of currency.
83 unit_jpy :: Unit
84 unit_jpy = Unit "¥"
85
86 -- | <https://en.wikipedia.org/wiki/Russian_ruble Russian ruble> unit of currency.
87 --
88 -- NOTE: Ꝑ (U+A750) is used as a replacement latin letter,
89 -- because GHC currently chokes on ₽ (U+20BD),
90 -- which is the recently (2014/02) assigned Unicode code-point
91 -- for this currency.
92 unit_rub :: Unit
93 unit_rub = Unit "Ꝑ"
94
95 -- | <https://en.wikipedia.org/wiki/United_States_dollar United States dollar> unit of currency.
96 unit_usd :: Unit
97 unit_usd = Unit "$"
98
99 -- * Type 'Amount_Style'
100
101 data Amount_Style
102 = Amount_Style
103 { amount_style_fractioning :: Maybe Amount_Style_Fractioning
104 , amount_style_grouping_integral :: Maybe Amount_Style_Grouping
105 , amount_style_grouping_fractional :: Maybe Amount_Style_Grouping
106 -- TODO: , amount_style_sign_plus :: Maybe Bool
107 , amount_style_unit_side :: Maybe Amount_Style_Side
108 , amount_style_unit_spaced :: Maybe Amount_Style_Spacing
109 } deriving (Data, Eq, Ord, Show, Typeable)
110 instance NFData Amount_Style where
111 rnf (Amount_Style f gi gf ui up) =
112 rnf f `seq`
113 rnf gi `seq`
114 rnf gf `seq`
115 rnf ui `seq`
116 rnf up
117 instance Monoid Amount_Style where
118 mempty = amount_style
119 mappend = amount_style_union
120
121 amount_style :: Amount_Style
122 amount_style =
123 Amount_Style
124 { amount_style_fractioning = Nothing
125 , amount_style_grouping_integral = Nothing
126 , amount_style_grouping_fractional = Nothing
127 , amount_style_unit_side = Nothing
128 , amount_style_unit_spaced = Nothing
129 }
130
131 amount_style_union
132 :: Amount_Style
133 -> Amount_Style
134 -> 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, Eq, Show, Typeable)
297 instance NFData Amount where
298 rnf (Amount q u) =
299 rnf q `seq`
300 rnf u
301 instance H.Amount Amount where
302 type Amount_Quantity Amount = Quantity
303 type Amount_Unit Amount = Unit
304 amount_quantity = amount_quantity
305 amount_unit = amount_unit
306 instance H.Zero Amount where
307 quantity_zero = Amount H.unit_empty H.quantity_zero
308 quantity_null = (==) H.quantity_zero . amount_quantity
309
310 amount :: Amount
311 amount =
312 Amount
313 { amount_quantity = H.quantity_zero
314 , amount_unit = ""
315 }
316
317 -- ** Extractors
318
319 amount_amount_style :: Amount_Styles -> Amount -> Amount_Style
320 amount_amount_style styles = amount_style_find styles . amount_unit
321
322 amount_sign :: Amount -> Ordering
323 amount_sign a =
324 case amount_quantity a of
325 0 -> EQ
326 q | q < 0 -> LT
327 _ -> GT
328
329 -- | Return 'True' if and only if 'Amount'’s 'Quantity' is zero.
330 --
331 -- NOTE: the 'Amount'’s 'amount_quantity' MUST already be rounded
332 -- at 'Amount'’s 'amount_amount_style'’s 'amount_style_precision'.
333 amount_null :: Amount -> Bool
334 amount_null = H.quantity_null . amount_quantity