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 null :: Amount
  66 null =
  67         Amount
  68          { conversion = Nothing
  69          , quantity = Quantity.null
  70          , style = Style.null
  71          , unit = ""
  72          }
  73
  74 --- *** From 'Quantity'
  75
  76 -- | Return an empty 'Unit' 'Amount'.
  77 scalar :: Quantity -> Amount
  78 scalar q =
  79         Amount
  80          { conversion=Nothing
  81          , quantity=q
  82          , style=Style.Style
  83                  { Style.decimal_point=Just '.'
  84                  , Style.format=Just $ Style.Format ',' [3]
  85                  , Style.precision=maxBound
  86                  , Style.unit_side=Just Style.Side_Right
  87                  , Style.unit_spaced=Just False
  88                  }
  89          , unit=""
  90          }
  91
  92 -- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
  93 chf :: Quantity -> Amount
  94 chf q =
  95         Amount
  96          { conversion=Nothing
  97          , quantity=q
  98          , style=Style.Style
  99                  { Style.decimal_point=Just ','
 100                  , Style.format=Just $ Style.Format '.' [3]
 101                  , Style.precision=2
 102                  , Style.unit_side=Just Style.Side_Right
 103                  , Style.unit_spaced=Just False
 104                  }
 105          , unit="CHF"
 106          }
 107 -- | <https://en.wikipedia.org/wiki/Yuan Yuan> unit of currency.
 108 cny :: Quantity -> Amount
 109 cny q =
 110         Amount
 111          { conversion=Nothing
 112          , quantity=q
 113          , style=Style.Style
 114                  { Style.decimal_point=Just ','
 115                  , Style.format=Just $ Style.Format '.' [3]
 116                  , Style.precision=2
 117                  , Style.unit_side=Just Style.Side_Right
 118                  , Style.unit_spaced=Just False
 119                  }
 120          , unit="Ұ"
 121          }
 122 -- | <https://en.wikipedia.org/wiki/Euro Euro> unit of currency.
 123 eur :: Quantity -> Amount
 124 eur q =
 125         Amount
 126          { conversion=Nothing
 127          , quantity=q
 128          , style=Style.Style
 129                  { Style.decimal_point=Just ','
 130                  , Style.format=Just $ Style.Format '.' [3]
 131                  , Style.precision=2
 132                  , Style.unit_side=Just Style.Side_Right
 133                  , Style.unit_spaced=Just False
 134                  }
 135          , unit="€"
 136          }
 137 -- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> unit of currency.
 138 gbp :: Quantity -> Amount
 139 gbp q =
 140         Amount
 141          { conversion=Nothing
 142          , quantity=q
 143          , style=Style.Style
 144                  { Style.decimal_point=Just '.'
 145                  , Style.format=Just $ Style.Format ',' [3]
 146                  , Style.precision=2
 147                  , Style.unit_side=Just Style.Side_Left
 148                  , Style.unit_spaced=Just False
 149                  }
 150          , unit="£"
 151          }
 152 -- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> unit of currency.
 153 inr :: Quantity -> Amount
 154 inr q =
 155         Amount
 156          { conversion=Nothing
 157          , quantity=q
 158          , style=Style.Style
 159                  { Style.decimal_point=Just ','
 160                  , Style.format=Just $ Style.Format '.' [3]
 161                  , Style.precision=2
 162                  , Style.unit_side=Just Style.Side_Right
 163                  , Style.unit_spaced=Just False
 164                  }
 165          , unit="₹"
 166          }
 167 -- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> unit of currency.
 168 jpy :: Quantity -> Amount
 169 jpy q =
 170         Amount
 171          { conversion=Nothing
 172          , quantity=q
 173          , style=Style.Style
 174                  { Style.decimal_point=Just '.'
 175                  , Style.format=Just $ Style.Format ',' [3]
 176                  , Style.precision=2
 177                  , Style.unit_side=Just Style.Side_Left
 178                  , Style.unit_spaced=Just False
 179                  }
 180          , unit="¥"
 181          }
 182 -- | <https://en.wikipedia.org/wiki/Russian_ruble Russian ruble> unit of currency.
 183 --
 184 -- NOTE: Ꝑ (U+A750) is used as a replacement latin letter,
 185 --       because GHC currently chokes on ₽ (U+20BD),
 186 --       which is the recently (2014/02) assigned Unicode code-point
 187 --       for this currency.
 188 rub :: Quantity -> Amount
 189 rub q =
 190         Amount
 191          { conversion=Nothing
 192          , quantity=q
 193          , style=Style.Style
 194                  { Style.decimal_point=Just '.'
 195                  , Style.format=Just $ Style.Format ',' [3]
 196                  , Style.precision=2
 197                  , Style.unit_side=Just Style.Side_Left
 198                  , Style.unit_spaced=Just False
 199                  }
 200          , unit="Ꝑ"
 201          }
 202 -- | <https://en.wikipedia.org/wiki/United_States_dollar United States dollar> unit of currency.
 203 usd :: Quantity -> Amount
 204 usd q =
 205         Amount
 206          { conversion=Nothing
 207          , quantity=q
 208          , style=Style.Style
 209                  { Style.decimal_point=Just '.'
 210                  , Style.format=Just $ Style.Format ',' [3]
 211                  , Style.precision=2
 212                  , Style.unit_side=Just Style.Side_Left
 213                  , Style.unit_spaced=Just False
 214                  }
 215          , unit="$"
 216          }
 217
 218 --- ** Tests
 219
 220 -- | Return 'True' if and only if 'Amount'’s 'Quantity' is zero at 'Style'’s precision.
 221 is_zero :: Amount -> Bool
 222 is_zero amount =
 223         Quantity.is_zero
 224          (Style.precision $ style amount) $
 225         quantity amount
 226
 227 -- * The 'By_Unit' mapping
 228
 229 -- | 'By_Unit'’s is a partially valid 'Num' instance:
 230 --
 231 --   * (*) operator is not defined.
 232 type By_Unit
 233  = Data.Map.Map Unit Amount
 234
 235 -- XXX: haddock drops this instance
 236 -- | 'By_Unit'’s is a partially valid 'Num' instance.
 237 instance Num By_Unit where
 238         abs         = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=abs    q})
 239         fromInteger = Data.Map.singleton "" . fromInteger
 240         negate      = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=negate q})
 241         signum      = Data.Map.map (\a@Amount{quantity=q} -> a{quantity=signum q})
 242         (+)         = Data.Map.unionWith (+)
 243         (*)         = error "(*) not-supported"
 244
 245 -- ** Constructors
 246
 247 null_By_Unit :: By_Unit
 248 null_By_Unit =
 249         Data.Map.empty
 250
 251 -- ** Tests
 252
 253 -- | Return 'True' if and only if all 'Amount's are zero at their 'Style'’s precision.
 254 are_zero :: By_Unit -> Bool
 255 are_zero = Data.Foldable.all is_zero
 256
 257 -- | Return a tuple associating the given 'Amount' with its 'Unit'.
 258 assoc_by_unit :: Amount -> (Unit, Amount)
 259 assoc_by_unit amount = (unit amount, amount)
 260
 261 -- | Return a 'Data.Map.Map' associating the given 'Amount's with their respective 'Unit'.
 262 from_List :: [Amount] -> By_Unit
 263 from_List amounts =
 264         Data.Map.fromListWith (+) $
 265         Data.List.map assoc_by_unit amounts