lib/Hcompta/Model/Amount.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE TypeSynonymInstances #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# OPTIONS_GHC -fno-warn-orphans #-}
   6 module Hcompta.Model.Amount where
   7
   8 import Data.Data
   9 import qualified Data.List
  10 import qualified Data.Map.Strict as Data.Map
  11 import qualified Data.Foldable
  12 import Data.Typeable ()
  13
  14 import qualified Hcompta.Calc.Balance as Calc.Balance
  15 import qualified Hcompta.Model.Amount.Quantity as Quantity
  16 import qualified Hcompta.Model.Amount.Style as Style
  17 import qualified Hcompta.Model.Amount.Unit as Unit
  18
  19 -- * Type synonyms to submodules
  20
  21 type Quantity   = Quantity.Quantity
  22 type Style      = Style.Style
  23 type Unit       = Unit.Unit
  24
  25 -- * The 'Amount' type
  26
  27 data Amount
  28  =   Amount
  29  { quantity :: Quantity
  30  , style    :: Style
  31  , unit     :: Unit
  32  } deriving (Data, Show, Typeable)
  33
  34 instance Eq Amount where
  35         (==)
  36          Amount{quantity=q0, unit=u0}
  37          Amount{quantity=q1, unit=u1} =
  38                 case compare u0 u1 of
  39                  LT -> False
  40                  GT -> False
  41                  EQ -> (==) q0 q1 -- NOTE: MUST already be rounded to Style.precision
  42
  43 instance Ord Amount where
  44         compare
  45          Amount{quantity=q0, unit=u0}
  46          Amount{quantity=q1, unit=u1} =
  47                 case compare u0 u1 of
  48                  LT -> LT
  49                  GT -> GT
  50                  EQ -> compare q0 q1 -- NOTE: MUST already be rounded to Style.precision
  51
  52 instance Calc.Balance.Amount Amount where
  53         amount_sign = flip compare Quantity.zero . quantity
  54
  55 -- | An 'Amount' is a partially valid 'Num' instance:
  56 --
  57 --   * (+) operator requires both operand to have the same 'Unit' (homogeneity constraint).
  58 --   * (*) operator requires at least one operand with an empty 'Unit' ('scalar').
  59 instance Num Amount where
  60         abs    a@Amount{quantity=q} = a{quantity=abs q}
  61         fromInteger            = scalar . fromInteger
  62         negate a@Amount{quantity=q} = a{quantity=negate q}
  63         signum a@Amount{quantity=q} = a{quantity=signum q}
  64         (+) a b =
  65                 let s@(Style.Style{Style.precision=p}) = Style.union (style a) (style b) in
  66                 a{ quantity = Quantity.round p $ quantity a + quantity b
  67                  , style = s
  68                  , unit =
  69                         if unit a == unit b
  70                         then unit a
  71                         else error "(+) on non-homogeneous units"
  72                  }
  73         (*) a b =
  74                 let Style.Style{Style.precision=p} = s in
  75                 a{ quantity = Quantity.round p $ quantity a * quantity b
  76                  , style = s
  77                  , unit = u
  78                  }
  79                 where (s, u) =
  80                         if unit a == ""
  81                         then
  82                                 if unit b == ""
  83                                 then (Style.union (style a) (style b), "")
  84                                 else (style b, unit b)
  85                         else
  86                                 if unit b == ""
  87                                 then (style a, unit a)
  88                                 else error "(*) by non-scalar unit"
  89
  90 -- ** Constructors
  91
  92 nil :: Amount
  93 nil =
  94         Amount
  95          { quantity = Quantity.zero
  96          , style = Style.nil
  97          , unit = ""
  98          }
  99
 100 -- *** From 'Quantity'
 101
 102 -- | Return an 'Amount' with 'unit' = Unit.'Unit.nil'.
 103 scalar :: Quantity -> Amount
 104 scalar q =
 105         Amount
 106          { quantity = q
 107          , style = Style.Style
 108                  { Style.fractioning = Just '.'
 109                  , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
 110                  , Style.grouping_integral   = Just $ Style.Grouping ',' [3]
 111                  , Style.precision = maxBound
 112                  , Style.unit_side = Just Style.Side_Right
 113                  , Style.unit_spaced = Just False
 114                  }
 115          , unit = ""
 116          }
 117
 118 -- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
 119 chf :: Quantity -> Amount
 120 chf q =
 121         Amount
 122          { quantity = q
 123          , style = Style.Style
 124                  { Style.fractioning = Just ','
 125                  , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
 126                  , Style.grouping_integral   = Just $ Style.Grouping '.' [3]
 127                  , Style.precision = 2
 128                  , Style.unit_side = Just Style.Side_Right
 129                  , Style.unit_spaced = Just False
 130                  }
 131          , unit = "CHF"
 132          }
 133 -- | <https://en.wikipedia.org/wiki/Yuan Yuan> unit of currency.
 134 cny :: Quantity -> Amount
 135 cny q =
 136         Amount
 137          { quantity = q
 138          , style = Style.Style
 139                  { Style.fractioning = Just ','
 140                  , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
 141                  , Style.grouping_integral   = Just $ Style.Grouping '.' [3]
 142                  , Style.precision = 2
 143                  , Style.unit_side = Just Style.Side_Right
 144                  , Style.unit_spaced = Just False
 145                  }
 146          , unit = "Ұ"
 147          }
 148 -- | <https://en.wikipedia.org/wiki/Euro Euro> unit of currency.
 149 eur :: Quantity -> Amount
 150 eur q =
 151         Amount
 152          { quantity = q
 153          , style = Style.Style
 154                  { Style.fractioning = Just ','
 155                  , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
 156                  , Style.grouping_integral   = Just $ Style.Grouping '.' [3]
 157                  , Style.precision = 2
 158                  , Style.unit_side = Just Style.Side_Right
 159                  , Style.unit_spaced = Just False
 160                  }
 161          , unit = "€"
 162          }
 163 -- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> unit of currency.
 164 gbp :: Quantity -> Amount
 165 gbp q =
 166         Amount
 167          { quantity = q
 168          , style = Style.Style
 169                  { Style.fractioning = Just '.'
 170                  , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
 171                  , Style.grouping_integral   = Just $ Style.Grouping ',' [3]
 172                  , Style.precision = 2
 173                  , Style.unit_side = Just Style.Side_Left
 174                  , Style.unit_spaced = Just False
 175                  }
 176          , unit = "£"
 177          }
 178 -- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> unit of currency.
 179 inr :: Quantity -> Amount
 180 inr q =
 181         Amount
 182          { quantity = q
 183          , style = Style.Style
 184                  { Style.fractioning = Just ','
 185                  , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
 186                  , Style.grouping_integral   = Just $ Style.Grouping '.' [3]
 187                  , Style.precision = 2
 188                  , Style.unit_side = Just Style.Side_Right
 189                  , Style.unit_spaced = Just False
 190                  }
 191          , unit = "₹"
 192          }
 193 -- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> unit of currency.
 194 jpy :: Quantity -> Amount
 195 jpy q =
 196         Amount
 197          { quantity = q
 198          , style = Style.Style
 199                  { Style.fractioning = Just '.'
 200                  , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
 201                  , Style.grouping_integral   = Just $ Style.Grouping ',' [3]
 202                  , Style.precision = 2
 203                  , Style.unit_side = Just Style.Side_Left
 204                  , Style.unit_spaced = Just False
 205                  }
 206          , unit = "¥"
 207          }
 208 -- | <https://en.wikipedia.org/wiki/Russian_ruble Russian ruble> unit of currency.
 209 --
 210 -- NOTE: Ꝑ (U+A750) is used as a replacement latin letter,
 211 --       because GHC currently chokes on ₽ (U+20BD),
 212 --       which is the recently (2014/02) assigned Unicode code-point
 213 --       for this currency.
 214 rub :: Quantity -> Amount
 215 rub 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/United_States_dollar United States dollar> unit of currency.
 229 usd :: Quantity -> Amount
 230 usd q =
 231         Amount
 232          { quantity = q
 233          , style = Style.Style
 234                  { Style.fractioning = Just '.'
 235                  , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
 236                  , Style.grouping_integral = Just $ Style.Grouping ',' [3]
 237                  , Style.precision = 2
 238                  , Style.unit_side = Just Style.Side_Left
 239                  , Style.unit_spaced = Just False
 240                  }
 241          , unit = "$"
 242          }
 243
 244 -- ** Tests
 245
 246 -- | Return 'True' if and only if 'Amount'’s 'Quantity' is zero.
 247 --
 248 --  NOTE: the 'Amount'’s 'quantity' MUST be have been rounded at 'Amount'’s 'style'’s 'Style.precision'.
 249 is_zero :: Amount -> Bool
 250 is_zero = Quantity.is_zero . quantity
 251
 252 -- * The 'Amount_by_Unit' mapping
 253
 254 type Amount_by_Unit
 255  = Data.Map.Map Unit Amount
 256 type By_Unit = Amount_by_Unit
 257
 258 -- | 'Amount_by_Unit'’s is a partially valid 'Num' instance.
 259 --
 260 --   * (*) operator is not defined.
 261 instance Num Amount_by_Unit where
 262         abs         = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=abs    q})
 263         fromInteger = Data.Map.singleton "" . fromInteger
 264         negate      = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=negate q})
 265         signum      = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=signum q})
 266         (+)         = Data.Map.unionWith (+)
 267         (*)         = error "(*) not-supported"
 268
 269 type Signs = (Int, Int)
 270
 271 signs :: Amount_by_Unit -> Signs
 272 signs = Data.Map.foldl
 273  (\(nega, plus) amt ->
 274         case flip compare 0 $ quantity amt of
 275          LT -> (nega - 1, plus)
 276          EQ -> (nega, plus)
 277          GT -> (nega, plus + 1))
 278  (0, 0)
 279
 280 -- ** Constructors
 281
 282 nil_By_Unit :: Amount_by_Unit
 283 nil_By_Unit =
 284         Data.Map.empty
 285
 286 -- ** Tests
 287
 288 -- | Return 'True' if and only if all 'Amount's satisfy 'is_zero'.
 289 are_zero :: Amount_by_Unit -> Bool
 290 are_zero = Data.Foldable.all is_zero
 291
 292 -- | Return a tuple associating the given 'Amount' with its 'Unit'.
 293 assoc_by_unit :: Amount -> (Unit, Amount)
 294 assoc_by_unit amount = (unit amount, amount)
 295
 296 -- | Return a 'Data.Map.Map' associating the given 'Amount's with their respective 'Unit'.
 297 from_List :: [Amount] -> Amount_by_Unit
 298 from_List amounts =
 299         Data.Map.fromListWith (flip (+)) $ -- NOTE: flip to propagate 'Style' first to last.
 300         Data.List.map assoc_by_unit amounts