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 at 'Style'’s precision.
 243 is_zero :: Amount -> Bool
 244 is_zero = Quantity.is_zero . quantity
 245
 246 -- * The 'By_Unit' mapping
 247
 248 type By_Unit
 249  = Data.Map.Map Unit Amount
 250
 251 -- | 'By_Unit'’s is a partially valid 'Num' instance.
 252 --
 253 --   * (*) operator is not defined.
 254 instance Num By_Unit where
 255         abs         = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=abs    q})
 256         fromInteger = Data.Map.singleton "" . fromInteger
 257         negate      = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=negate q})
 258         signum      = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=signum q})
 259         (+)         = Data.Map.unionWith (+)
 260         (*)         = error "(*) not-supported"
 261
 262 type Signs = (Int, Int)
 263
 264 signs :: By_Unit -> Signs
 265 signs = Data.Map.foldl
 266  (\(nega, plus) amt ->
 267         case flip compare 0 $ quantity amt of
 268          LT -> (nega - 1, plus)
 269          EQ -> (nega, plus)
 270          GT -> (nega, plus + 1))
 271  (0, 0)
 272
 273 -- ** Constructors
 274
 275 nil_By_Unit :: By_Unit
 276 nil_By_Unit =
 277         Data.Map.empty
 278
 279 -- ** Tests
 280
 281 -- | Return 'True' if and only if all 'Amount's are zero at their 'Style'’s precision.
 282 are_zero :: By_Unit -> Bool
 283 are_zero = Data.Foldable.all is_zero
 284
 285 -- | Return a tuple associating the given 'Amount' with its 'Unit'.
 286 assoc_by_unit :: Amount -> (Unit, Amount)
 287 assoc_by_unit amount = (unit amount, amount)
 288
 289 -- | Return a 'Data.Map.Map' associating the given 'Amount's with their respective 'Unit'.
 290 from_List :: [Amount] -> By_Unit
 291 from_List amounts =
 292         Data.Map.fromListWith (flip (+)) $ -- NOTE: flip to propagate 'Style' first to last.
 293         Data.List.map assoc_by_unit amounts