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