jcc/Hcompta/JCC/Amount.hs

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