lib/Hcompta/Model/Amount.hs

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