jcc/Hcompta/Format/JCC/Amount.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE StandaloneDeriving #-}
   7 {-# LANGUAGE TupleSections #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9 {-# OPTIONS_GHC -fno-warn-orphans #-}
  10 module Hcompta.Format.JCC.Amount where
  11
  12 import           Control.DeepSeq
  13 import           Data.Bool
  14 import           Data.Char (Char)
  15 import           Data.Data
  16 import           Data.Decimal
  17 import           Data.Eq (Eq(..))
  18 import           Data.Function (($), (.), const)
  19 import           Data.Map.Strict (Map)
  20 import qualified Data.Map.Strict as Map
  21 import           Data.Maybe (Maybe(..), maybe)
  22 import           Data.Monoid (Monoid(..))
  23 import           Data.Ord (Ord(..), Ordering(..))
  24 import           Data.Text (Text)
  25 import           Data.String (IsString)
  26 import           Data.Typeable ()
  27 import           Data.Word (Word8)
  28 import           Prelude (Int, seq)
  29 import           Text.Show (Show(..))
  30
  31 import qualified Hcompta.Amount as Amount
  32 import qualified Hcompta.Filter as Filter
  33 import qualified Hcompta.Filter.Amount as Filter.Amount
  34 import qualified Hcompta.Polarize as Polarize
  35 import qualified Hcompta.Quantity as Quantity
  36 import qualified Hcompta.Unit as Unit
  37
  38
  39 -- * Type 'Quantity'
  40
  41 type Quantity = Filter.Amount.Quantity
  42
  43 -- ** Operators
  44
  45 quantity_round :: Word8 -> Quantity -> Quantity
  46 quantity_round = Data.Decimal.roundTo
  47
  48 -- * Type 'Unit'
  49
  50 newtype Unit
  51  = Unit Text
  52  deriving (Data, Eq, IsString, Ord, Show, Typeable)
  53 instance Unit.Unit Unit where
  54         unit_empty = Unit ""
  55         unit_text (Unit t) = t
  56 instance NFData Unit where
  57         rnf (Unit t) = rnf t
  58
  59 -- ** Example 'Unit's
  60
  61 -- | 'Unit.unit_empty'.
  62 unit_scalar :: Unit
  63 unit_scalar = Unit.unit_empty
  64
  65 -- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
  66 unit_chf :: Unit
  67 unit_chf = Unit "CHF"
  68
  69 -- | <https://en.wikipedia.org/wiki/Yuan Yuan> unit of currency.
  70 unit_cny :: Unit
  71 unit_cny = Unit "Ұ"
  72
  73 -- | <https://en.wikipedia.org/wiki/Euro Euro> unit of currency.
  74 unit_eur :: Unit
  75 unit_eur = Unit "€"
  76
  77 -- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> unit of currency.
  78 unit_gbp :: Unit
  79 unit_gbp = Unit "£"
  80
  81 -- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> unit of currency.
  82 unit_inr :: Unit
  83 unit_inr = Unit "₹"
  84
  85 -- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> unit of currency.
  86 unit_jpy :: Unit
  87 unit_jpy = Unit "¥"
  88
  89 -- | <https://en.wikipedia.org/wiki/Russian_ruble Russian ruble> unit of currency.
  90 --
  91 -- NOTE: Ꝑ (U+A750) is used as a replacement latin letter,
  92 --       because GHC currently chokes on ₽ (U+20BD),
  93 --       which is the recently (2014/02) assigned Unicode code-point
  94 --       for this currency.
  95 unit_rub :: Unit
  96 unit_rub = Unit "Ꝑ"
  97
  98 -- | <https://en.wikipedia.org/wiki/United_States_dollar United States dollar> unit of currency.
  99 unit_usd :: Unit
 100 unit_usd = Unit "$"
 101
 102 -- * Type 'Amount_Style'
 103
 104 data Amount_Style
 105  =   Amount_Style
 106  { amount_style_fractioning         :: Maybe Amount_Style_Fractioning
 107  , amount_style_grouping_integral   :: Maybe Amount_Style_Grouping
 108  , amount_style_grouping_fractional :: Maybe Amount_Style_Grouping
 109  -- TODO: , amount_style_sign_plus     :: Maybe Bool
 110  , amount_style_unit_side           :: Maybe Amount_Style_Side
 111  , amount_style_unit_spaced         :: Maybe Amount_Style_Spacing
 112  } deriving (Data, Eq, Ord, Show, Typeable)
 113 instance NFData Amount_Style where
 114         rnf (Amount_Style f gi gf ui up) =
 115                 rnf f  `seq`
 116                 rnf gi `seq`
 117                 rnf gf `seq`
 118                 rnf ui `seq`
 119                 rnf up
 120 instance Monoid Amount_Style where
 121         mempty  = amount_style
 122         mappend = amount_style_union
 123
 124 amount_style :: Amount_Style
 125 amount_style =
 126         Amount_Style
 127          { amount_style_fractioning         = Nothing
 128          , amount_style_grouping_integral   = Nothing
 129          , amount_style_grouping_fractional = Nothing
 130          , amount_style_unit_side           = Nothing
 131          , amount_style_unit_spaced         = Nothing
 132          }
 133
 134 amount_style_union :: Amount_Style -> Amount_Style -> 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, Show, Typeable)
 297 instance Amount.Amount Amount where
 298         type Amount_Quantity Amount = Quantity
 299         type Amount_Unit     Amount = Unit
 300         amount_quantity = amount_quantity
 301         amount_unit     = amount_unit
 302 instance Filter.Amount Amount where
 303         type Amount_Quantity Amount = Quantity
 304         type Amount_Unit     Amount = Unit
 305         amount_quantity = Polarize.polarize . amount_quantity
 306         amount_unit     = amount_unit
 307 instance NFData Amount where
 308         rnf (Amount q u) = rnf q `seq` rnf u
 309 instance Quantity.Zero Amount where
 310         quantity_zero = Amount Unit.unit_empty Quantity.quantity_zero
 311         quantity_null = (==) Quantity.quantity_zero . amount_quantity
 312
 313 amount :: Amount
 314 amount =
 315         Amount
 316          { amount_quantity = Quantity.quantity_zero
 317          , amount_unit     = ""
 318          }
 319
 320 -- ** Extractors
 321
 322 amount_amount_style :: Amount_Styles -> Amount -> Amount_Style
 323 amount_amount_style styles = amount_style_find styles . amount_unit
 324
 325 amount_sign :: Amount -> Ordering
 326 amount_sign a =
 327         case amount_quantity a of
 328          0         -> EQ
 329          q | q < 0 -> LT
 330          _         -> GT
 331
 332 -- | Return 'True' if and only if 'Amount'’s 'Quantity' is zero.
 333 --
 334 --  NOTE: the 'Amount'’s 'amount_quantity' MUST already be rounded
 335 --        at 'Amount'’s 'amount_amount_style'’s 'amount_style_precision'.
 336 amount_null :: Amount -> Bool
 337 amount_null = Quantity.quantity_null . amount_quantity
 338
 339 {-
 340 instance Eq Amount where
 341         (==)
 342          Amount{amount_quantity=q0, amount_unit=u0}
 343          Amount{amount_quantity=q1, amount_unit=u1} =
 344                 case compare u0 u1 of
 345                  LT -> False
 346                  GT -> False
 347                  EQ -> (==) q0 q1 -- NOTE: MUST already be rounded to amount_style_precision
 348 instance Ord Amount where
 349         compare
 350          Amount{amount_quantity=q0, amount_unit=u0}
 351          Amount{amount_quantity=q1, amount_unit=u1} =
 352                 case compare u0 u1 of
 353                  LT -> LT
 354                  GT -> GT
 355                  EQ -> compare q0 q1 -- NOTE: MUST already be rounded to amount_style_precision
 356 -}
 357 {-
 358 instance GL.Amount Amount where
 359         type Amount_Unit Amount = Unit
 360         amount_add = (+)
 361 instance GL.Amount (Map Unit Amount) where
 362         type Amount_Unit (Map Unit Amount) = Unit
 363         amount_add = Data.Map.unionWith (+)
 364 -}
 365
 366 {-
 367 -- | An 'Amount' is a partially valid 'Num' instance:
 368 --
 369 --   * (+) operator requires both operand to have the same 'Unit' (homogeneity constraint).
 370 --   * (*) operator requires at least one operand with an empty 'Unit' ('scalar').
 371 instance Num Amount where
 372         abs    a@Amount{amount_quantity=q} = a{amount_quantity=abs q}
 373         fromInteger                        = scalar . fromInteger
 374         negate a@Amount{amount_quantity=q} = a{amount_quantity=negate q}
 375         signum a@Amount{amount_quantity=q} = a{amount_quantity=signum q}
 376         (+) a b =
 377                 let s@(Style.Style{Style.precision=p}) = Style.union (amount_style a) (amount_style b) in
 378                 a{ amount_quantity = quantity_round p $ amount_quantity a + amount_quantity b
 379                  , amount_style = s
 380                  , amount_unit =
 381                         if amount_unit a == amount_unit b
 382                         then amount_unit a
 383                         else error "(+) on non-homogeneous units"
 384                  }
 385         (*) a b =
 386                 let Style.Style{Style.precision=p} = s in
 387                 a{ amount_quantity = quantity_round p $ amount_quantity a * amount_quantity b
 388                  , amount_style = s
 389                  , amount_unit = u
 390                  }
 391                 where (s, u)
 392                         | amount_unit a == "" =
 393                                 if amount_unit b == ""
 394                                 then (Style.union (amount_style a) (amount_style b), "")
 395                                 else (amount_style b, amount_unit b)
 396                         | amount_unit b == "" = (amount_style a, amount_unit a)
 397                         | otherwise = error "(*) by non-scalar amount_unit"
 398 -}
 399
 400 {-
 401 -- * Type 'Amount_by_Unit' mapping
 402
 403 type Amount_by_Unit
 404  = Map Unit Amount
 405 type By_Unit = Amount_by_Unit
 406
 407 -- | 'Amount_by_Unit'’s is a partially valid 'Num' instance.
 408 --
 409 --   * (*) operator is not defined.
 410 instance Num Amount_by_Unit where
 411         abs         = Data.Map.map (\a@Amount{amount_quantity=q} -> a{amount_quantity=abs    q})
 412         fromInteger = Data.Map.singleton "" . fromInteger
 413         negate      = Data.Map.map (\a@Amount{amount_quantity=q} -> a{amount_quantity=negate q})
 414         signum      = Data.Map.map (\a@Amount{amount_quantity=q} -> a{amount_quantity=signum q})
 415         (+)         = Data.Map.unionWith (+)
 416         (*)         = error "(*) not-supported"
 417
 418 type Signs = (Int, Int)
 419
 420 signs :: Amount_by_Unit -> Signs
 421 signs = Data.Map.foldl'
 422  (\(nega, plus) amt ->
 423         case flip compare 0 $ amount_quantity amt of
 424          LT -> (nega - 1, plus)
 425          EQ -> (nega, plus)
 426          GT -> (nega, plus + 1))
 427  (0, 0)
 428
 429 -- ** Constructors
 430
 431 nil_By_Unit :: Amount_by_Unit
 432 nil_By_Unit =
 433         Data.Map.empty
 434
 435 -- ** Tests
 436
 437 -- | Return 'True' if and only if all 'Amount's satisfy 'null'.
 438 amount_nulls :: Amount_by_Unit -> Bool
 439 amount_nulls = all amount_null
 440
 441 -- | Return a tuple associating the given 'Amount' with its 'Unit'.
 442 assoc_by_unit :: Amount -> (Unit, Amount)
 443 assoc_by_unit amt = (amount_unit amt, amt)
 444
 445 -- | Return a 'Data.Map.Map' associating the given 'Amount's with their respective 'Unit'.
 446 from_List :: [Amount] -> Amount_by_Unit
 447 from_List amounts =
 448         Data.Map.fromListWith (flip (+)) $ -- NOTE: flip to propagate 'Style' first to last.
 449         Data.List.map assoc_by_unit amounts
 450
 451 -}