lib/Hcompta/Model/Amount.hs

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