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.Model.Amount.Quantity as Quantity
  15 import qualified Hcompta.Model.Amount.Style as Style
  16 import qualified Hcompta.Model.Amount.Unit as Unit
  17
  18 -- * Type synonyms to submodules
  19
  20 type Quantity   = Quantity.Quantity
  21 type Style      = Style.Style
  22 type Unit       = Unit.Unit
  23
  24 -- * The 'Amount' type
  25
  26 data Amount
  27  =   Amount
  28  { quantity :: Quantity
  29  , style :: Style
  30  , unit :: Unit
  31  } deriving (Data, Eq, Ord, Read, Show, Typeable)
  32
  33 -- | An 'Amount' is a partially valid 'Num' instance:
  34 --
  35 --   * (+) operator requires both operand to have the same 'Unit' (homogeneity constraint).
  36 --   * (*) operator requires at least one operand with an empty 'Unit' ('scalar').
  37 instance Num Amount where
  38         abs    a@Amount{quantity=q} = a{quantity=abs q}
  39         fromInteger            = scalar . fromInteger
  40         negate a@Amount{quantity=q} = a{quantity=negate q}
  41         signum a@Amount{quantity=q} = a{quantity=signum q}
  42         (+) a b = a{ quantity=quantity a + quantity b
  43                    , style=Style.union (style a) (style b)
  44                    , unit=if unit a == unit b then unit a else error "(+) on non-homogeneous units"
  45                    }
  46         (*) a b = a{ quantity=quantity a * quantity b
  47                    , style=s
  48                    , unit=u
  49                    }
  50                 where (s, u) =
  51                         if unit a == ""
  52                         then
  53                                 if unit b == ""
  54                                 then (Style.union (style a) (style b), "")
  55                                 else (style b, unit b)
  56                         else
  57                                 if unit b == ""
  58                                 then (style a, unit a)
  59                                 else error "(*) by non-scalar unit"
  60
  61 -- ** Constructors
  62
  63 nil :: Amount
  64 nil =
  65         Amount
  66          { quantity = Quantity.nil
  67          , style = Style.nil
  68          , unit = ""
  69          }
  70
  71 -- *** From 'Quantity'
  72
  73 -- | Return an 'Amount' with 'unit' = Unit.'Unit.nil'.
  74 scalar :: Quantity -> Amount
  75 scalar q =
  76         Amount
  77          { quantity = q
  78          , style = Style.Style
  79                  { Style.fractioning = Just '.'
  80                  , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
  81                  , Style.grouping_integral   = Just $ Style.Grouping ',' [3]
  82                  , Style.precision = maxBound
  83                  , Style.unit_side = Just Style.Side_Right
  84                  , Style.unit_spaced = Just False
  85                  }
  86          , unit = ""
  87          }
  88
  89 -- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
  90 chf :: Quantity -> Amount
  91 chf q =
  92         Amount
  93          { quantity = q
  94          , style = Style.Style
  95                  { Style.fractioning = Just ','
  96                  , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
  97                  , Style.grouping_integral   = Just $ Style.Grouping '.' [3]
  98                  , Style.precision = 2
  99                  , Style.unit_side = Just Style.Side_Right
 100                  , Style.unit_spaced = Just False
 101                  }
 102          , unit = "CHF"
 103          }
 104 -- | <https://en.wikipedia.org/wiki/Yuan Yuan> unit of currency.
 105 cny :: Quantity -> Amount
 106 cny 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 = 2
 114                  , Style.unit_side = Just Style.Side_Right
 115                  , Style.unit_spaced = Just False
 116                  }
 117          , unit = "Ұ"
 118          }
 119 -- | <https://en.wikipedia.org/wiki/Euro Euro> unit of currency.
 120 eur :: Quantity -> Amount
 121 eur q =
 122         Amount
 123          { quantity = q
 124          , style = Style.Style
 125                  { Style.fractioning = Just ','
 126                  , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
 127                  , Style.grouping_integral   = Just $ Style.Grouping '.' [3]
 128                  , Style.precision = 2
 129                  , Style.unit_side = Just Style.Side_Right
 130                  , Style.unit_spaced = Just False
 131                  }
 132          , unit = "€"
 133          }
 134 -- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> unit of currency.
 135 gbp :: Quantity -> Amount
 136 gbp q =
 137         Amount
 138          { quantity = q
 139          , style = Style.Style
 140                  { Style.fractioning = Just '.'
 141                  , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
 142                  , Style.grouping_integral   = Just $ Style.Grouping ',' [3]
 143                  , Style.precision = 2
 144                  , Style.unit_side = Just Style.Side_Left
 145                  , Style.unit_spaced = Just False
 146                  }
 147          , unit = "£"
 148          }
 149 -- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> unit of currency.
 150 inr :: Quantity -> Amount
 151 inr q =
 152         Amount
 153          { quantity = q
 154          , style = Style.Style
 155                  { Style.fractioning = Just ','
 156                  , Style.grouping_fractional = Just $ Style.Grouping '.' [3]
 157                  , Style.grouping_integral   = Just $ Style.Grouping '.' [3]
 158                  , Style.precision = 2
 159                  , Style.unit_side = Just Style.Side_Right
 160                  , Style.unit_spaced = Just False
 161                  }
 162          , unit = "₹"
 163          }
 164 -- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> unit of currency.
 165 jpy :: Quantity -> Amount
 166 jpy q =
 167         Amount
 168          { quantity = q
 169          , style = Style.Style
 170                  { Style.fractioning = Just '.'
 171                  , Style.grouping_fractional = Just $ Style.Grouping ',' [3]
 172                  , Style.grouping_integral   = Just $ Style.Grouping ',' [3]
 173                  , Style.precision = 2
 174                  , Style.unit_side = Just Style.Side_Left
 175                  , Style.unit_spaced = Just False
 176                  }
 177          , unit = "¥"
 178          }
 179 -- | <https://en.wikipedia.org/wiki/Russian_ruble Russian ruble> unit of currency.
 180 --
 181 -- NOTE: Ꝑ (U+A750) is used as a replacement latin letter,
 182 --       because GHC currently chokes on ₽ (U+20BD),
 183 --       which is the recently (2014/02) assigned Unicode code-point
 184 --       for this currency.
 185 rub :: Quantity -> Amount
 186 rub 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/United_States_dollar United States dollar> unit of currency.
 200 usd :: Quantity -> Amount
 201 usd 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_Left
 210                  , Style.unit_spaced = Just False
 211                  }
 212          , unit = "$"
 213          }
 214
 215 -- ** Tests
 216
 217 -- | Return 'True' if and only if 'Amount'’s 'Quantity' is zero at 'Style'’s precision.
 218 is_zero :: Amount -> Bool
 219 is_zero amount =
 220         Quantity.is_zero
 221          (Style.precision $ style amount) $
 222         quantity amount
 223
 224 -- * The 'By_Unit' mapping
 225
 226 type By_Unit
 227  = Data.Map.Map Unit Amount
 228
 229 -- | 'By_Unit'’s is a partially valid 'Num' instance.
 230 --
 231 --   * (*) operator is not defined.
 232 instance Num By_Unit where
 233         abs         = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=abs    q})
 234         fromInteger = Data.Map.singleton "" . fromInteger
 235         negate      = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=negate q})
 236         signum      = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=signum q})
 237         (+)         = Data.Map.unionWith (+)
 238         (*)         = error "(*) not-supported"
 239
 240 -- ** Constructors
 241
 242 nil_By_Unit :: By_Unit
 243 nil_By_Unit =
 244         Data.Map.empty
 245
 246 -- ** Tests
 247
 248 -- | Return 'True' if and only if all 'Amount's are zero at their 'Style'’s precision.
 249 are_zero :: By_Unit -> Bool
 250 are_zero = Data.Foldable.all is_zero
 251
 252 -- | Return a tuple associating the given 'Amount' with its 'Unit'.
 253 assoc_by_unit :: Amount -> (Unit, Amount)
 254 assoc_by_unit amount = (unit amount, amount)
 255
 256 -- | Return a 'Data.Map.Map' associating the given 'Amount's with their respective 'Unit'.
 257 from_List :: [Amount] -> By_Unit
 258 from_List amounts =
 259         Data.Map.fromListWith (flip (+)) $ -- NOTE: flip to propagate 'Style' first to last.
 260         Data.List.map assoc_by_unit amounts