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