lib/Hcompta/Amount.hs

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