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