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 instance H.Zeroable Style_Amounts where
 255         zero = Style_Amounts mempty
 256 instance H.Sumable Style_Amounts (Unit, Style_Amount) where
 257         Style_Amounts ss += (u, s) = Style_Amounts $ Map.insertWith (flip (<>)) u s ss
 258
 259 unStyle_Amounts :: Style_Amounts -> Map Unit Style_Amount
 260 unStyle_Amounts (Style_Amounts fp) = fp
 261
 262 style_amount_find :: Style_Amounts -> Unit -> Style_Amount
 263 style_amount_find (Style_Amounts s) u = Map.findWithDefault mempty u s
 264
 265 -- *** Example 'Style_Amounts'
 266 style_amounts :: Style_Amounts
 267 style_amounts = Style_Amounts $ Map.fromList
 268  [ (unit_scalar,) Style_Amount
 269     { style_amount_fractioning         = Just '.'
 270     , style_amount_grouping_fractional = Just $ Style_Amount_Grouping ',' [3]
 271     , style_amount_grouping_integral   = Just $ Style_Amount_Grouping ',' [3]
 272     , style_amount_unit_side           = Just R
 273     , style_amount_unit_spaced         = Just False
 274     }
 275  , (unit_chf,) Style_Amount
 276     { style_amount_fractioning         = Just ','
 277     , style_amount_grouping_fractional = Just $ Style_Amount_Grouping '.' [3]
 278     , style_amount_grouping_integral   = Just $ Style_Amount_Grouping '.' [3]
 279     , style_amount_unit_side           = Just R
 280     , style_amount_unit_spaced         = Just False
 281     }
 282  , (unit_cny,) Style_Amount
 283     { style_amount_fractioning         = Just ','
 284     , style_amount_grouping_fractional = Just $ Style_Amount_Grouping '.' [3]
 285     , style_amount_grouping_integral   = Just $ Style_Amount_Grouping '.' [3]
 286     , style_amount_unit_side           = Just R
 287     , style_amount_unit_spaced         = Just False
 288     }
 289  , (unit_eur,) Style_Amount
 290     { style_amount_fractioning         = Just ','
 291     , style_amount_grouping_fractional = Just $ Style_Amount_Grouping '.' [3]
 292     , style_amount_grouping_integral   = Just $ Style_Amount_Grouping '.' [3]
 293     , style_amount_unit_side           = Just R
 294     , style_amount_unit_spaced         = Just False
 295     }
 296  , (unit_gbp,) Style_Amount
 297     { style_amount_fractioning         = Just '.'
 298     , style_amount_grouping_fractional = Just $ Style_Amount_Grouping ',' [3]
 299     , style_amount_grouping_integral   = Just $ Style_Amount_Grouping ',' [3]
 300     , style_amount_unit_side           = Just L
 301     , style_amount_unit_spaced         = Just False
 302     }
 303  , (unit_inr,) Style_Amount
 304     { style_amount_fractioning         = Just ','
 305     , style_amount_grouping_fractional = Just $ Style_Amount_Grouping '.' [3]
 306     , style_amount_grouping_integral   = Just $ Style_Amount_Grouping '.' [3]
 307     , style_amount_unit_side           = Just R
 308     , style_amount_unit_spaced         = Just False
 309     }
 310  , (unit_jpy,) Style_Amount
 311     { style_amount_fractioning         = Just '.'
 312     , style_amount_grouping_fractional = Just $ Style_Amount_Grouping ',' [3]
 313     , style_amount_grouping_integral   = Just $ Style_Amount_Grouping ',' [3]
 314     , style_amount_unit_side           = Just L
 315     , style_amount_unit_spaced         = Just False
 316     }
 317  , (unit_rub,) Style_Amount
 318     { style_amount_fractioning         = Just '.'
 319     , style_amount_grouping_fractional = Just $ Style_Amount_Grouping ',' [3]
 320     , style_amount_grouping_integral   = Just $ Style_Amount_Grouping ',' [3]
 321     , style_amount_unit_side           = Just L
 322     , style_amount_unit_spaced         = Just False
 323     }
 324  , (unit_usd,) Style_Amount
 325     { style_amount_fractioning         = Just '.'
 326     , style_amount_grouping_fractional = Just $ Style_Amount_Grouping ',' [3]
 327     , style_amount_grouping_integral   = Just $ Style_Amount_Grouping ',' [3]
 328     , style_amount_unit_side           = Just L
 329     , style_amount_unit_spaced         = Just False
 330     }
 331  ]
 332
 333 -- ** Type 'Styled_Amount'
 334 type Styled_Amount t = (Style_Amount, t)
 335
 336 styled_amount :: Style_Amounts -> Amount -> Styled_Amount Amount
 337 styled_amount styles amt = (amount_style styles amt, amt)
 338
 339 -- * Type 'Amounts'
 340 newtype Amounts = Amounts (Map Unit Quantity)
 341  deriving (Data, Eq, NFData, Ord, Show, Typeable
 342  , H.Addable, H.Negable, H.Subable)
 343 unAmounts :: Amounts -> Map Unit Quantity
 344 unAmounts (Amounts a) = a
 345 instance H.Zeroable Amounts where
 346         zero = Amounts H.zero
 347 instance H.Nullable Amounts where
 348         null (Amounts x) = H.null x
 349 instance Semigroup Amounts where
 350         Amounts x <> Amounts y = Amounts (Map.unionWith (flip (H.+)) x y)
 351 instance Monoid Amounts where
 352         mempty  = Amounts mempty
 353         mappend = (<>)
 354
 355 type instance MT.Element Amounts = Amount
 356 -- instance H.Amounts Amounts
 357
 358 -- instance H.Get (H.Balance_Amounts Unit Quantity) Amounts where
 359 --      get (Amounts a) = a