lib/Hcompta/Model/Amount.hs

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