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