lcc/Hcompta/LCC/Amount.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE NamedFieldPuns #-}
   7 {-# LANGUAGE OverloadedStrings #-}
   8 {-# LANGUAGE TupleSections #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10 {-# LANGUAGE TypeOperators #-}
  11 {-# OPTIONS_GHC -fno-warn-orphans #-}
  12 module Hcompta.LCC.Amount where
  13
  14 import           Control.DeepSeq
  15 import           Data.Bool
  16 import           Data.Char (Char)
  17 import           Data.Data
  18 import           Data.Decimal (Decimal, roundTo)
  19 import           Data.Eq (Eq(..))
  20 import           Data.Function (($), (.), const, flip)
  21 import           Data.Map.Strict (Map)
  22 import qualified Data.Map.Strict as Map
  23 import           Data.Maybe (Maybe(..), maybe)
  24 import           Data.Monoid (Monoid(..))
  25 import qualified Data.MonoTraversable as MT
  26 import           Data.Ord (Ord(..))
  27 import           Data.Text (Text)
  28 import           Data.String (IsString)
  29 import           Data.Typeable ()
  30 import           Data.Word (Word8)
  31 import           Prelude (Int, seq)
  32 import           Text.Show (Show(..))
  33
  34 import qualified Hcompta as H
  35
  36 -- * Type 'Amount'
  37 data Amount
  38  =   Amount
  39  {   amount_unit     :: !Unit
  40  ,   amount_quantity :: !Quantity
  41  } deriving (Data, Eq, Show, Typeable)
  42 instance NFData Amount where
  43         rnf (Amount q u) = rnf q `seq` rnf u
  44 instance H.Amount Amount
  45
  46 type instance H.Unit H.:@ Amount = Unit
  47 instance H.GetI H.Unit Amount where
  48         getI _ = amount_unit
  49 instance H.SetI H.Unit Amount where
  50         setI _ amount_unit a = a{amount_unit}
  51
  52 type instance H.Quantity H.:@ Amount = Quantity
  53 instance H.GetI H.Quantity Amount where
  54         getI _ = amount_quantity
  55 instance H.SetI H.Quantity Amount where
  56         setI _ amount_quantity a = a{amount_quantity}
  57
  58 instance H.Zero Amount where
  59         quantity_zero = Amount H.unit_empty H.quantity_zero
  60         quantity_null = H.quantity_null . amount_quantity
  61         --  NOTE: the 'Amount'’s 'amount_quantity' MUST already be rounded
  62         --        at 'Amount'’s 'amount_amount_style'’s 'amount_style_precision'.
  63         quantity_sign = H.quantity_sign . amount_quantity
  64
  65 amount :: Amount
  66 amount =
  67         Amount
  68          { amount_quantity = H.quantity_zero
  69          , amount_unit     = ""
  70          }
  71
  72 amount_amount_style :: Amount_Styles -> Amount -> Amount_Style
  73 amount_amount_style styles = amount_style_find styles . amount_unit
  74
  75 -- * Type 'Quantity'
  76 type Quantity = Decimal
  77
  78 quantity_round :: Word8 -> Quantity -> Quantity
  79 quantity_round = Data.Decimal.roundTo
  80
  81 -- * Type 'Unit'
  82 newtype Unit
  83  = Unit Text
  84  deriving (Data, Eq, IsString, Ord, Show, Typeable)
  85 instance H.Unit Unit where
  86         unit_empty = Unit ""
  87         unit_text (Unit t) = t
  88 instance NFData Unit where
  89         rnf (Unit t) = rnf t
  90
  91 -- ** Example 'Unit's
  92
  93 -- | 'H.unit_empty'.
  94 unit_scalar :: Unit
  95 unit_scalar = H.unit_empty
  96
  97 -- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
  98 unit_chf :: Unit
  99 unit_chf = Unit "CHF"
 100
 101 -- | <https://en.wikipedia.org/wiki/Yuan Yuan> unit of currency.
 102 unit_cny :: Unit
 103 unit_cny = Unit "Ұ"
 104
 105 -- | <https://en.wikipedia.org/wiki/Euro Euro> unit of currency.
 106 unit_eur :: Unit
 107 unit_eur = Unit "€"
 108
 109 -- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> unit of currency.
 110 unit_gbp :: Unit
 111 unit_gbp = Unit "£"
 112
 113 -- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> unit of currency.
 114 unit_inr :: Unit
 115 unit_inr = Unit "₹"
 116
 117 -- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> unit of currency.
 118 unit_jpy :: Unit
 119 unit_jpy = Unit "¥"
 120
 121 -- | <https://en.wikipedia.org/wiki/Russian_ruble Russian ruble> unit of currency.
 122 --
 123 -- NOTE: Ꝑ (U+A750) is used as a replacement latin letter,
 124 --       because GHC currently chokes on ₽ (U+20BD),
 125 --       which is the recently (2014/02) assigned Unicode code-point
 126 --       for this currency.
 127 unit_rub :: Unit
 128 unit_rub = Unit "Ꝑ"
 129
 130 -- | <https://en.wikipedia.org/wiki/United_States_dollar United States dollar> unit of currency.
 131 unit_usd :: Unit
 132 unit_usd = Unit "$"
 133
 134 -- * Type 'Amount_Style'
 135 data Amount_Style
 136  =   Amount_Style
 137  { amount_style_fractioning         :: Maybe Amount_Style_Fractioning
 138  , amount_style_grouping_integral   :: Maybe Amount_Style_Grouping
 139  , amount_style_grouping_fractional :: Maybe Amount_Style_Grouping
 140  -- TODO: , amount_style_sign_plus     :: Maybe Bool
 141  , amount_style_unit_side           :: Maybe Amount_Style_Side
 142  , amount_style_unit_spaced         :: Maybe Amount_Style_Spacing
 143  } deriving (Data, Eq, Ord, Show, Typeable)
 144 instance NFData Amount_Style where
 145         rnf (Amount_Style f gi gf ui up) =
 146                 rnf f  `seq`
 147                 rnf gi `seq`
 148                 rnf gf `seq`
 149                 rnf ui `seq`
 150                 rnf up
 151 instance Monoid Amount_Style where
 152         mempty  = amount_style
 153         mappend = amount_style_union
 154
 155 amount_style :: Amount_Style
 156 amount_style =
 157         Amount_Style
 158          { amount_style_fractioning         = Nothing
 159          , amount_style_grouping_integral   = Nothing
 160          , amount_style_grouping_fractional = Nothing
 161          , amount_style_unit_side           = Nothing
 162          , amount_style_unit_spaced         = Nothing
 163          }
 164
 165 amount_style_union
 166  :: Amount_Style
 167  -> Amount_Style
 168  -> Amount_Style
 169 amount_style_union
 170  sty@Amount_Style
 171  { amount_style_fractioning=f
 172  , amount_style_grouping_integral=gi
 173  , amount_style_grouping_fractional=gf
 174  , amount_style_unit_side=side
 175  , amount_style_unit_spaced=spaced
 176  }
 177  sty'@Amount_Style
 178  { amount_style_fractioning=f'
 179  , amount_style_grouping_integral=gi'
 180  , amount_style_grouping_fractional=gf'
 181  , amount_style_unit_side=side'
 182  , amount_style_unit_spaced=spaced'
 183  } =
 184         if sty == sty'
 185         then sty'
 186         else
 187                 Amount_Style
 188                  { amount_style_fractioning         = maybe f'      (const f)      f
 189                  , amount_style_grouping_integral   = maybe gi'     (const gi)     gi
 190                  , amount_style_grouping_fractional = maybe gf'     (const gf)     gf
 191                  , amount_style_unit_side           = maybe side'   (const side)   side
 192                  , amount_style_unit_spaced         = maybe spaced' (const spaced) spaced
 193                  }
 194
 195 -- ** Type 'Amount_Style_Fractioning'
 196 type Amount_Style_Fractioning
 197  = Char
 198
 199 -- ** Type 'Amount_Style_Grouping'
 200 data Amount_Style_Grouping
 201  =   Amount_Style_Grouping Char [Int]
 202  deriving (Data, Eq, Ord, Show, Typeable)
 203 instance NFData Amount_Style_Grouping where
 204         rnf (Amount_Style_Grouping s d) = rnf s `seq` rnf d
 205
 206 -- ** Type 'Amount_Style_Precision'
 207 type Amount_Style_Precision
 208  = Word8
 209
 210 -- ** Type 'Amount_Style_Spacing'
 211 type Amount_Style_Spacing
 212  = Bool
 213
 214 -- ** Type 'Amount_Style_Side'
 215 data Amount_Style_Side
 216  =   Amount_Style_Side_Left
 217  |   Amount_Style_Side_Right
 218  deriving (Data, Eq, Ord, Show, Typeable)
 219 instance NFData Amount_Style_Side where
 220         rnf Amount_Style_Side_Left  = ()
 221         rnf Amount_Style_Side_Right = ()
 222
 223 -- ** Type 'Amount_Styles'
 224 newtype Amount_Styles
 225  =      Amount_Styles (Map Unit Amount_Style)
 226  deriving (Data, Eq, NFData, Show, Typeable)
 227 instance Monoid Amount_Styles where
 228         mempty = Amount_Styles mempty
 229         mappend (Amount_Styles x) (Amount_Styles y) =
 230                 Amount_Styles (Map.unionWith (flip mappend) x y)
 231
 232 -- ** Operators
 233 amount_style_cons :: (Unit, Amount_Style) -> Amount_Styles -> Amount_Styles
 234 amount_style_cons (u, s) (Amount_Styles ss) =
 235         Amount_Styles $
 236         Map.insertWith (flip mappend) u s ss
 237
 238 amount_style_find :: Amount_Styles -> Unit -> Amount_Style
 239 amount_style_find (Amount_Styles s) u = Map.findWithDefault mempty u s
 240
 241 -- *** Example 'Amount_Styles'
 242 amount_styles :: Amount_Styles
 243 amount_styles = Amount_Styles $ Map.fromList
 244  [ (unit_scalar,) Amount_Style
 245     { amount_style_fractioning         = Just '.'
 246     , amount_style_grouping_fractional = Just $ Amount_Style_Grouping ',' [3]
 247     , amount_style_grouping_integral   = Just $ Amount_Style_Grouping ',' [3]
 248     , amount_style_unit_side           = Just Amount_Style_Side_Right
 249     , amount_style_unit_spaced         = Just False
 250     }
 251  , (unit_chf,) Amount_Style
 252     { amount_style_fractioning         = Just ','
 253     , amount_style_grouping_fractional = Just $ Amount_Style_Grouping '.' [3]
 254     , amount_style_grouping_integral   = Just $ Amount_Style_Grouping '.' [3]
 255     , amount_style_unit_side           = Just Amount_Style_Side_Right
 256     , amount_style_unit_spaced         = Just False
 257     }
 258  , (unit_cny,) Amount_Style
 259     { amount_style_fractioning         = Just ','
 260     , amount_style_grouping_fractional = Just $ Amount_Style_Grouping '.' [3]
 261     , amount_style_grouping_integral   = Just $ Amount_Style_Grouping '.' [3]
 262     , amount_style_unit_side           = Just Amount_Style_Side_Right
 263     , amount_style_unit_spaced         = Just False
 264     }
 265  , (unit_eur,) Amount_Style
 266     { amount_style_fractioning         = Just ','
 267     , amount_style_grouping_fractional = Just $ Amount_Style_Grouping '.' [3]
 268     , amount_style_grouping_integral   = Just $ Amount_Style_Grouping '.' [3]
 269     , amount_style_unit_side           = Just Amount_Style_Side_Right
 270     , amount_style_unit_spaced         = Just False
 271     }
 272  , (unit_gbp,) Amount_Style
 273     { amount_style_fractioning         = Just '.'
 274     , amount_style_grouping_fractional = Just $ Amount_Style_Grouping ',' [3]
 275     , amount_style_grouping_integral   = Just $ Amount_Style_Grouping ',' [3]
 276     , amount_style_unit_side           = Just Amount_Style_Side_Left
 277     , amount_style_unit_spaced         = Just False
 278     }
 279  , (unit_inr,) Amount_Style
 280     { amount_style_fractioning         = Just ','
 281     , amount_style_grouping_fractional = Just $ Amount_Style_Grouping '.' [3]
 282     , amount_style_grouping_integral   = Just $ Amount_Style_Grouping '.' [3]
 283     , amount_style_unit_side           = Just Amount_Style_Side_Right
 284     , amount_style_unit_spaced         = Just False
 285     }
 286  , (unit_jpy,) Amount_Style
 287     { amount_style_fractioning         = Just '.'
 288     , amount_style_grouping_fractional = Just $ Amount_Style_Grouping ',' [3]
 289     , amount_style_grouping_integral   = Just $ Amount_Style_Grouping ',' [3]
 290     , amount_style_unit_side           = Just Amount_Style_Side_Left
 291     , amount_style_unit_spaced         = Just False
 292     }
 293  , (unit_rub,) Amount_Style
 294     { amount_style_fractioning         = Just '.'
 295     , amount_style_grouping_fractional = Just $ Amount_Style_Grouping ',' [3]
 296     , amount_style_grouping_integral   = Just $ Amount_Style_Grouping ',' [3]
 297     , amount_style_unit_side           = Just Amount_Style_Side_Left
 298     , amount_style_unit_spaced         = Just False
 299     }
 300  , (unit_usd,) Amount_Style
 301     { amount_style_fractioning         = Just '.'
 302     , amount_style_grouping_fractional = Just $ Amount_Style_Grouping ',' [3]
 303     , amount_style_grouping_integral   = Just $ Amount_Style_Grouping ',' [3]
 304     , amount_style_unit_side           = Just Amount_Style_Side_Left
 305     , amount_style_unit_spaced         = Just False
 306     }
 307  ]
 308
 309 -- ** Type 'Amount_Styled'
 310 type Amount_Styled t = (Amount_Style, t)
 311
 312 amount_styled :: Amount_Styles -> Amount -> Amount_Styled Amount
 313 amount_styled styles amt = (amount_amount_style styles amt, amt)
 314
 315 -- * Type 'Amounts'
 316 newtype Amounts = Amounts (Map Unit Quantity)
 317  deriving (Data, Eq, NFData, Show, Typeable
 318  , H.Zero, H.Addable, H.Negable, H.Subable)
 319 instance Monoid Amounts where
 320         mempty = Amounts mempty
 321         mappend (Amounts x) (Amounts y) =
 322                 Amounts (Map.unionWith (flip H.quantity_add) x y)
 323
 324 type instance MT.Element Amounts = Amount
 325 instance H.Amounts Amounts
 326
 327 instance H.Get (H.Balance_Amounts Unit Quantity) Amounts where
 328         get (Amounts a) = a