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           Control.DeepSeq
  11 import           Data.Data
  12 import qualified Data.List
  13 import qualified Data.Map.Strict as Data.Map
  14 import           Data.Map.Strict (Map)
  15 import qualified Data.Foldable
  16 import           Data.Typeable ()
  17
  18 import qualified Hcompta.Balance as Balance
  19 import qualified Hcompta.GL as GL
  20 import qualified Hcompta.Amount.Quantity as Quantity
  21 import qualified Hcompta.Amount.Style as Style
  22 import qualified Hcompta.Amount.Unit as Unit
  23
  24 -- * Type synonyms to submodules
  25
  26 type Quantity = Quantity.Quantity
  27 type Style    = Style.Style
  28 type Unit     = Unit.Unit
  29
  30 -- * The 'Amount' type
  31
  32 data Amount
  33  =   Amount
  34  { quantity :: !Quantity
  35  , style    :: !Style
  36  , unit     :: !Unit
  37  } deriving (Data, Show, Typeable)
  38 instance NFData (Amount) where
  39         rnf (Amount q s u) = rnf q `seq` rnf s `seq` rnf u
  40
  41 instance Eq Amount where
  42         (==)
  43          Amount{quantity=q0, unit=u0}
  44          Amount{quantity=q1, unit=u1} =
  45                 case compare u0 u1 of
  46                  LT -> False
  47                  GT -> False
  48                  EQ -> (==) q0 q1 -- NOTE: MUST already be rounded to Style.precision
  49
  50 instance Ord Amount where
  51         compare
  52          Amount{quantity=q0, unit=u0}
  53          Amount{quantity=q1, unit=u1} =
  54                 case compare u0 u1 of
  55                  LT -> LT
  56                  GT -> GT
  57                  EQ -> compare q0 q1 -- NOTE: MUST already be rounded to Style.precision
  58
  59 instance Balance.Amount Amount where
  60         type Amount_Unit Amount = Unit
  61         amount_null = (==) Quantity.zero . quantity
  62         amount_add = (+)
  63         amount_negate = negate
  64
  65 instance Balance.Amount (Map Unit Amount) where
  66         type Amount_Unit (Map Unit Amount) = Unit
  67         amount_null = Data.Foldable.all ((==) Quantity.zero . quantity)
  68         amount_add = Data.Map.unionWith (+)
  69         amount_negate = Data.Map.map negate
  70
  71 instance GL.Amount Amount where
  72         type Amount_Unit Amount = Unit
  73         amount_add = (+)
  74
  75 instance GL.Amount (Map Unit Amount) where
  76         type Amount_Unit (Map Unit Amount) = Unit
  77         amount_add = Data.Map.unionWith (+)
  78
  79 -- | An 'Amount' is a partially valid 'Num' instance:
  80 --
  81 --   * (+) operator requires both operand to have the same 'Unit' (homogeneity constraint).
  82 --   * (*) operator requires at least one operand with an empty 'Unit' ('scalar').
  83 instance Num Amount where
  84         abs    a@Amount{quantity=q} = a{quantity=abs q}
  85         fromInteger                 = scalar . fromInteger
  86         negate a@Amount{quantity=q} = a{quantity=negate q}
  87         signum a@Amount{quantity=q} = a{quantity=signum q}
  88         (+) a b =
  89                 let s@(Style.Style{Style.precision=p}) = Style.union (style a) (style b) in
  90                 a{ quantity = Quantity.round p $ quantity a + quantity b
  91                  , style = s
  92                  , unit =
  93                         if unit a == unit b
  94                         then unit a
  95                         else error "(+) on non-homogeneous units"
  96                  }
  97         (*) a b =
  98                 let Style.Style{Style.precision=p} = s in
  99                 a{ quantity = Quantity.round p $ quantity a * quantity b
 100                  , style = s
 101                  , unit = u
 102                  }
 103                 where (s, u)
 104                         | unit a == "" =
 105                                 if unit b == ""
 106                                 then (Style.union (style a) (style b), "")
 107                                 else (style b, unit b)
 108                         | unit b == "" = (style a, unit a)
 109                         | otherwise = 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 instance NFData amount => NFData (Sum amount) where
 389         rnf (Sum_Negative a) = rnf a
 390         rnf (Sum_Positive a) = rnf a
 391         rnf (Sum_Both a0 a1) = rnf a0 `seq` rnf a1
 392
 393 instance Functor Sum where
 394         fmap f (Sum_Negative a) = Sum_Negative (f a)
 395         fmap f (Sum_Positive a) = Sum_Positive (f a)
 396         fmap f (Sum_Both a0 a1) = Sum_Both (f a0) (f a1)
 397
 398 instance Balance.Amount a
 399  => Balance.Amount (Sum a) where
 400         type Amount_Unit (Sum a) = Balance.Amount_Unit a
 401         amount_null amt =
 402                 case amt of
 403                  Sum_Negative n -> Balance.amount_null n
 404                  Sum_Positive p -> Balance.amount_null p
 405                  Sum_Both n p   -> Balance.amount_null (Balance.amount_add n p)
 406         amount_add a0 a1 =
 407                 case (a0, a1) of
 408                  (Sum_Negative n0, Sum_Negative n1) -> Sum_Negative (Balance.amount_add n0 n1)
 409                  (Sum_Negative n , Sum_Positive p)  -> Sum_Both n p
 410                  (Sum_Negative n0, Sum_Both n1 p)   -> Sum_Both (Balance.amount_add n0 n1) p
 411
 412                  (Sum_Positive p , Sum_Negative n)  -> Sum_Both n p
 413                  (Sum_Positive p0, Sum_Positive p1) -> Sum_Positive (Balance.amount_add p0 p1)
 414                  (Sum_Positive p , Sum_Both n1 p1)  -> Sum_Both n1 (Balance.amount_add p p1)
 415
 416                  (Sum_Both n0 p0, Sum_Negative n)  -> Sum_Both (Balance.amount_add n0 n) p0
 417                  (Sum_Both n0 p0, Sum_Positive p1) -> Sum_Both n0 (Balance.amount_add p0 p1)
 418                  (Sum_Both n0 p0, Sum_Both n1 p1)  -> Sum_Both (Balance.amount_add n0 n1) (Balance.amount_add p0 p1)
 419         amount_negate amt =
 420                 case amt of
 421                  Sum_Negative n -> Sum_Positive $ Balance.amount_negate n
 422                  Sum_Positive p -> Sum_Negative $ Balance.amount_negate p
 423                  Sum_Both n p   -> Sum_Both (Balance.amount_negate p) (Balance.amount_negate n)
 424
 425 instance GL.Amount (Sum (Map Unit Amount)) where
 426         type Amount_Unit (Sum (Map Unit Amount)) = Unit
 427         amount_add a0 a1 =
 428                 case (a0, a1) of
 429                  (Sum_Negative n0, Sum_Negative n1) -> Sum_Negative (GL.amount_add n0 n1)
 430                  (Sum_Negative n , Sum_Positive p)  -> Sum_Both n p
 431                  (Sum_Negative n0, Sum_Both n1 p)   -> Sum_Both (GL.amount_add n0 n1) p
 432
 433                  (Sum_Positive p , Sum_Negative n)  -> Sum_Both n p
 434                  (Sum_Positive p0, Sum_Positive p1) -> Sum_Positive (GL.amount_add p0 p1)
 435                  (Sum_Positive p , Sum_Both n1 p1)  -> Sum_Both n1 (GL.amount_add p p1)
 436
 437                  (Sum_Both n0 p0, Sum_Negative n)  -> Sum_Both (GL.amount_add n0 n) p0
 438                  (Sum_Both n0 p0, Sum_Positive p1) -> Sum_Both n0 (GL.amount_add p0 p1)
 439                  (Sum_Both n0 p0, Sum_Both n1 p1)  -> Sum_Both (GL.amount_add n0 n1) (GL.amount_add p0 p1)
 440
 441 sum
 442  :: Sumable amount
 443  => amount -> Sum amount
 444 sum amt =
 445         case ( sumable_negative amt
 446              , sumable_positive amt ) of
 447          (Just n, Nothing)  -> Sum_Negative n
 448          (Nothing, Just p)  -> Sum_Positive p
 449          (Just n, Just p)   -> Sum_Both n p
 450          (Nothing, Nothing) -> Sum_Both amt amt
 451
 452 sum_negative
 453  :: Sum amount -> Maybe amount
 454 sum_negative amt =
 455         case amt of
 456          Sum_Negative n -> Just n
 457          Sum_Positive _ -> Nothing
 458          Sum_Both n _   -> Just n
 459
 460 sum_positive
 461  :: Sum amount -> Maybe amount
 462 sum_positive amt =
 463         case amt of
 464          Sum_Negative _ -> Nothing
 465          Sum_Positive p -> Just p
 466          Sum_Both _ p   -> Just p
 467
 468 sum_balance
 469  :: GL.Amount amount
 470  => Sum amount -> amount
 471 sum_balance amt =
 472         case amt of
 473          Sum_Negative n -> n
 474          Sum_Positive p -> p
 475          Sum_Both n p   -> GL.amount_add n p