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 -}