src/Symantic/Compta/Calc/Unit.hs

   1 {-# LANGUAGE NoOverloadedLists #-}
   2 module Symantic.Compta.Calc.Unit where
   3
   4 import Control.DeepSeq (NFData)
   5 --import Data.Word (Word8)
   6 import Data.Bool (Bool(..))
   7 import Data.Char (Char)
   8 import Data.Int (Int)
   9 import Data.Eq (Eq)
  10 import Data.Ord (Ord)
  11 import GHC.Stack (HasCallStack)
  12 import GHC.Generics (Generic)
  13 import Data.String (String)
  14 import Data.Functor ((<$>))
  15 import Data.Monoid (Monoid(..))
  16 import Data.Function (flip)
  17 import Data.Semigroup (Semigroup(..))
  18 import Text.Show (Show)
  19 import qualified Data.Map.Strict as Map
  20 import qualified Data.Char as Char
  21
  22 import Symantic.Compta.Lang
  23 import Symantic.Compta.Utils.Error
  24
  25 data EUR
  26
  27 -- * Class 'Unitable'
  28 class Unitable repr where
  29   unit :: HasCallStack => Ty repr TyUnit -> repr a -> repr a
  30   --withUnit :: repr U -> repr a -> repr a
  31
  32 --withEuro :: repr a -> repr a
  33 --withEuro = withUnit euro
  34
  35 -- ** Class 'EURable'
  36 class EURable repr where
  37   eur :: repr TyQuantity -> repr TyAmount
  38 (€) :: EURable repr => repr TyQuantity -> repr TyAmount
  39 (€) = eur
  40 -- ** Class 'USDable'
  41 class USDable repr where
  42   usd :: repr TyQuantity -> repr TyAmount
  43 --($) = usd
  44
  45 -- * Type 'Unit'
  46 newtype Unit = Unit String
  47   deriving newtype (Eq, Ord, Show, NFData)
  48   deriving anyclass (Generic)
  49 instance IsString Unit where
  50   fromString = \case
  51     s@[c] | Char.CurrencySymbol <- Char.generalCategory c -> Unit s
  52     [] -> Unit ""
  53     _ -> errorWithStack "Unit"
  54
  55 -- * Type 'Quantity'
  56 newtype Quantity qty = Quantity qty
  57   deriving newtype (Eq, Show, NFData, Zeroable, Nullable, Addable, Negable, FromInteger, FromRational)
  58 instance Addable a => Semigroup (Quantity a) where
  59   Quantity x <> Quantity y = Quantity (x + y)
  60 instance (Zeroable a, Addable a) => Monoid (Quantity a) where
  61   mempty = Quantity zero
  62
  63 -- * Type 'Amounts'
  64 newtype Amounts unit qty = Amounts (Map.Map unit qty)
  65   deriving newtype (Eq, Show, NFData)
  66 {-
  67 instance Zeroable (Amounts a) where
  68   zero = Amounts Map.empty
  69 instance Nullable (Amounts a) where
  70   null (Amounts x) = Foldable.all null x
  71 -}
  72 instance (Ord unit, Semigroup qty) => Semigroup (Amounts unit qty) where
  73   Amounts x <> Amounts y = Amounts (Map.unionWith (flip (<>)) x y)
  74 instance (Ord unit, Semigroup qty) => Monoid (Amounts unit qty) where
  75   mempty = Amounts Map.empty
  76 instance Negable qty => Negable (Amounts unit qty) where
  77   negate (Amounts x) = Amounts (negate <$> x)
  78
  79 -- * Type 'AmountStyle'
  80 data AmountStyle = AmountStyle
  81   {  amountStyleFractioning :: Char
  82   ,  amountStyleGroupingIntegral :: (Char, [Int])
  83   ,  amountStyleGroupingFractional :: (Char, [Int])
  84   ,  amountStyleUnitSideLeft :: Bool
  85   ,  amountStyleUnitSpaced :: Bool
  86   -- TODO: , amountStyleSignPlus :: Bool
  87   } deriving (Eq, Show, Generic, NFData)
  88
  89 -- ** Type 'AmountStylePrecision'
  90 --type AmountStylePrecision = Natural
  91 {-
  92 amountStyles :: Map.Map Unit AmountStyle
  93 amountStyles = Map.fromList
  94   [ (scalarUnit, AmountStyle
  95      { amountStyleFractioning = '.'
  96      , amountStyleGroupingFractional = (',', [3])
  97      , amountStyleGroupingIntegral = (',', [3])
  98      , amountStyleUnitSideLeft = False
  99      , amountStyleUnitSpaced = False
 100      })
 101   , (chfUnit, AmountStyle
 102      { amountStyleFractioning = ','
 103      , amountStyleGroupingFractional = ('.', [3])
 104      , amountStyleGroupingIntegral = ('.', [3])
 105      , amountStyleUnitSideLeft = False
 106      , amountStyleUnitSpaced = False
 107      })
 108   , (cnyUnit, AmountStyle
 109      { amountStyleFractioning = ','
 110      , amountStyleGroupingFractional = ('.', [3])
 111      , amountStyleGroupingIntegral = ('.', [3])
 112      , amountStyleUnitSideLeft = False
 113      , amountStyleUnitSpaced = False
 114      })
 115   , (eurUnit, AmountStyle
 116      { amountStyleFractioning = ','
 117      , amountStyleGroupingFractional = ('.', [3])
 118      , amountStyleGroupingIntegral = ('.', [3])
 119      , amountStyleUnitSideLeft = False
 120      , amountStyleUnitSpaced = False
 121      })
 122   , (gbpUnit, AmountStyle
 123      { amountStyleFractioning = '.'
 124      , amountStyleGroupingFractional = (',', [3])
 125      , amountStyleGroupingIntegral = (',', [3])
 126      , amountStyleUnitSideLeft = True
 127      , amountStyleUnitSpaced = False
 128      })
 129   , (inrUnit, AmountStyle
 130      { amountStyleFractioning = ','
 131      , amountStyleGroupingFractional = ('.', [3])
 132      , amountStyleGroupingIntegral = ('.', [3])
 133      , amountStyleUnitSideLeft = False
 134      , amountStyleUnitSpaced = False
 135      })
 136   , (jpyUnit, AmountStyle
 137      { amountStyleFractioning = '.'
 138      , amountStyleGroupingFractional = (',', [3])
 139      , amountStyleGroupingIntegral = (',', [3])
 140      , amountStyleUnitSideLeft = True
 141      , amountStyleUnitSpaced = False
 142      })
 143   , (rubUnit, AmountStyle
 144      { amountStyleFractioning = '.'
 145      , amountStyleGroupingFractional = (',', [3])
 146      , amountStyleGroupingIntegral = (',', [3])
 147      , amountStyleUnitSideLeft = True
 148      , amountStyleUnitSpaced = False
 149      })
 150   , (usdUnit, AmountStyle
 151      { amountStyleFractioning = '.'
 152      , amountStyleGroupingFractional = (',', [3])
 153      , amountStyleGroupingIntegral = (',', [3])
 154      , amountStyleUnitSideLeft = True
 155      , amountStyleUnitSpaced = False
 156      })
 157   ]
 158 -}
 159
 160 scalarUnit :: Unit
 161 scalarUnit = Unit ""
 162
 163 -- | <https://en.wikipedia.org/wiki/Swiss_franc Swiss franc> unit of currency.
 164 chfUnit :: Unit
 165 chfUnit = Unit "CHF"
 166
 167 -- | <https://en.wikipedia.org/wiki/Yuan Yuan> unit of currency.
 168 cnyUnit :: Unit
 169 cnyUnit = Unit "Ұ"
 170
 171 -- | <https://en.wikipedia.org/wiki/Euro Euro> unit of currency.
 172 eurUnit :: Unit
 173 eurUnit = Unit "€"
 174
 175 -- | <https://en.wikipedia.org/wiki/Pound_sterling Pound sterling> unit of currency.
 176 gbpUnit :: Unit
 177 gbpUnit = Unit "£"
 178
 179 -- | <https://en.wikipedia.org/wiki/Indian_rupee Indian rupee> unit of currency.
 180 inrUnit :: Unit
 181 inrUnit = Unit "₹"
 182
 183 -- | <https://en.wikipedia.org/wiki/Japanese_yen Japanese yen> unit of currency.
 184 jpyUnit :: Unit
 185 jpyUnit = Unit "¥"
 186
 187 -- | <https://en.wikipedia.org/wiki/Russian_ruble Russian ruble> unit of currency.
 188 rubUnit :: Unit
 189 rubUnit = Unit "₽"
 190
 191 -- | <https://en.wikipedia.org/wiki/United_States_dollar United States dollar> unit of currency.
 192 usdUnit :: Unit
 193 usdUnit = Unit "$"
 194
 195
 196
 197 {-
 198 import Control.DeepSeq
 199 import Data.Bool
 200 import Data.Char (Char)
 201 import Data.Data
 202 import Data.Decimal (Decimal, roundTo)
 203 import Data.Eq (Eq(..))
 204 import Data.Function (($), (.), const, flip)
 205 import Data.Map.Strict (Map)
 206 import Data.Monoid (Monoid(..))
 207 import Data.Ord (Ord(..))
 208 import Data.Semigroup (Semigroup(..))
 209 import Data.Strict.Maybe
 210 import Data.String (IsString)
 211 import Data.Text (Text)
 212 import Data.Typeable ()
 213 import Data.Word (Word8)
 214 import Prelude (Int, seq)
 215 import Text.Show (Show(..))
 216 import qualified Data.Map.Strict as Map
 217 import qualified Data.MonoTraversable as MT
 218 import qualified Data.Strict as S
 219 import qualified Data.Text as T
 220
 221 import qualified Hcompta as H
 222
 223 -- * Type 'Amount'
 224 data Amount
 225  =   Amount
 226  {   amount_unit     :: !Unit
 227  ,   amount_quantity :: !Quantity
 228  } deriving (Data, Eq, Ord, Show, Typeable)
 229
 230 -- type instance H.UnitFor     Amount = Unit
 231 -- type instance H.QuantityFor Amount = H.Polarized Quantity
 232
 233 instance NFData Amount where
 234   rnf (Amount q u) = rnf q `seq` rnf u
 235 -- instance H.Amount Amount
 236
 237 {-
 238 type instance H.Unit H.:@ Amount = Unit
 239 instance H.GetI H.Unit Amount where
 240   getI = amount_unit
 241 instance H.SetI H.Unit Amount where
 242   setI amount_unit a = a{amount_unit}
 243
 244 type instance H.Quantity H.:@ Amount = Quantity
 245 instance H.GetI H.Quantity Amount where
 246   getI = amount_quantity
 247 instance H.SetI H.Quantity Amount where
 248   setI amount_quantity a = a{amount_quantity}
 249 -}
 250
 251 instance H.Zeroable Amount where
 252   zero = Amount "" H.zero
 253 instance H.Nullable Amount where
 254   null = H.null . amount_quantity
 255    -- NOTE: the 'Amount'’s 'amount_quantity' MUST already be rounded
 256    --       at 'Amount'’s 'amount_style'’s 'style_amount_precision'.
 257 instance H.Signable Amount where
 258   sign = H.sign . amount_quantity
 259
 260 amount :: Amount
 261 amount =
 262   Amount
 263    { amount_unit     = ""
 264    , amount_quantity = H.zero
 265    }
 266
 267 amount_style :: Style_Amounts -> Amount -> Style_Amount
 268 amount_style styles = style_amount_find styles . amount_unit
 269
 270 -- * Type 'Quantity'
 271 type Quantity = Decimal
 272
 273 quantity_round :: Word8 -> Quantity -> Quantity
 274 quantity_round = Data.Decimal.roundTo
 275
 276 -- * Type 'Unit'
 277 newtype Unit
 278  = Unit Text
 279  deriving (Data, Eq, IsString, Ord, Show, Typeable)
 280 instance H.Zeroable Unit where
 281   zero = Unit ""
 282 instance H.Nullable Unit where
 283   null (Unit x) = T.null x
 284 {-
 285 instance H.Unit Unit where
 286   noUnit = Unit ""
 287   textUnit (Unit t) = t
 288 -}
 289 instance NFData Unit where
 290   rnf (Unit t) = rnf t
 291
 292 -- ** Example 'Unit's
 293
 294
 295 -- * Type 'Style_Amount'
 296 data Style_Amount
 297  =   Style_Amount
 298  {   amountStyleFractioning         :: !(S.Maybe Style_Amount_Fractioning)
 299  ,   amountStyleGroupingIntegral   :: !(S.Maybe AmountStyleGrouping)
 300  ,   amountStyleGroupingFractional :: !(S.Maybe AmountStyleGrouping)
 301  ,   amountStyleUnitSideLeft           :: !(S.Maybe LR)
 302  ,   amountStyleUnitSpaced         :: !(S.Maybe Style_Amount_Spacing)
 303  -- TODO: , style_amount_sign_plus     :: S.Maybe Bool
 304  } deriving (Data, Eq, Ord, Show, Typeable)
 305 instance NFData Style_Amount where
 306   rnf (Style_Amount f gi gf ui up) =
 307     rnf f  `seq`
 308     rnf gi `seq`
 309     rnf gf `seq`
 310     rnf ui `seq`
 311     rnf up
 312 instance Semigroup Style_Amount where
 313   (<>) = style_amount_union
 314 instance Monoid Style_Amount where
 315   mempty  = style_amount
 316   mappend = (<>)
 317
 318 style_amount :: Style_Amount
 319 style_amount =
 320   Style_Amount
 321    { amountStyleFractioning         = Nothing
 322    , amountStyleGroupingIntegral   = Nothing
 323    , amountStyleGroupingFractional = Nothing
 324    , amountStyleUnitSideLeft           = Nothing
 325    , amountStyleUnitSpaced         = Nothing
 326    }
 327
 328 style_amount_union
 329  :: Style_Amount
 330  -> Style_Amount
 331  -> Style_Amount
 332 style_amount_union
 333  sty@Style_Amount
 334  { amountStyleFractioning=f
 335  , amountStyleGroupingIntegral=gi
 336  , amountStyleGroupingFractional=gf
 337  , amountStyleUnitSideLeft=side
 338  , amountStyleUnitSpaced=spaced
 339  }
 340  sty'@Style_Amount
 341  { amountStyleFractioning=f'
 342  , amountStyleGroupingIntegral=gi'
 343  , amountStyleGroupingFractional=gf'
 344  , amountStyleUnitSideLeft=side'
 345  , amountStyleUnitSpaced=spaced'
 346  } =
 347   if sty == sty'
 348   then sty'
 349   else
 350     Style_Amount
 351      { amountStyleFractioning        = S.maybe f'      (const f)      f
 352      , amountStyleGroupingIntegral   = S.maybe gi'     (const gi)     gi
 353      , amountStyleGroupingFractional = S.maybe gf'     (const gf)     gf
 354      , amountStyleUnitSideLeft       = S.maybe side'   (const side)   side
 355      , amountStyleUnitSpaced         = S.maybe spaced' (const spaced) spaced
 356      }
 357
 358 -- ** Type 'Style_Amount_Fractioning'
 359 type Style_Amount_Fractioning
 360  = Char
 361
 362 -- ** Type 'AmountStyleGrouping'
 363 data AmountStyleGrouping
 364  =   AmountStyleGrouping Char [Int]
 365  deriving (Data, Eq, Ord, Show, Typeable)
 366 instance NFData AmountStyleGrouping where
 367   rnf (AmountStyleGrouping s d) = rnf s `seq` rnf d
 368
 369 -- ** Type 'Style_Amount_Precision'
 370 type Style_Amount_Precision
 371  = Word8
 372
 373 -- ** Type 'Style_Amount_Spacing'
 374 type Style_Amount_Spacing
 375  = Bool
 376
 377 -- ** Type 'LR'
 378 data LR = L | R
 379  deriving (Data, Eq, Ord, Show, Typeable)
 380 instance NFData LR where
 381   rnf L = ()
 382   rnf R = ()
 383
 384 -- ** Type 'Style_Amounts'
 385 newtype Style_Amounts
 386  =      Style_Amounts (Map Unit Style_Amount)
 387  deriving (Data, Eq, NFData, Ord, Show, Typeable)
 388
 389 -- type instance H.UnitFor     Amounts = Unit
 390 -- type instance H.QuantityFor Amounts = Quantity
 391
 392 instance Semigroup Style_Amounts where
 393   Style_Amounts x <> Style_Amounts y =
 394     Style_Amounts (Map.unionWith (flip (<>)) x y)
 395 instance Monoid Style_Amounts where
 396   mempty  = Style_Amounts mempty
 397   mappend = (<>)
 398 instance H.Zeroable Style_Amounts where
 399   zero = Style_Amounts mempty
 400 instance H.Sumable Style_Amounts (Unit, Style_Amount) where
 401   Style_Amounts ss += (u, s) = Style_Amounts $ Map.insertWith (flip (<>)) u s ss
 402
 403 unStyle_Amounts :: Style_Amounts -> Map Unit Style_Amount
 404 unStyle_Amounts (Style_Amounts fp) = fp
 405
 406 style_amount_find :: Style_Amounts -> Unit -> Style_Amount
 407 style_amount_find (Style_Amounts s) u = Map.findWithDefault mempty u s
 408
 409 -- *** Example 'Style_Amounts'
 410 amountStyles :: Style_Amounts
 411
 412 -- ** Type 'Styled_Amount'
 413 type Styled_Amount t = (Style_Amount, t)
 414
 415 styled_amount :: Style_Amounts -> Amount -> Styled_Amount Amount
 416 styled_amount styles amt = (amount_style styles amt, amt)
 417
 418 -- * Type 'Amounts'
 419 newtype Amounts = Amounts (Map Unit Quantity)
 420  deriving (Data, Eq, NFData, Ord, Show, Typeable
 421  , H.Addable, H.Negable, H.Subable)
 422 unAmounts :: Amounts -> Map Unit Quantity
 423 unAmounts (Amounts a) = a
 424
 425 type instance MT.Element Amounts = Amount
 426 -- instance H.Amounts Amounts
 427
 428 -- instance H.Get (H.Balance_Amounts Unit Quantity) Amounts where
 429 --   get (Amounts a) = a
 430 -}