src/Literate/Accounting/Unit.hs

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