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