lib/Hcompta/Amount.hs

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