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