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