1 {-# LANGUAGE NoOverloadedLists #-}
2 module Symantic.Compta.Calc.Unit where
4 import Control.DeepSeq (NFData)
5 --import Data.Word (Word8)
6 import Data.Bool (Bool(..))
7 import Data.Char (Char)
11 import GHC.Stack (HasCallStack)
12 import GHC.Generics (Generic)
13 import Data.String (String)
14 import Data.Functor ((<$>))
15 import Data.Monoid (Monoid(..))
16 import Data.Function (flip)
17 import Data.Semigroup (Semigroup(..))
18 import Text.Show (Show)
19 import qualified Data.Map.Strict as Map
20 import qualified Data.Char as Char
22 import Symantic.Compta.Lang
23 import Symantic.Compta.Utils.Error
28 class Unitable repr where
29 unit :: HasCallStack => Ty repr TyUnit -> repr a -> repr a
30 --withUnit :: repr U -> repr a -> repr a
32 --withEuro :: repr a -> repr a
33 --withEuro = withUnit euro
36 class EURable repr where
37 eur :: repr TyQuantity -> repr TyAmount
38 (€) :: EURable repr => repr TyQuantity -> repr TyAmount
41 class USDable repr where
42 usd :: repr TyQuantity -> repr TyAmount
46 newtype Unit = Unit String
47 deriving newtype (Eq, Ord, Show, NFData)
48 deriving anyclass (Generic)
49 instance IsString Unit where
51 s@[c] | Char.CurrencySymbol <- Char.generalCategory c -> Unit s
53 _ -> errorWithStack "Unit"
56 newtype Quantity qty = Quantity qty
57 deriving newtype (Eq, Show, NFData, Zeroable, Nullable, Addable, Negable, FromInteger, FromRational)
58 instance Addable a => Semigroup (Quantity a) where
59 Quantity x <> Quantity y = Quantity (x + y)
60 instance (Zeroable a, Addable a) => Monoid (Quantity a) where
61 mempty = Quantity zero
64 newtype Amounts unit qty = Amounts (Map.Map unit qty)
65 deriving newtype (Eq, Show, NFData)
67 instance Zeroable (Amounts a) where
68 zero = Amounts Map.empty
69 instance Nullable (Amounts a) where
70 null (Amounts x) = Foldable.all null x
72 instance (Ord unit, Semigroup qty) => Semigroup (Amounts unit qty) where
73 Amounts x <> Amounts y = Amounts (Map.unionWith (flip (<>)) x y)
74 instance (Ord unit, Semigroup qty) => Monoid (Amounts unit qty) where
75 mempty = Amounts Map.empty
76 instance Negable qty => Negable (Amounts unit qty) where
77 negate (Amounts x) = Amounts (negate <$> x)
79 -- * Type 'AmountStyle'
80 data AmountStyle = AmountStyle
81 { amountStyleFractioning :: Char
82 , amountStyleGroupingIntegral :: (Char, [Int])
83 , amountStyleGroupingFractional :: (Char, [Int])
84 , amountStyleUnitSideLeft :: Bool
85 , amountStyleUnitSpaced :: Bool
86 -- TODO: , amountStyleSignPlus :: Bool
87 } deriving (Eq, Show, Generic, NFData)
89 -- ** Type 'AmountStylePrecision'
90 --type AmountStylePrecision = Natural
92 amountStyles :: Map.Map Unit AmountStyle
93 amountStyles = Map.fromList
94 [ (scalarUnit, AmountStyle
95 { amountStyleFractioning = '.'
96 , amountStyleGroupingFractional = (',', [3])
97 , amountStyleGroupingIntegral = (',', [3])
98 , amountStyleUnitSideLeft = False
99 , amountStyleUnitSpaced = False
101 , (chfUnit, AmountStyle
102 { amountStyleFractioning = ','
103 , amountStyleGroupingFractional = ('.', [3])
104 , amountStyleGroupingIntegral = ('.', [3])
105 , amountStyleUnitSideLeft = False
106 , amountStyleUnitSpaced = False
108 , (cnyUnit, AmountStyle
109 { amountStyleFractioning = ','
110 , amountStyleGroupingFractional = ('.', [3])
111 , amountStyleGroupingIntegral = ('.', [3])
112 , amountStyleUnitSideLeft = False
113 , amountStyleUnitSpaced = False
115 , (eurUnit, AmountStyle
116 { amountStyleFractioning = ','
117 , amountStyleGroupingFractional = ('.', [3])
118 , amountStyleGroupingIntegral = ('.', [3])
119 , amountStyleUnitSideLeft = False
120 , amountStyleUnitSpaced = False
122 , (gbpUnit, AmountStyle
123 { amountStyleFractioning = '.'
124 , amountStyleGroupingFractional = (',', [3])
125 , amountStyleGroupingIntegral = (',', [3])
126 , amountStyleUnitSideLeft = True
127 , amountStyleUnitSpaced = False
129 , (inrUnit, AmountStyle
130 { amountStyleFractioning = ','
131 , amountStyleGroupingFractional = ('.', [3])
132 , amountStyleGroupingIntegral = ('.', [3])
133 , amountStyleUnitSideLeft = False
134 , amountStyleUnitSpaced = False
136 , (jpyUnit, AmountStyle
137 { amountStyleFractioning = '.'
138 , amountStyleGroupingFractional = (',', [3])
139 , amountStyleGroupingIntegral = (',', [3])
140 , amountStyleUnitSideLeft = True
141 , amountStyleUnitSpaced = False
143 , (rubUnit, AmountStyle
144 { amountStyleFractioning = '.'
145 , amountStyleGroupingFractional = (',', [3])
146 , amountStyleGroupingIntegral = (',', [3])
147 , amountStyleUnitSideLeft = True
148 , amountStyleUnitSpaced = False
150 , (usdUnit, AmountStyle
151 { amountStyleFractioning = '.'
152 , amountStyleGroupingFractional = (',', [3])
153 , amountStyleGroupingIntegral = (',', [3])
154 , amountStyleUnitSideLeft = True
155 , amountStyleUnitSpaced = False
163 -- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
167 -- | <https://en.wikipedia.org/wiki/Yuan Yuan> unit of currency.
171 -- | <https://en.wikipedia.org/wiki/Euro Euro> unit of currency.
175 -- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> unit of currency.
179 -- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> unit of currency.
183 -- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> unit of currency.
187 -- | <https://en.wikipedia.org/wiki/Russian_ruble Russian ruble> unit of currency.
191 -- | <https://en.wikipedia.org/wiki/United_States_dollar United States dollar> unit of currency.
198 import Control.DeepSeq
200 import Data.Char (Char)
202 import Data.Decimal (Decimal, roundTo)
203 import Data.Eq (Eq(..))
204 import Data.Function (($), (.), const, flip)
205 import Data.Map.Strict (Map)
206 import Data.Monoid (Monoid(..))
207 import Data.Ord (Ord(..))
208 import Data.Semigroup (Semigroup(..))
209 import Data.Strict.Maybe
210 import Data.String (IsString)
211 import Data.Text (Text)
212 import Data.Typeable ()
213 import Data.Word (Word8)
214 import Prelude (Int, seq)
215 import Text.Show (Show(..))
216 import qualified Data.Map.Strict as Map
217 import qualified Data.MonoTraversable as MT
218 import qualified Data.Strict as S
219 import qualified Data.Text as T
221 import qualified Hcompta as H
226 { amount_unit :: !Unit
227 , amount_quantity :: !Quantity
228 } deriving (Data, Eq, Ord, Show, Typeable)
230 -- type instance H.UnitFor Amount = Unit
231 -- type instance H.QuantityFor Amount = H.Polarized Quantity
233 instance NFData Amount where
234 rnf (Amount q u) = rnf q `seq` rnf u
235 -- instance H.Amount Amount
238 type instance H.Unit H.:@ Amount = Unit
239 instance H.GetI H.Unit Amount where
241 instance H.SetI H.Unit Amount where
242 setI amount_unit a = a{amount_unit}
244 type instance H.Quantity H.:@ Amount = Quantity
245 instance H.GetI H.Quantity Amount where
246 getI = amount_quantity
247 instance H.SetI H.Quantity Amount where
248 setI amount_quantity a = a{amount_quantity}
251 instance H.Zeroable Amount where
252 zero = Amount "" H.zero
253 instance H.Nullable Amount where
254 null = H.null . amount_quantity
255 -- NOTE: the 'Amount'’s 'amount_quantity' MUST already be rounded
256 -- at 'Amount'’s 'amount_style'’s 'style_amount_precision'.
257 instance H.Signable Amount where
258 sign = H.sign . amount_quantity
264 , amount_quantity = H.zero
267 amount_style :: Style_Amounts -> Amount -> Style_Amount
268 amount_style styles = style_amount_find styles . amount_unit
271 type Quantity = Decimal
273 quantity_round :: Word8 -> Quantity -> Quantity
274 quantity_round = Data.Decimal.roundTo
279 deriving (Data, Eq, IsString, Ord, Show, Typeable)
280 instance H.Zeroable Unit where
282 instance H.Nullable Unit where
283 null (Unit x) = T.null x
285 instance H.Unit Unit where
287 textUnit (Unit t) = t
289 instance NFData Unit where
292 -- ** Example 'Unit's
295 -- * Type 'Style_Amount'
298 { amountStyleFractioning :: !(S.Maybe Style_Amount_Fractioning)
299 , amountStyleGroupingIntegral :: !(S.Maybe AmountStyleGrouping)
300 , amountStyleGroupingFractional :: !(S.Maybe AmountStyleGrouping)
301 , amountStyleUnitSideLeft :: !(S.Maybe LR)
302 , amountStyleUnitSpaced :: !(S.Maybe Style_Amount_Spacing)
303 -- TODO: , style_amount_sign_plus :: S.Maybe Bool
304 } deriving (Data, Eq, Ord, Show, Typeable)
305 instance NFData Style_Amount where
306 rnf (Style_Amount f gi gf ui up) =
312 instance Semigroup Style_Amount where
313 (<>) = style_amount_union
314 instance Monoid Style_Amount where
315 mempty = style_amount
318 style_amount :: Style_Amount
321 { amountStyleFractioning = Nothing
322 , amountStyleGroupingIntegral = Nothing
323 , amountStyleGroupingFractional = Nothing
324 , amountStyleUnitSideLeft = Nothing
325 , amountStyleUnitSpaced = Nothing
334 { amountStyleFractioning=f
335 , amountStyleGroupingIntegral=gi
336 , amountStyleGroupingFractional=gf
337 , amountStyleUnitSideLeft=side
338 , amountStyleUnitSpaced=spaced
341 { amountStyleFractioning=f'
342 , amountStyleGroupingIntegral=gi'
343 , amountStyleGroupingFractional=gf'
344 , amountStyleUnitSideLeft=side'
345 , amountStyleUnitSpaced=spaced'
351 { amountStyleFractioning = S.maybe f' (const f) f
352 , amountStyleGroupingIntegral = S.maybe gi' (const gi) gi
353 , amountStyleGroupingFractional = S.maybe gf' (const gf) gf
354 , amountStyleUnitSideLeft = S.maybe side' (const side) side
355 , amountStyleUnitSpaced = S.maybe spaced' (const spaced) spaced
358 -- ** Type 'Style_Amount_Fractioning'
359 type Style_Amount_Fractioning
362 -- ** Type 'AmountStyleGrouping'
363 data AmountStyleGrouping
364 = AmountStyleGrouping Char [Int]
365 deriving (Data, Eq, Ord, Show, Typeable)
366 instance NFData AmountStyleGrouping where
367 rnf (AmountStyleGrouping s d) = rnf s `seq` rnf d
369 -- ** Type 'Style_Amount_Precision'
370 type Style_Amount_Precision
373 -- ** Type 'Style_Amount_Spacing'
374 type Style_Amount_Spacing
379 deriving (Data, Eq, Ord, Show, Typeable)
380 instance NFData LR where
384 -- ** Type 'Style_Amounts'
385 newtype Style_Amounts
386 = Style_Amounts (Map Unit Style_Amount)
387 deriving (Data, Eq, NFData, Ord, Show, Typeable)
389 -- type instance H.UnitFor Amounts = Unit
390 -- type instance H.QuantityFor Amounts = Quantity
392 instance Semigroup Style_Amounts where
393 Style_Amounts x <> Style_Amounts y =
394 Style_Amounts (Map.unionWith (flip (<>)) x y)
395 instance Monoid Style_Amounts where
396 mempty = Style_Amounts mempty
398 instance H.Zeroable Style_Amounts where
399 zero = Style_Amounts mempty
400 instance H.Sumable Style_Amounts (Unit, Style_Amount) where
401 Style_Amounts ss += (u, s) = Style_Amounts $ Map.insertWith (flip (<>)) u s ss
403 unStyle_Amounts :: Style_Amounts -> Map Unit Style_Amount
404 unStyle_Amounts (Style_Amounts fp) = fp
406 style_amount_find :: Style_Amounts -> Unit -> Style_Amount
407 style_amount_find (Style_Amounts s) u = Map.findWithDefault mempty u s
409 -- *** Example 'Style_Amounts'
410 amountStyles :: Style_Amounts
412 -- ** Type 'Styled_Amount'
413 type Styled_Amount t = (Style_Amount, t)
415 styled_amount :: Style_Amounts -> Amount -> Styled_Amount Amount
416 styled_amount styles amt = (amount_style styles amt, amt)
419 newtype Amounts = Amounts (Map Unit Quantity)
420 deriving (Data, Eq, NFData, Ord, Show, Typeable
421 , H.Addable, H.Negable, H.Subable)
422 unAmounts :: Amounts -> Map Unit Quantity
423 unAmounts (Amounts a) = a
425 type instance MT.Element Amounts = Amount
426 -- instance H.Amounts Amounts
428 -- instance H.Get (H.Balance_Amounts Unit Quantity) Amounts where
429 -- get (Amounts a) = a