lib/Hcompta/Amount.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE TypeFamilies #-}
   6 {-# LANGUAGE TypeSynonymInstances #-}
   7 {-# OPTIONS_GHC -fno-warn-orphans #-}
   8 module Hcompta.Amount where
   9
  10 import           Data.Data
  11 import qualified Data.List
  12 import qualified Data.Map.Strict as Data.Map
  13 import           Data.Map.Strict (Map)
  14 import qualified Data.Foldable
  15 import           Data.Typeable ()
  16
  17 import qualified Hcompta.Balance as Balance
  18 import qualified Hcompta.GL as GL
  19 import qualified Hcompta.Amount.Quantity as Quantity
  20 import qualified Hcompta.Amount.Style as Style
  21 import qualified Hcompta.Amount.Unit as Unit
  22
  23 -- * Type synonyms to submodules
  24
  25 type Quantity = Quantity.Quantity
  26 type Style    = Style.Style
  27 type Unit     = Unit.Unit
  28
  29 -- * The 'Amount' type
  30
  31 data Amount
  32  =   Amount
  33  { quantity :: Quantity
  34  , style    :: Style
  35  , unit     :: Unit
  36  } deriving (Data, Show, Typeable)
  37
  38 instance Eq Amount where
  39         (==)
  40          Amount{quantity=q0, unit=u0}
  41          Amount{quantity=q1, unit=u1} =
  42                 case compare u0 u1 of
  43                  LT -> False
  44                  GT -> False
  45                  EQ -> (==) q0 q1 -- NOTE: MUST already be rounded to Style.precision
  46
  47 instance Ord Amount where
  48         compare
  49          Amount{quantity=q0, unit=u0}
  50          Amount{quantity=q1, unit=u1} =
  51                 case compare u0 u1 of
  52                  LT -> LT
  53                  GT -> GT
  54                  EQ -> compare q0 q1 -- NOTE: MUST already be rounded to Style.precision
  55
  56 instance Balance.Amount Amount where
  57         type Amount_Unit Amount = Unit
  58         amount_null = (==) Quantity.zero . quantity
  59         amount_add = (+)
  60         amount_negate = negate
  61
  62 instance Balance.Amount (Map Unit Amount) where
  63         type Amount_Unit (Map Unit Amount) = Unit
  64         amount_null = Data.Foldable.all ((==) Quantity.zero . quantity)
  65         amount_add = Data.Map.unionWith (+)
  66         amount_negate = Data.Map.map negate
  67
  68 instance GL.Amount Amount where
  69         type Amount_Unit Amount = Unit
  70         amount_add = (+)
  71
  72 instance GL.Amount (Map Unit Amount) where
  73         type Amount_Unit (Map Unit Amount) = Unit
  74         amount_add = Data.Map.unionWith (+)
  75
  76 -- | An 'Amount' is a partially valid 'Num' instance:
  77 --
  78 --   * (+) operator requires both operand to have the same 'Unit' (homogeneity constraint).
  79 --   * (*) operator requires at least one operand with an empty 'Unit' ('scalar').
  80 instance Num Amount where
  81         abs    a@Amount{quantity=q} = a{quantity=abs q}
  82         fromInteger                 = scalar . fromInteger
  83         negate a@Amount{quantity=q} = a{quantity=negate q}
  84         signum a@Amount{quantity=q} = a{quantity=signum q}
  85         (+) a b =
  86                 let s@(Style.Style{Style.precision=p}) = Style.union (style a) (style b) in
  87                 a{ quantity = Quantity.round p $ quantity a + quantity b
  88                  , style = s
  89                  , unit =
  90                         if unit a == unit b
  91                         then unit a
  92                         else error "(+) on non-homogeneous units"
  93                  }
  94         (*) a b =
  95                 let Style.Style{Style.precision=p} = s in
  96                 a{ quantity = Quantity.round p $ quantity a * quantity b
  97                  , style = s
  98                  , unit = u
  99                  }
 100                 where (s, u) =
 101                         if unit a == ""
 102                         then
 103                                 if unit b == ""
 104                                 then (Style.union (style a) (style b), "")
 105                                 else (style b, unit b)
 106                         else
 107                                 if unit b == ""
 108                                 then (style a, unit a)
 109                                 else error "(*) by non-scalar unit"
 110
 111 -- ** Constructors
 112
 113 nil :: Amount
 114 nil =
 115         Amount
 116          { quantity = Quantity.zero
 117          , style = Style.nil
 118          , unit = ""
 119          }
 120
 121 -- *** From 'Quantity'
 122
 123 -- | Return an 'Amount' with 'unit' = Unit.'Unit.nil'.
 124 scalar :: Quantity -> Amount
 125 scalar q =
 126         Amount
 127          { quantity = q
 128          , style = Style.Style
 129                  { Style.fractioning = Just '.'
 130                  , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
 131                  , Style.grouping_integral   = Just $ Style.Grouping ',' [3]
 132                  , Style.precision = maxBound
 133                  , Style.unit_side = Just Style.Side_Right
 134                  , Style.unit_spaced = Just False
 135                  }
 136          , unit = ""
 137          }
 138
 139 -- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
 140 chf :: Quantity -> Amount
 141 chf q =
 142         Amount
 143          { quantity = q
 144          , style = Style.Style
 145                  { Style.fractioning = Just ','
 146                  , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
 147                  , Style.grouping_integral   = Just $ Style.Grouping '.' [3]
 148                  , Style.precision = 2
 149                  , Style.unit_side = Just Style.Side_Right
 150                  , Style.unit_spaced = Just False
 151                  }
 152          , unit = "CHF"
 153          }
 154 -- | <https://en.wikipedia.org/wiki/Yuan Yuan> unit of currency.
 155 cny :: Quantity -> Amount
 156 cny q =
 157         Amount
 158          { quantity = q
 159          , style = Style.Style
 160                  { Style.fractioning = Just ','
 161                  , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
 162                  , Style.grouping_integral   = Just $ Style.Grouping '.' [3]
 163                  , Style.precision = 2
 164                  , Style.unit_side = Just Style.Side_Right
 165                  , Style.unit_spaced = Just False
 166                  }
 167          , unit = "Ұ"
 168          }
 169 -- | <https://en.wikipedia.org/wiki/Euro Euro> unit of currency.
 170 eur :: Quantity -> Amount
 171 eur q =
 172         Amount
 173          { quantity = q
 174          , style = Style.Style
 175                  { Style.fractioning = Just ','
 176                  , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
 177                  , Style.grouping_integral   = Just $ Style.Grouping '.' [3]
 178                  , Style.precision = 2
 179                  , Style.unit_side = Just Style.Side_Right
 180                  , Style.unit_spaced = Just False
 181                  }
 182          , unit = "€"
 183          }
 184 -- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> unit of currency.
 185 gbp :: Quantity -> Amount
 186 gbp q =
 187         Amount
 188          { quantity = q
 189          , style = Style.Style
 190                  { Style.fractioning = Just '.'
 191                  , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
 192                  , Style.grouping_integral   = Just $ Style.Grouping ',' [3]
 193                  , Style.precision = 2
 194                  , Style.unit_side = Just Style.Side_Left
 195                  , Style.unit_spaced = Just False
 196                  }
 197          , unit = "£"
 198          }
 199 -- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> unit of currency.
 200 inr :: Quantity -> Amount
 201 inr q =
 202         Amount
 203          { quantity = q
 204          , style = Style.Style
 205                  { Style.fractioning = Just ','
 206                  , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
 207                  , Style.grouping_integral   = Just $ Style.Grouping '.' [3]
 208                  , Style.precision = 2
 209                  , Style.unit_side = Just Style.Side_Right
 210                  , Style.unit_spaced = Just False
 211                  }
 212          , unit = "₹"
 213          }
 214 -- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> unit of currency.
 215 jpy :: Quantity -> Amount
 216 jpy q =
 217         Amount
 218          { quantity = q
 219          , style = Style.Style
 220                  { Style.fractioning = Just '.'
 221                  , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
 222                  , Style.grouping_integral   = Just $ Style.Grouping ',' [3]
 223                  , Style.precision = 2
 224                  , Style.unit_side = Just Style.Side_Left
 225                  , Style.unit_spaced = Just False
 226                  }
 227          , unit = "¥"
 228          }
 229 -- | <https://en.wikipedia.org/wiki/Russian_ruble Russian ruble> unit of currency.
 230 --
 231 -- NOTE: Ꝑ (U+A750) is used as a replacement latin letter,
 232 --       because GHC currently chokes on ₽ (U+20BD),
 233 --       which is the recently (2014/02) assigned Unicode code-point
 234 --       for this currency.
 235 rub :: Quantity -> Amount
 236 rub q =
 237         Amount
 238          { quantity = q
 239          , style = Style.Style
 240                  { Style.fractioning = Just '.'
 241                  , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
 242                  , Style.grouping_integral   = Just $ Style.Grouping ',' [3]
 243                  , Style.precision = 2
 244                  , Style.unit_side = Just Style.Side_Left
 245                  , Style.unit_spaced = Just False
 246                  }
 247          , unit = "Ꝑ"
 248          }
 249 -- | <https://en.wikipedia.org/wiki/United_States_dollar United States dollar> unit of currency.
 250 usd :: Quantity -> Amount
 251 usd q =
 252         Amount
 253          { quantity = q
 254          , style = Style.Style
 255                  { Style.fractioning = Just '.'
 256                  , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
 257                  , Style.grouping_integral = Just $ Style.Grouping ',' [3]
 258                  , Style.precision = 2
 259                  , Style.unit_side = Just Style.Side_Left
 260                  , Style.unit_spaced = Just False
 261                  }
 262          , unit = "$"
 263          }
 264
 265 -- ** Tests
 266
 267 -- | Return 'True' if and only if 'Amount'’s 'Quantity' is zero.
 268 --
 269 --  NOTE: the 'Amount'’s 'quantity' MUST be have been rounded at 'Amount'’s 'style'’s 'Style.precision'.
 270 is_zero :: Amount -> Bool
 271 is_zero = Quantity.is_zero . quantity
 272
 273 -- * The 'Amount_by_Unit' mapping
 274
 275 type Amount_by_Unit
 276  = Data.Map.Map Unit Amount
 277 type By_Unit = Amount_by_Unit
 278
 279 -- | 'Amount_by_Unit'’s is a partially valid 'Num' instance.
 280 --
 281 --   * (*) operator is not defined.
 282 instance Num Amount_by_Unit where
 283         abs         = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=abs    q})
 284         fromInteger = Data.Map.singleton "" . fromInteger
 285         negate      = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=negate q})
 286         signum      = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=signum q})
 287         (+)         = Data.Map.unionWith (+)
 288         (*)         = error "(*) not-supported"
 289
 290 type Signs = (Int, Int)
 291
 292 signs :: Amount_by_Unit -> Signs
 293 signs = Data.Map.foldl
 294  (\(nega, plus) amt ->
 295         case flip compare 0 $ quantity amt of
 296          LT -> (nega - 1, plus)
 297          EQ -> (nega, plus)
 298          GT -> (nega, plus + 1))
 299  (0, 0)
 300
 301 -- ** Constructors
 302
 303 nil_By_Unit :: Amount_by_Unit
 304 nil_By_Unit =
 305         Data.Map.empty
 306
 307 -- ** Tests
 308
 309 -- | Return 'True' if and only if all 'Amount's satisfy 'is_zero'.
 310 are_zero :: Amount_by_Unit -> Bool
 311 are_zero = Data.Foldable.all is_zero
 312
 313 -- | Return a tuple associating the given 'Amount' with its 'Unit'.
 314 assoc_by_unit :: Amount -> (Unit, Amount)
 315 assoc_by_unit amount = (unit amount, amount)
 316
 317 -- | Return a 'Data.Map.Map' associating the given 'Amount's with their respective 'Unit'.
 318 from_List :: [Amount] -> Amount_by_Unit
 319 from_List amounts =
 320         Data.Map.fromListWith (flip (+)) $ -- NOTE: flip to propagate 'Style' first to last.
 321         Data.List.map assoc_by_unit amounts
 322
 323 -- * Type 'Sum'
 324
 325 -- ** Class 'Sumable'
 326 class
 327  ( Data (Sumable_Unit a)
 328  , Data a
 329  , Eq a
 330  , Ord  (Sumable_Unit a)
 331  , Show (Sumable_Unit a)
 332  , Show a
 333  , Typeable (Sumable_Unit a)
 334  , Typeable a
 335  ) => Sumable a where
 336         type Sumable_Unit a
 337         -- sumable_add      :: a -> a -> a
 338         sumable_positive :: a -> Maybe a
 339         sumable_negative :: a -> Maybe a
 340
 341 instance Sumable Amount where
 342         type Sumable_Unit Amount = Unit
 343         -- sumable_add = (+)
 344         sumable_positive a =
 345                 case compare (quantity a) Quantity.zero of
 346                  LT -> Nothing
 347                  EQ -> Nothing
 348                  _  -> Just a
 349         sumable_negative a =
 350                 case compare (quantity a) Quantity.zero of
 351                  GT -> Nothing
 352                  EQ -> Nothing
 353                  _  -> Just a
 354
 355 instance Sumable (Map Unit Amount) where
 356         type Sumable_Unit (Map Unit Amount) = Unit
 357         -- sumable_add = (+)
 358         sumable_positive a =
 359                 let r = Data.Map.mapMaybe sumable_positive a in
 360                 if Data.Map.null r
 361                 then Nothing
 362                 else Just r
 363         sumable_negative a =
 364                 let r = Data.Map.mapMaybe sumable_negative a in
 365                 if Data.Map.null r
 366                 then Nothing
 367                 else Just r
 368
 369 instance Sumable amount => Sumable (Sum amount) where
 370         type Sumable_Unit (Sum amount) = Sumable_Unit amount
 371         sumable_negative amt =
 372                 case amt of
 373                  Sum_Negative _ -> Just $ amt
 374                  Sum_Positive _ -> Nothing
 375                  Sum_Both n _   -> Just $ Sum_Negative n
 376         sumable_positive amt =
 377                 case amt of
 378                  Sum_Negative _ -> Nothing
 379                  Sum_Positive _ -> Just $ amt
 380                  Sum_Both _ p   -> Just $ Sum_Positive p
 381
 382 -- | Sum separately keeping track of negative and positive 'amount's.
 383 data Sum amount
 384  =   Sum_Negative amount
 385  |   Sum_Positive amount
 386  |   Sum_Both     amount amount
 387  deriving (Data, Eq, Show, Typeable)
 388
 389 instance Functor Sum where
 390         fmap f (Sum_Negative a) = Sum_Negative (f a)
 391         fmap f (Sum_Positive a) = Sum_Positive (f a)
 392         fmap f (Sum_Both a0 a1) = Sum_Both (f a0) (f a1)
 393
 394 instance Balance.Amount a
 395  => Balance.Amount (Sum a) where
 396         type Amount_Unit (Sum a) = Balance.Amount_Unit a
 397         amount_null amt =
 398                 case amt of
 399                  Sum_Negative n -> Balance.amount_null n
 400                  Sum_Positive p -> Balance.amount_null p
 401                  Sum_Both n p   -> Balance.amount_null (Balance.amount_add n p)
 402         amount_add a0 a1 =
 403                 case (a0, a1) of
 404                  (Sum_Negative n0, Sum_Negative n1) -> Sum_Negative (Balance.amount_add n0 n1)
 405                  (Sum_Negative n , Sum_Positive p)  -> Sum_Both n p
 406                  (Sum_Negative n0, Sum_Both n1 p)   -> Sum_Both (Balance.amount_add n0 n1) p
 407
 408                  (Sum_Positive p , Sum_Negative n)  -> Sum_Both n p
 409                  (Sum_Positive p0, Sum_Positive p1) -> Sum_Positive (Balance.amount_add p0 p1)
 410                  (Sum_Positive p , Sum_Both n1 p1)  -> Sum_Both n1 (Balance.amount_add p p1)
 411
 412                  (Sum_Both n0 p0, Sum_Negative n)  -> Sum_Both (Balance.amount_add n0 n) p0
 413                  (Sum_Both n0 p0, Sum_Positive p1) -> Sum_Both n0 (Balance.amount_add p0 p1)
 414                  (Sum_Both n0 p0, Sum_Both n1 p1)  -> Sum_Both (Balance.amount_add n0 n1) (Balance.amount_add p0 p1)
 415         amount_negate amt =
 416                 case amt of
 417                  Sum_Negative n -> Sum_Positive $ Balance.amount_negate n
 418                  Sum_Positive p -> Sum_Negative $ Balance.amount_negate p
 419                  Sum_Both n p   -> Sum_Both (Balance.amount_negate p) (Balance.amount_negate n)
 420
 421 instance GL.Amount (Sum (Map Unit Amount)) where
 422         type Amount_Unit (Sum (Map Unit Amount)) = Unit
 423         amount_add a0 a1 =
 424                 case (a0, a1) of
 425                  (Sum_Negative n0, Sum_Negative n1) -> Sum_Negative (GL.amount_add n0 n1)
 426                  (Sum_Negative n , Sum_Positive p)  -> Sum_Both n p
 427                  (Sum_Negative n0, Sum_Both n1 p)   -> Sum_Both (GL.amount_add n0 n1) p
 428
 429                  (Sum_Positive p , Sum_Negative n)  -> Sum_Both n p
 430                  (Sum_Positive p0, Sum_Positive p1) -> Sum_Positive (GL.amount_add p0 p1)
 431                  (Sum_Positive p , Sum_Both n1 p1)  -> Sum_Both n1 (GL.amount_add p p1)
 432
 433                  (Sum_Both n0 p0, Sum_Negative n)  -> Sum_Both (GL.amount_add n0 n) p0
 434                  (Sum_Both n0 p0, Sum_Positive p1) -> Sum_Both n0 (GL.amount_add p0 p1)
 435                  (Sum_Both n0 p0, Sum_Both n1 p1)  -> Sum_Both (GL.amount_add n0 n1) (GL.amount_add p0 p1)
 436
 437 sum
 438  :: Sumable amount
 439  => amount -> Sum amount
 440 sum amt =
 441         case ( sumable_negative amt
 442              , sumable_positive amt ) of
 443          (Just n, Nothing)  -> Sum_Negative n
 444          (Nothing, Just p)  -> Sum_Positive p
 445          (Just n, Just p)   -> Sum_Both n p
 446          (Nothing, Nothing) -> Sum_Both amt amt
 447
 448 sum_negative
 449  :: Sum amount -> Maybe amount
 450 sum_negative amt =
 451         case amt of
 452          Sum_Negative n -> Just n
 453          Sum_Positive _ -> Nothing
 454          Sum_Both n _   -> Just n
 455
 456 sum_positive
 457  :: Sum amount -> Maybe amount
 458 sum_positive amt =
 459         case amt of
 460          Sum_Negative _ -> Nothing
 461          Sum_Positive p -> Just p
 462          Sum_Both _ p   -> Just p
 463
 464 sum_balance
 465  :: GL.Amount amount
 466  => Sum amount -> amount
 467 sum_balance amt =
 468         case amt of
 469          Sum_Negative n -> n
 470          Sum_Positive p -> p
 471          Sum_Both n p   -> GL.amount_add n p