diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,10 +2,57 @@ ## [Unreleased] + +## [0.0.0.7] - 2022-11-17 +### Chore +- bump development version to 0.0.0.7 +- **dev:** document pre-release checks + +### Docs +- add missing Haddock documentation for function + +### Test +- fix tests for updated Balance data definition + +### Pull Requests +- Merge pull request [#14](https://github.com/telostat/haspara/issues/14) from telostat/vst/test-and-doc-fixes + + + +## [0.0.0.6] - 2022-11-17 +### Chore +- drop Stack usage +- bump development version to 0.0.0.6 +- remove stylish-haskell configuration +- **deps:** park library dependencies under library section +- **docs:** update development and release procedure in README +- **nix:** use telos.nix +- **release:** 0.0.0.6 +- **test:** get ready for hspec-based testing + +### Feat +- integrate inventory accounting into posting +- add division operations for `Quantity` type + +### Fix +- **test:** revisit doctests, adopt 9.x TH changes + +### Refactor +- start working on inventory machinery +- reorder language pragmas +- drop Haskell 2021 Extensions in favour of explicit pragmas +- reformat codebase using fourmolu + +### Pull Requests +- Merge pull request [#13](https://github.com/telostat/haspara/issues/13) from telostat/vst/pnl-capture +- Merge pull request [#12](https://github.com/telostat/haspara/issues/12) from telostat/develop + + ## [0.0.0.5] - 2022-06-23 ### Chore - bump development version to 0.0.0.5 +- **release:** 0.0.0.5 ### Feat - **accounting:** add Aeson instances to Haspara.Accounting.Journal module @@ -119,7 +166,9 @@ - Merge pull request [#1](https://github.com/telostat/haspara/issues/1) from telostat/init -[Unreleased]: https://github.com/telostat/haspara/compare/0.0.0.5...HEAD +[Unreleased]: https://github.com/telostat/haspara/compare/0.0.0.7...HEAD +[0.0.0.7]: https://github.com/telostat/haspara/compare/0.0.0.6...0.0.0.7 +[0.0.0.6]: https://github.com/telostat/haspara/compare/0.0.0.5...0.0.0.6 [0.0.0.5]: https://github.com/telostat/haspara/compare/0.0.0.4...0.0.0.5 [0.0.0.4]: https://github.com/telostat/haspara/compare/0.0.0.3...0.0.0.4 [0.0.0.3]: https://github.com/telostat/haspara/compare/0.0.0.2...0.0.0.3 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -18,15 +18,15 @@ Before committing code to repository, reformat the code: ```sh -stylish-haskell -i -r src/ +fourmolu -i src/ test/ ``` Compile the codebase, check warnings and errors: ```sh -stack test -stack build -stack haddock +cabal build -O0 +cabal test -O0 +cabal haddock -O0 ``` Run [hlint](https://github.com/ndmitchell/hlint): @@ -43,45 +43,37 @@ ## Making Releases -1. Switch to `develop` branch: - - ```sh - git checkout develop - ``` - -1. Ensure that your development branch is up to date: - - ```sh - git pull - ``` - 1. Checkout `main` branch: ```sh git checkout main ``` -1. Merge `develop` branch to `main`: +2. Ensure that your branch is up to date: ```sh - git merge --no-ff develop + git pull ``` -1. Update the `version` information in [package.yaml](./package.yaml) if - required and recompile the project to reflect the change on the `.cabal` - file: +3. Update the `version` information in [package.yaml](./package.yaml) if + required, run `hpack` to reflect the change on the `.cabal` file, and + recompile the project, run tests and generate Haddock documentation: ```sh - stack build + hpack + cabal clean + cabal build -O0 + cabal test -O0 + cabal haddock -O0 ``` -1. Update [CHANGELOG.md](./CHANGELOG.md) file: +4. Update [CHANGELOG.md](./CHANGELOG.md) file: ```sh git-chglog --next-tag -o CHANGELOG.md ``` -1. Commit, tag and push: +5. Commit, tag and push: ```sh git commit -am "chore(release): " @@ -89,38 +81,21 @@ git push --follow-tags origin main ``` -1. Release to Hackage as a candidate first and check the result: - - ```sh - stack upload --candidate . - ``` - -1. If the candidate package release works fine, release to Hackage: - - ```sh - stack upload . - ``` - -1. Checkout to `develop` and rebase onto `main`: +6. Create the package, upload to Hackage as a candidate first and check the result: ```sh - git checkout develop - git rebase main + cabal clean + cabal build -O0 + cabal test -O0 + cabal haddock -O0 + cabal sdist + cabal upload ``` -1. Update the `version` information in [package.yaml](./package.yaml) with the - upcoming version and recompile the project to reflect the change on the - `.cabal` file: - - ```sh - stack build - ``` - -1. Commit and push: +7. If the candidate package release works fine, release to Hackage: ```sh - git commit -am "chore: bump development version to " - git push + cabal upload --publish ``` ## License diff --git a/doctest.hs b/doctest.hs new file mode 100644 --- /dev/null +++ b/doctest.hs @@ -0,0 +1,7 @@ +import Test.DocTest (doctest) + + +main :: IO () +main = + doctest + ["-isrc" , "src"] diff --git a/haspara.cabal b/haspara.cabal --- a/haspara.cabal +++ b/haspara.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: haspara -version: 0.0.0.5 +version: 0.0.0.7 synopsis: A library providing definitions to work with monetary values. description: Please see the README on GitHub at category: Finance @@ -32,6 +32,7 @@ Haspara.Accounting.Account Haspara.Accounting.Amount Haspara.Accounting.Balance + Haspara.Accounting.Inventory Haspara.Accounting.Journal Haspara.Accounting.Ledger Haspara.Accounting.Side @@ -46,49 +47,12 @@ Paths_haspara hs-source-dirs: src - default-extensions: - BangPatterns - BinaryLiterals - ConstrainedClassMethods - ConstraintKinds - DeriveDataTypeable - DeriveFoldable - DeriveFunctor - DeriveGeneric - DeriveLift - DeriveTraversable - EmptyCase - EmptyDataDeriving - ExistentialQuantification - ExplicitForAll - FlexibleContexts - FlexibleInstances - GADTSyntax - GeneralisedNewtypeDeriving - HexFloatLiterals - ImportQualifiedPost - InstanceSigs - KindSignatures - MultiParamTypeClasses - NamedFieldPuns - NamedWildCards - NumericUnderscores - PolyKinds - PostfixOperators - RankNTypes - ScopedTypeVariables - StandaloneDeriving - StandaloneKindSignatures - TupleSections - TypeApplications - TypeOperators - TypeSynonymInstances - OverloadedStrings ghc-options: -Wall -Wunused-packages build-depends: aeson >=1.5.6.0 && <2.1 , base >=4.11 && <5 , containers >=0.6.4.1 && <0.7 + , data-default ==0.7.* , exceptions >=0.10.4 && <0.11 , hashable >=1.3.0.0 && <1.4 , megaparsec >=9.0.1 && <9.3 @@ -107,22 +71,27 @@ other-modules: Paths_haspara hs-source-dirs: - test + ./ ghc-options: -threaded build-depends: - aeson >=1.5.6.0 && <2.1 - , base >=4.11 && <5 - , containers >=0.6.4.1 && <0.7 + base >=4.11 && <5 , doctest - , exceptions >=0.10.4 && <0.11 - , hashable >=1.3.0.0 && <1.4 + default-language: Haskell2010 + +test-suite haspara-test + type: exitcode-stdio-1.0 + main-is: test.hs + other-modules: + Tests.Haspara.Accounting.Inventory + Paths_haspara + hs-source-dirs: + test + ghc-options: -Wall -Wunused-packages -threaded + build-depends: + base >=4.11 && <5 + , containers + , data-default , haspara - , megaparsec >=9.0.1 && <9.3 - , mtl >=2.2.2 && <2.3 - , refined >=0.6.3 && <0.7 - , safe-decimal >=0.2.1.0 && <0.3 - , scientific >=0.3.7.0 && <0.4 - , template-haskell >=2.16.0.0 && <2.18 - , text >=1.2.4.1 && <1.3 - , time >=1.9.3 && <1.10 + , hspec + , time default-language: Haskell2010 diff --git a/src/Haspara.hs b/src/Haspara.hs --- a/src/Haspara.hs +++ b/src/Haspara.hs @@ -2,15 +2,15 @@ -- -- @haspara@ provides rudimentary (and experimental) accounting functionality, -- too. These definitions can be found under "Haspara.Accounting" module. - -module Haspara - ( module Haspara.Currency - , module Haspara.FxQuote - , module Haspara.Monetary - , module Haspara.Quantity - ) where +module Haspara ( + module Haspara.Currency, + module Haspara.FxQuote, + module Haspara.Monetary, + module Haspara.Quantity, +) where import Haspara.Currency import Haspara.FxQuote import Haspara.Monetary import Haspara.Quantity + diff --git a/src/Haspara/Accounting.hs b/src/Haspara/Accounting.hs --- a/src/Haspara/Accounting.hs +++ b/src/Haspara/Accounting.hs @@ -1,15 +1,14 @@ -- | This module provides a collection of definitions for a rudimentary -- accounting functionality. - -module Haspara.Accounting - ( module Haspara.Accounting.Account - , module Haspara.Accounting.Amount - , module Haspara.Accounting.Balance - , module Haspara.Accounting.Journal - , module Haspara.Accounting.Ledger - , module Haspara.Accounting.Side - , module Haspara.Accounting.TrialBalance - ) where +module Haspara.Accounting ( + module Haspara.Accounting.Account, + module Haspara.Accounting.Amount, + module Haspara.Accounting.Balance, + module Haspara.Accounting.Journal, + module Haspara.Accounting.Ledger, + module Haspara.Accounting.Side, + module Haspara.Accounting.TrialBalance, +) where import Haspara.Accounting.Account import Haspara.Accounting.Amount @@ -18,3 +17,4 @@ import Haspara.Accounting.Ledger import Haspara.Accounting.Side import Haspara.Accounting.TrialBalance + diff --git a/src/Haspara/Accounting/Account.hs b/src/Haspara/Accounting/Account.hs --- a/src/Haspara/Accounting/Account.hs +++ b/src/Haspara/Accounting/Account.hs @@ -1,20 +1,19 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + -- | This module provides definitions for acccounts and types of accounts as -- they are used in accounting reporting. - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} - module Haspara.Accounting.Account where -import qualified Data.Aeson as Aeson -import Data.Hashable (Hashable) -import qualified Data.Text as T -import GHC.Generics (Generic) -import Haspara.Internal.Aeson (aesonOptionsForSingleTag, commonAesonOptions) +import qualified Data.Aeson as Aeson +import Data.Hashable (Hashable) +import qualified Data.Text as T +import GHC.Generics (Generic) +import Haspara.Internal.Aeson (aesonOptionsForSingleTag, commonAesonOptions) -- * Account Kind --- $accountKind -- | Type encoding for ledger account type. @@ -31,6 +30,7 @@ -- -- 'Data.Aeson.FromJSON' and 'Data.Aeson.ToJSON' instances, too: -- +-- >>> :set -XTypeApplications -- >>> Data.Aeson.decode @AccountKind "\"ASSET\"" -- Just AccountKindAsset -- >>> Data.Aeson.decode @AccountKind "\"LIABILITY\"" @@ -51,8 +51,8 @@ -- "\"REVENUE\"" -- >>> Data.Aeson.encode AccountKindExpense -- "\"EXPENSE\"" -data AccountKind = - AccountKindAsset +data AccountKind + = AccountKindAsset | AccountKindLiability | AccountKindEquity | AccountKindRevenue @@ -84,15 +84,14 @@ -- >>> accountKindText AccountKindExpense -- "Expense" accountKindText :: AccountKind -> T.Text -accountKindText AccountKindAsset = "Asset" +accountKindText AccountKindAsset = "Asset" accountKindText AccountKindLiability = "Liability" -accountKindText AccountKindEquity = "Equity" -accountKindText AccountKindRevenue = "Revenue" -accountKindText AccountKindExpense = "Expense" +accountKindText AccountKindEquity = "Equity" +accountKindText AccountKindRevenue = "Revenue" +accountKindText AccountKindExpense = "Expense" -- * Account --- $account -- | Type encoding for account values. @@ -102,6 +101,7 @@ -- use-site to use its own account identity and accompanying information when -- required. -- +-- >>> :set -XTypeApplications -- >>> let acc = Account AccountKindAsset (1 ::Int) -- >>> Data.Aeson.encode acc -- "{\"kind\":\"ASSET\",\"object\":1}" @@ -110,7 +110,7 @@ -- >>> Data.Aeson.decode (Data.Aeson.encode acc) == Just acc -- True data Account o = Account - { accountKind :: !AccountKind + { accountKind :: !AccountKind , accountObject :: !o } deriving (Eq, Generic, Ord, Show) diff --git a/src/Haspara/Accounting/Amount.hs b/src/Haspara/Accounting/Amount.hs --- a/src/Haspara/Accounting/Amount.hs +++ b/src/Haspara/Accounting/Amount.hs @@ -1,25 +1,26 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} + -- | This module provides definitions for amounts used as in accounting. -- -- For balance definition that allows "Negative Balance" phenomenon, see -- 'Haspara.Accounting.Balance'. - -{-# LANGUAGE DataKinds #-} - module Haspara.Accounting.Amount where -import qualified Data.Aeson as Aeson -import GHC.Generics (Generic) -import GHC.TypeLits (KnownNat, Nat) -import Haspara.Accounting.Account (AccountKind(..)) -import Haspara.Accounting.Side (Side(..), sideByAccountKind) -import Haspara.Internal.Aeson (commonAesonOptions) -import Haspara.Quantity (Quantity, UnsignedQuantity, absQuantity) -import Refined (unrefine) +import qualified Data.Aeson as Aeson +import GHC.Generics (Generic) +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Accounting.Account (AccountKind (..)) +import Haspara.Accounting.Side (Side (..), sideByAccountKind) +import Haspara.Internal.Aeson (commonAesonOptions) +import Haspara.Quantity (Quantity, UnsignedQuantity, absQuantity) +import Refined (unrefine) -- | Data definition for amounts. data Amount (precision :: Nat) = Amount - { amountSide :: !Side + { amountSide :: !Side , amountValue :: !(UnsignedQuantity precision) } deriving (Eq, Generic, Ord, Show) @@ -27,6 +28,8 @@ -- | 'Aeson.FromJSON' instance for 'Amount'. -- +-- >>> :set -XDataKinds +-- >>> :set -XOverloadedStrings -- >>> Aeson.eitherDecode "{\"side\": \"db\", \"value\": 42}" :: Either String (Amount 2) -- Right (Amount {amountSide = SideDebit, amountValue = Refined 42.00}) -- >>> Aeson.eitherDecode "{\"side\": \"cr\", \"value\": 42}" :: Either String (Amount 2) @@ -37,6 +40,7 @@ -- | 'Aeson.ToJSON' instance for 'Amount'. -- +-- >>> :set -XDataKinds -- >>> import Haspara.Accounting.Side -- >>> import Haspara.Quantity -- >>> import Refined.Unsafe @@ -55,13 +59,13 @@ -- | Returns the debit value of the 'Amount', if any. amountDebit :: KnownNat precision => Amount precision -> Maybe (UnsignedQuantity precision) amountDebit (Amount SideDebit value) = Just value -amountDebit _ = Nothing +amountDebit _ = Nothing -- | Returns the credit value of the 'Amount', if any. amountCredit :: KnownNat precision => Amount precision -> Maybe (UnsignedQuantity precision) amountCredit (Amount SideCredit value) = Just value -amountCredit _ = Nothing +amountCredit _ = Nothing -- | Builds the 'Amount' for the given /value/ for the given 'AccountKind'. @@ -88,6 +92,7 @@ -- -- Conventionally, the latter is reflected as follow: -- +-- >>> :set -XDataKinds -- >>> import Haspara.Quantity -- >>> amountFromQuantity AccountKindLiability (mkQuantity 1000 :: Quantity 2) -- Amount {amountSide = SideCredit, amountValue = Refined 1000.00} @@ -145,11 +150,11 @@ -> Quantity precision -> Amount precision amountFromValue k q = case k of - AccountKindAsset -> Amount { amountSide = if q >= 0 then SideDebit else SideCredit, amountValue = absQuantity q } - AccountKindLiability -> Amount { amountSide = if q >= 0 then SideDebit else SideCredit, amountValue = absQuantity q } - AccountKindEquity -> Amount { amountSide = if q >= 0 then SideCredit else SideDebit, amountValue = absQuantity q } - AccountKindRevenue -> Amount { amountSide = if q >= 0 then SideCredit else SideDebit, amountValue = absQuantity q } - AccountKindExpense -> Amount { amountSide = if q >= 0 then SideCredit else SideDebit, amountValue = absQuantity q } + AccountKindAsset -> Amount {amountSide = if q >= 0 then SideDebit else SideCredit, amountValue = absQuantity q} + AccountKindLiability -> Amount {amountSide = if q >= 0 then SideDebit else SideCredit, amountValue = absQuantity q} + AccountKindEquity -> Amount {amountSide = if q >= 0 then SideCredit else SideDebit, amountValue = absQuantity q} + AccountKindRevenue -> Amount {amountSide = if q >= 0 then SideCredit else SideDebit, amountValue = absQuantity q} + AccountKindExpense -> Amount {amountSide = if q >= 0 then SideCredit else SideDebit, amountValue = absQuantity q} -- | Returns the value for the given 'Amount' for the given 'AccountKind'. @@ -159,6 +164,7 @@ -- For values of positive and negative net-effect on the net-worth of the -- entity, respectively: -- +-- >>> :set -XDataKinds -- >>> import Haspara.Quantity -- >>> let valPos = mkQuantity 42 :: Quantity 2 -- >>> let valNeg = mkQuantity (-42) :: Quantity 2 @@ -184,16 +190,16 @@ -> Amount precision -> Quantity precision valueFromAmount k (Amount s v) = case (k, s, unrefine v) of - (AccountKindAsset, SideDebit, q) -> q - (AccountKindAsset, SideCredit, q) -> -q - (AccountKindLiability, SideDebit, q) -> q + (AccountKindAsset, SideDebit, q) -> q + (AccountKindAsset, SideCredit, q) -> -q + (AccountKindLiability, SideDebit, q) -> q (AccountKindLiability, SideCredit, q) -> -q - (AccountKindEquity, SideDebit, q) -> -q - (AccountKindEquity, SideCredit, q) -> q - (AccountKindRevenue, SideDebit, q) -> -q - (AccountKindRevenue, SideCredit, q) -> q - (AccountKindExpense, SideDebit, q) -> -q - (AccountKindExpense, SideCredit, q) -> q + (AccountKindEquity, SideDebit, q) -> -q + (AccountKindEquity, SideCredit, q) -> q + (AccountKindRevenue, SideDebit, q) -> -q + (AccountKindRevenue, SideCredit, q) -> q + (AccountKindExpense, SideDebit, q) -> -q + (AccountKindExpense, SideCredit, q) -> q -- | Builds the 'Amount' value for the given account kind and quantity. @@ -204,6 +210,7 @@ -- For example, a loan of USD 1,000 has an increase in our liabilities. -- Therefore, the quantity is expected to be positive: -- +-- >>> :set -XDataKinds -- >>> import Haspara.Quantity -- >>> amountFromQuantity AccountKindLiability (mkQuantity 1000 :: Quantity 2) -- Amount {amountSide = SideCredit, amountValue = Refined 1000.00} @@ -239,17 +246,15 @@ -> Amount precision -> Quantity precision quantityFromAmount k (Amount side absValue) = - let - value = unrefine absValue - in - case (k, side) of - (AccountKindAsset, SideDebit) -> value - (AccountKindAsset, SideCredit) -> -value - (AccountKindLiability, SideDebit) -> -value - (AccountKindLiability, SideCredit) -> value - (AccountKindEquity, SideDebit) -> -value - (AccountKindEquity, SideCredit) -> value - (AccountKindRevenue, SideDebit) -> -value - (AccountKindRevenue, SideCredit) -> value - (AccountKindExpense, SideDebit) -> value - (AccountKindExpense, SideCredit) -> -value + let value = unrefine absValue + in case (k, side) of + (AccountKindAsset, SideDebit) -> value + (AccountKindAsset, SideCredit) -> -value + (AccountKindLiability, SideDebit) -> -value + (AccountKindLiability, SideCredit) -> value + (AccountKindEquity, SideDebit) -> -value + (AccountKindEquity, SideCredit) -> value + (AccountKindRevenue, SideDebit) -> -value + (AccountKindRevenue, SideCredit) -> value + (AccountKindExpense, SideDebit) -> value + (AccountKindExpense, SideCredit) -> -value diff --git a/src/Haspara/Accounting/Balance.hs b/src/Haspara/Accounting/Balance.hs --- a/src/Haspara/Accounting/Balance.hs +++ b/src/Haspara/Accounting/Balance.hs @@ -1,18 +1,22 @@ --- | This module provides definitions for balances used as in accounting. - {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +-- | This module provides definitions for balances used as in accounting. module Haspara.Accounting.Balance where -import qualified Data.Aeson as Aeson -import GHC.Generics (Generic) -import GHC.TypeLits (KnownNat, Nat) -import Haspara.Accounting.Account (AccountKind) -import Haspara.Accounting.Amount (Amount(Amount), quantityFromAmount, valueFromAmount) -import Haspara.Accounting.Side (Side(..), otherSide) -import Haspara.Internal.Aeson (commonAesonOptions) -import Haspara.Quantity (Quantity, absQuantity) -import Refined (unrefine) +import qualified Data.Aeson as Aeson +import qualified Data.Foldable as Foldable +import Data.Time (Day) +import GHC.Generics (Generic) +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Accounting.Account (AccountKind (AccountKindAsset)) +import Haspara.Accounting.Amount (Amount (Amount), quantityFromAmount, valueFromAmount) +import Haspara.Accounting.Inventory (Inventory, InventoryHistoryItem, updateInventoryVV) +import Haspara.Accounting.Side (Side (..), otherSide) +import Haspara.Internal.Aeson (commonAesonOptions) +import Haspara.Quantity (Quantity, absQuantity) +import Refined (unrefine) -- | Data definition for balances. @@ -22,8 +26,9 @@ -- -- See https://www.accountingtools.com/articles/what-is-a-negative-balance.html data Balance (precision :: Nat) = Balance - { balanceSide :: !Side + { balanceSide :: !Side , balanceValue :: !(Quantity precision) + , balanceInventory :: !(Inventory 8 12 precision) } deriving (Eq, Generic, Show) @@ -32,17 +37,19 @@ -- -- For normal balances: -- --- >>> Aeson.eitherDecode "{\"side\": \"db\", \"value\": 42}" :: Either String (Balance 2) --- Right (Balance {balanceSide = SideDebit, balanceValue = 42.00}) --- >>> Aeson.eitherDecode "{\"side\": \"cr\", \"value\": 42}" :: Either String (Balance 2) --- Right (Balance {balanceSide = SideCredit, balanceValue = 42.00}) +-- >>> :set -XDataKinds +-- >>> :set -XOverloadedStrings +-- >>> Aeson.eitherDecode "{\"side\": \"db\", \"value\": 42, \"inventory\": {\"current\": [], \"history\": [], \"total\": 0.0}}" :: Either String (Balance 2) +-- Right (Balance {balanceSide = SideDebit, balanceValue = 42.00, balanceInventory = MkInventory {inventoryTotal = 0.000000000000, inventoryCurrent = fromList [], inventoryHistory = fromList []}}) +-- >>> Aeson.eitherDecode "{\"side\": \"cr\", \"value\": 42, \"inventory\": {\"current\": [], \"history\": [], \"total\": 0.0}}" :: Either String (Balance 2) +-- Right (Balance {balanceSide = SideCredit, balanceValue = 42.00, balanceInventory = MkInventory {inventoryTotal = 0.000000000000, inventoryCurrent = fromList [], inventoryHistory = fromList []}}) -- -- For negative balances: -- --- >>> Aeson.eitherDecode "{\"side\": \"db\", \"value\": -42}" :: Either String (Balance 2) --- Right (Balance {balanceSide = SideDebit, balanceValue = -42.00}) --- >>> Aeson.eitherDecode "{\"side\": \"cr\", \"value\": -42}" :: Either String (Balance 2) --- Right (Balance {balanceSide = SideCredit, balanceValue = -42.00}) +-- >>> Aeson.eitherDecode "{\"side\": \"db\", \"value\": -42, \"inventory\": {\"current\": [], \"history\": [], \"total\": 0.0}}" :: Either String (Balance 2) +-- Right (Balance {balanceSide = SideDebit, balanceValue = -42.00, balanceInventory = MkInventory {inventoryTotal = 0.000000000000, inventoryCurrent = fromList [], inventoryHistory = fromList []}}) +-- >>> Aeson.eitherDecode "{\"side\": \"cr\", \"value\": -42, \"inventory\": {\"current\": [], \"history\": [], \"total\": 0.0}}" :: Either String (Balance 2) +-- Right (Balance {balanceSide = SideCredit, balanceValue = -42.00, balanceInventory = MkInventory {inventoryTotal = 0.000000000000, inventoryCurrent = fromList [], inventoryHistory = fromList []}}) instance KnownNat precision => Aeson.FromJSON (Balance precision) where parseJSON = Aeson.genericParseJSON $ commonAesonOptions "balance" @@ -51,27 +58,29 @@ -- -- For normal balances: -- +-- >>> :set -XDataKinds +-- >>> import Data.Default (def) -- >>> import Haspara.Accounting.Side -- >>> import Haspara.Quantity --- >>> Aeson.encode (Balance SideDebit (mkQuantity 42 :: Quantity 2)) --- "{\"side\":\"db\",\"value\":42.0}" --- >>> Aeson.encode (Balance SideCredit (mkQuantity 42 :: Quantity 2)) --- "{\"side\":\"cr\",\"value\":42.0}" --- >>> Aeson.eitherDecode (Aeson.encode (Balance SideDebit (mkQuantity 42 :: Quantity 2))) :: Either String (Balance 2) --- Right (Balance {balanceSide = SideDebit, balanceValue = 42.00}) --- >>> Aeson.eitherDecode (Aeson.encode (Balance SideCredit (mkQuantity 42 :: Quantity 2))) :: Either String (Balance 2) --- Right (Balance {balanceSide = SideCredit, balanceValue = 42.00}) +-- >>> Aeson.encode (Balance SideDebit (mkQuantity 42 :: Quantity 2) def) +-- "{\"inventory\":{\"current\":[],\"history\":[],\"total\":0.0},\"side\":\"db\",\"value\":42.0}" +-- >>> Aeson.encode (Balance SideCredit (mkQuantity 42 :: Quantity 2) def) +-- "{\"inventory\":{\"current\":[],\"history\":[],\"total\":0.0},\"side\":\"cr\",\"value\":42.0}" +-- >>> Aeson.eitherDecode (Aeson.encode (Balance SideDebit (mkQuantity 42 :: Quantity 2) def)) :: Either String (Balance 2) +-- Right (Balance {balanceSide = SideDebit, balanceValue = 42.00, balanceInventory = MkInventory {inventoryTotal = 0.000000000000, inventoryCurrent = fromList [], inventoryHistory = fromList []}}) +-- >>> Aeson.eitherDecode (Aeson.encode (Balance SideCredit (mkQuantity 42 :: Quantity 2) def)) :: Either String (Balance 2) +-- Right (Balance {balanceSide = SideCredit, balanceValue = 42.00, balanceInventory = MkInventory {inventoryTotal = 0.000000000000, inventoryCurrent = fromList [], inventoryHistory = fromList []}}) -- -- For negative balances: -- --- >>> Aeson.encode (Balance SideDebit (mkQuantity (-42) :: Quantity 2)) --- "{\"side\":\"db\",\"value\":-42.0}" --- >>> Aeson.encode (Balance SideCredit (mkQuantity (-42) :: Quantity 2)) --- "{\"side\":\"cr\",\"value\":-42.0}" --- >>> Aeson.eitherDecode (Aeson.encode (Balance SideDebit (mkQuantity (-42) :: Quantity 2))) :: Either String (Balance 2) --- Right (Balance {balanceSide = SideDebit, balanceValue = -42.00}) --- >>> Aeson.eitherDecode (Aeson.encode (Balance SideCredit (mkQuantity (-42) :: Quantity 2))) :: Either String (Balance 2) --- Right (Balance {balanceSide = SideCredit, balanceValue = -42.00}) +-- >>> Aeson.encode (Balance SideDebit (mkQuantity (-42) :: Quantity 2) def) +-- "{\"inventory\":{\"current\":[],\"history\":[],\"total\":0.0},\"side\":\"db\",\"value\":-42.0}" +-- >>> Aeson.encode (Balance SideCredit (mkQuantity (-42) :: Quantity 2) def) +-- "{\"inventory\":{\"current\":[],\"history\":[],\"total\":0.0},\"side\":\"cr\",\"value\":-42.0}" +-- >>> Aeson.eitherDecode (Aeson.encode (Balance SideDebit (mkQuantity (-42) :: Quantity 2) def)) :: Either String (Balance 2) +-- Right (Balance {balanceSide = SideDebit, balanceValue = -42.00, balanceInventory = MkInventory {inventoryTotal = 0.000000000000, inventoryCurrent = fromList [], inventoryHistory = fromList []}}) +-- >>> Aeson.eitherDecode (Aeson.encode (Balance SideCredit (mkQuantity (-42) :: Quantity 2) def)) :: Either String (Balance 2) +-- Right (Balance {balanceSide = SideCredit, balanceValue = -42.00, balanceInventory = MkInventory {inventoryTotal = 0.000000000000, inventoryCurrent = fromList [], inventoryHistory = fromList []}}) instance KnownNat precision => Aeson.ToJSON (Balance precision) where toJSON = Aeson.genericToJSON $ commonAesonOptions "balance" @@ -81,8 +90,8 @@ :: KnownNat precision => Balance precision -> Maybe (Quantity precision) -balanceDebit (Balance SideDebit v) = Just v -balanceDebit _ = Nothing +balanceDebit (Balance SideDebit v _) = Just v +balanceDebit _ = Nothing -- | Returns the credit quantity, if any. @@ -90,18 +99,20 @@ :: KnownNat precision => Balance precision -> Maybe (Quantity precision) -balanceCredit (Balance SideCredit v) = Just v -balanceCredit _ = Nothing +balanceCredit (Balance SideCredit v _) = Just v +balanceCredit _ = Nothing -- | Updates the balance with the given amount. -- +-- >>> :set -XDataKinds +-- >>> import Data.Default (def) -- >>> import Haspara.Accounting.Amount -- >>> import Haspara.Accounting.Side -- >>> import Refined.Unsafe --- >>> let balance = Balance SideDebit 42 :: Balance 2 +-- >>> let balance = Balance SideDebit 42 def :: Balance 2 -- >>> balance --- Balance {balanceSide = SideDebit, balanceValue = 42.00} +-- Balance {balanceSide = SideDebit, balanceValue = 42.00, balanceInventory = MkInventory {inventoryTotal = 0.000000000000, inventoryCurrent = fromList [], inventoryHistory = fromList []}} -- >>> let amountDebit = Amount SideDebit (unsafeRefine 10) :: Amount 2 -- >>> amountDebit -- Amount {amountSide = SideDebit, amountValue = Refined 10.00} @@ -109,34 +120,51 @@ -- >>> amountCredit -- Amount {amountSide = SideCredit, amountValue = Refined 10.00} -- >>> updateBalance balance amountDebit --- Balance {balanceSide = SideDebit, balanceValue = 52.00} +-- Balance {balanceSide = SideDebit, balanceValue = 52.00, balanceInventory = MkInventory {inventoryTotal = 0.000000000000, inventoryCurrent = fromList [], inventoryHistory = fromList []}} -- >>> updateBalance balance amountCredit --- Balance {balanceSide = SideDebit, balanceValue = 32.00} +-- Balance {balanceSide = SideDebit, balanceValue = 32.00, balanceInventory = MkInventory {inventoryTotal = 0.000000000000, inventoryCurrent = fromList [], inventoryHistory = fromList []}} updateBalance :: KnownNat precision => Balance precision -> Amount precision -> Balance precision -updateBalance (Balance bSide bVal) (Amount aSide aVal) = - Balance bSide (bVal + (unrefine aVal * (if bSide == aSide then 1 else (-1)))) +updateBalance (Balance bSide bVal inventory) (Amount aSide aVal) = + Balance bSide (bVal + (unrefine aVal * (if bSide == aSide then 1 else (-1)))) inventory +-- | Updates the balance with additional inventory event. +updateBalanceWithInventory + :: KnownNat precision + => Day + -> Balance precision + -> Amount precision + -> Quantity 12 + -> ([InventoryHistoryItem 8 12 precision], Balance precision) +updateBalanceWithInventory date balance amount quantity = + let nb = updateBalance balance amount + vv = abs (valueFromAmount AccountKindAsset amount) + (is, ni) = updateInventoryVV date vv quantity (balanceInventory nb) + in (Foldable.toList is, nb {balanceInventory = ni}) + + -- | Converts the balance to amount. -- +-- >>> :set -XDataKinds +-- >>> import Data.Default (def) -- >>> import Haspara.Accounting.Side --- >>> amountFromBalance (Balance SideDebit 42 :: Balance 2) +-- >>> amountFromBalance (Balance SideDebit 42 def :: Balance 2) -- Amount {amountSide = SideDebit, amountValue = Refined 42.00} --- >>> amountFromBalance (Balance SideDebit (-42) :: Balance 2) +-- >>> amountFromBalance (Balance SideDebit (-42) def :: Balance 2) -- Amount {amountSide = SideCredit, amountValue = Refined 42.00} --- >>> amountFromBalance (Balance SideCredit 42 :: Balance 2) +-- >>> amountFromBalance (Balance SideCredit 42 def :: Balance 2) -- Amount {amountSide = SideCredit, amountValue = Refined 42.00} --- >>> amountFromBalance (Balance SideCredit (-42) :: Balance 2) +-- >>> amountFromBalance (Balance SideCredit (-42) def :: Balance 2) -- Amount {amountSide = SideDebit, amountValue = Refined 42.00} amountFromBalance :: KnownNat precision => Balance precision -> Amount precision -amountFromBalance (Balance side value) = +amountFromBalance (Balance side value _) = Amount (if value < 0 then otherSide side else side) (absQuantity value) diff --git a/src/Haspara/Accounting/Inventory.hs b/src/Haspara/Accounting/Inventory.hs new file mode 100644 --- /dev/null +++ b/src/Haspara/Accounting/Inventory.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RecordWildCards #-} + +-- | This module provides FIFO machinery for inventory accounting. +module Haspara.Accounting.Inventory where + +import qualified Data.Aeson as Aeson +import Data.Default (Default (..)) +import Data.Maybe (fromMaybe) +import qualified Data.Sequence as Seq +import Data.Time (Day) +import GHC.Generics (Generic) +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Internal.Aeson (commonAesonOptions) +import Haspara.Quantity (Quantity, divideD, times) + + +-- * Data Definitions + + +-- | Data definition that keeps track of inventory for an economic resource. +-- +-- This data definition is polymorphic over the precision for, respectively: +-- +-- 1. @pprec@ precision of the price values, +-- 2. @sprec@ precision of the inventory event quantities, and +-- 3. @vprec@ precision of the monetary values such as PnL. +-- +-- Values of this type should not be directly manipulated. Instead, `def` is to +-- be used for initializing an empty inventory and `updateInventory` method (and +-- convenience wrappers) should be used to update the inventory with new +-- inventory events. +data Inventory (pprec :: Nat) (sprec :: Nat) (vprec :: Nat) = MkInventory + { inventoryTotal :: !(Quantity sprec) + , inventoryCurrent :: !(Seq.Seq (InventoryEvent pprec sprec)) + , inventoryHistory :: !(Seq.Seq (InventoryHistoryItem pprec sprec vprec)) + } + deriving (Eq, Generic, Show) + + +instance (KnownNat pprec, KnownNat sprec, KnownNat vprec) => Default (Inventory pprec sprec vprec) where + def = + MkInventory + { inventoryTotal = 0 + , inventoryCurrent = mempty + , inventoryHistory = mempty + } + + +instance (KnownNat pprec, KnownNat sprec, KnownNat vprec) => Aeson.FromJSON (Inventory pprec sprec vprec) where + parseJSON = Aeson.genericParseJSON $ commonAesonOptions "inventory" + + +instance (KnownNat pprec, KnownNat sprec, KnownNat vprec) => Aeson.ToJSON (Inventory pprec sprec vprec) where + toJSON = Aeson.genericToJSON $ commonAesonOptions "inventory" + + +-- | Data definition for inventory events. +-- +-- This data definition is polymorphic over the precision for, respectively: +-- +-- 1. @pprec@ precision of the price values, and +-- 2. @sprec@ precision of the inventory event quantities. +data InventoryEvent (pprec :: Nat) (sprec :: Nat) = InventoryEvent + { inventoryEventDate :: !Day + , inventoryEventPrice :: !(Quantity pprec) + , inventoryEventQuantity :: !(Quantity sprec) + } + deriving (Eq, Generic, Show) + + +instance (KnownNat pprec, KnownNat sprec) => Aeson.FromJSON (InventoryEvent pprec sprec) where + parseJSON = Aeson.genericParseJSON $ commonAesonOptions "inventoryEvent" + + +instance (KnownNat pprec, KnownNat sprec) => Aeson.ToJSON (InventoryEvent pprec sprec) where + toJSON = Aeson.genericToJSON $ commonAesonOptions "inventoryEvent" + + +-- | Data definition for PnL-taking inventory history items. +-- +-- Essentially, values of this type represent a pnl-taking for a long/short +-- inventory event and a matching short/long inventory event of the same +-- quantity. Date refers to the date of the later event. If prices are +-- different, PnL is non-zero. +-- +-- This data definition is polymorphic over the precision for, respectively: +-- +-- 1. @pprec@ precision of the price values, +-- 2. @sprec@ precision of the inventory event quantities, and +-- 3. @vprec@ precision of the monetary values such as PnL. +-- +-- Values of this type should not be directly manipulated. `updateInventory` +-- method (and convenience wrappers) are in charge of creating values of this +-- data type. +data InventoryHistoryItem (pprec :: Nat) (sprec :: Nat) (vprec :: Nat) = MkInventoryHistoryItem + { inventoryHistoryItemDate :: !Day + , inventoryHistoryItemPnl :: !(Quantity vprec) + , inventoryHistoryItemFst :: !(InventoryEvent pprec sprec) + , inventoryHistoryItemSnd :: !(InventoryEvent pprec sprec) + } + deriving (Eq, Generic, Show) + + +instance (KnownNat pprec, KnownNat sprec, KnownNat vprec) => Aeson.FromJSON (InventoryHistoryItem pprec sprec vprec) where + parseJSON = Aeson.genericParseJSON $ commonAesonOptions "inventoryHistoryItem" + + +instance (KnownNat pprec, KnownNat sprec, KnownNat vprec) => Aeson.ToJSON (InventoryHistoryItem pprec sprec vprec) where + toJSON = Aeson.genericToJSON $ commonAesonOptions "inventoryHistoryItem" + + +-- * Operations + + +-- | Processes a new inventory event onto the inventory. +-- +-- Any event with @0@ quantity is disregarded. +updateInventory + :: KnownNat pprec + => KnownNat sprec + => KnownNat vprec + => InventoryEvent pprec sprec + -> Inventory pprec sprec vprec + -> (Seq.Seq (InventoryHistoryItem pprec sprec vprec), Inventory pprec sprec vprec) +updateInventory event inventory = case inventoryEventQuantity event of + 0 -> (mempty, inventory) + _ -> updateInventoryAux mempty event inventory + + +-- | Convenience wrapper for 'updateInventory' which works with date, price and +-- quantity. +updateInventoryVP + :: KnownNat pprec + => KnownNat sprec + => KnownNat vprec + => Day + -> Quantity pprec + -> Quantity sprec + -> Inventory pprec sprec vprec + -> (Seq.Seq (InventoryHistoryItem pprec sprec vprec), Inventory pprec sprec vprec) +updateInventoryVP date price quantity = + updateInventory $ + InventoryEvent + { inventoryEventDate = date + , inventoryEventPrice = price + , inventoryEventQuantity = quantity + } + + +-- | Convenience wrapper for 'updateInventory' which works with date, price and +-- quantity. +updateInventoryVV + :: KnownNat pprec + => KnownNat sprec + => KnownNat vprec + => Day + -> Quantity vprec + -> Quantity sprec + -> Inventory pprec sprec vprec + -> (Seq.Seq (InventoryHistoryItem pprec sprec vprec), Inventory pprec sprec vprec) +updateInventoryVV date value quantity = + let price = fromMaybe 0 $ value `divideD` quantity + in updateInventoryVP date (abs price) quantity + + +-- * Internal Definitions + + +-- | Work-horse function for updating inventory. +-- +-- This is where the whole trick happens in this module. +updateInventoryAux + :: KnownNat pprec + => KnownNat sprec + => KnownNat vprec + => Seq.Seq (InventoryHistoryItem pprec sprec vprec) + -> InventoryEvent pprec sprec + -> Inventory pprec sprec vprec + -> (Seq.Seq (InventoryHistoryItem pprec sprec vprec), Inventory pprec sprec vprec) +updateInventoryAux history event inventory@MkInventory {..} = + case Seq.viewl inventoryCurrent of + Seq.EmptyL -> (history, addInventoryEvent event inventory) + i Seq.:< is -> case whatMunch event i of + MunchNo -> (history, addInventoryEvent event inventory) + MunchAll -> + let (historyItem, newInventory) = munchAll event i is inventory + in (history Seq.|> historyItem, newInventory) + MunchLeft quan -> + let (newEvent, remEvent) = splitEvent quan event + (historyItem, newInventory) = munchAll newEvent i is inventory + in updateInventoryAux (history Seq.|> historyItem) remEvent newInventory + MunchRight quan -> + let (newEvent, remEvent) = splitEvent quan i + (historyItem, newInventory) = munchAll event newEvent (remEvent Seq.<| is) inventory + in (history Seq.|> historyItem, newInventory) + + +-- | Splits the event into two events as per the given quantity. +-- +-- If the event has a quantity of @100@ and the desired quantity is @10@, this +-- function spits out two event with same information except that the first has +-- a quantity of @10@ and the second has a quantity of @90@. +splitEvent + :: KnownNat pprec + => KnownNat sprec + => Quantity sprec + -> InventoryEvent pprec sprec + -> (InventoryEvent pprec sprec, InventoryEvent pprec sprec) +splitEvent qty event@InventoryEvent {..} = + let newItemQty = (-qty) + remItemQty = inventoryEventQuantity + qty + + newItem = event {inventoryEventQuantity = newItemQty} + remItem = event {inventoryEventQuantity = remItemQty} + in (newItem, remItem) + + +-- | Pushes a new inventory event to the inventory. +-- +-- This function is to be called by the internal machinery that handles most of +-- the critical tasks. Direct calls to this function will bypass the entire +-- machinery. +addInventoryEvent + :: KnownNat pprec + => KnownNat sprec + => KnownNat vprec + => InventoryEvent pprec sprec + -> Inventory pprec sprec vprec + -> Inventory pprec sprec vprec +addInventoryEvent event@InventoryEvent {..} inventory@MkInventory {..} = + inventory + { inventoryTotal = inventoryTotal + inventoryEventQuantity + , inventoryCurrent = inventoryCurrent Seq.|> event + } + + +-- | Captures two events of same absolute quantities with different directions +-- into a profit-taking inventory history item and updates the inventory. +munchAll + :: KnownNat pprec + => KnownNat sprec + => KnownNat vprec + => InventoryEvent pprec sprec + -> InventoryEvent pprec sprec + -> Seq.Seq (InventoryEvent pprec sprec) + -> Inventory pprec sprec vprec + -> (InventoryHistoryItem pprec sprec vprec, Inventory pprec sprec vprec) +munchAll lEvent rEvent remainingEvents inventory@MkInventory {..} = + let lValue = inventoryEventQuantity lEvent `times` inventoryEventPrice lEvent + rValue = inventoryEventQuantity rEvent `times` inventoryEventPrice rEvent + + historyItem = + MkInventoryHistoryItem + { inventoryHistoryItemDate = inventoryEventDate lEvent + , inventoryHistoryItemPnl = (-1) `times` (rValue + lValue) + , inventoryHistoryItemFst = rEvent + , inventoryHistoryItemSnd = lEvent + } + + newInventory = + inventory + { inventoryTotal = inventoryTotal + inventoryEventQuantity lEvent + , inventoryCurrent = remainingEvents + , inventoryHistory = inventoryHistory Seq.|> historyItem + } + in (historyItem, newInventory) + + +-- | Data definition representing how two inventory events should be processed. +data Munch (sprec :: Nat) + = MunchNo + | MunchAll + | MunchLeft (Quantity sprec) + | MunchRight (Quantity sprec) + deriving (Eq, Show) + + +-- | Figures out how two inventory events should be processed. +whatMunch + :: KnownNat pprec + => KnownNat sprec + => InventoryEvent pprec sprec + -> InventoryEvent pprec sprec + -> Munch sprec +whatMunch l r + | lsgn == rsgn = MunchNo + | labs == rabs = MunchAll + | labs > rabs = MunchLeft rqty + | otherwise = MunchRight lqty + where + lqty = inventoryEventQuantity l + labs = abs lqty + lsgn = signum lqty + + rqty = inventoryEventQuantity r + rabs = abs rqty + rsgn = signum rqty diff --git a/src/Haspara/Accounting/Journal.hs b/src/Haspara/Accounting/Journal.hs --- a/src/Haspara/Accounting/Journal.hs +++ b/src/Haspara/Accounting/Journal.hs @@ -1,20 +1,21 @@ --- | This module provides data definitions and functions to work with journal --- entries. - {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +-- | This module provides data definitions and functions to work with journal +-- entries. module Haspara.Accounting.Journal where -import qualified Data.Aeson as Aeson -import qualified Data.Text as T -import Data.Time (Day) -import GHC.Generics (Generic) -import GHC.TypeLits (KnownNat, Nat) -import Haspara.Accounting.Account (Account(accountKind)) -import Haspara.Accounting.Amount (Amount(..), amountFromQuantity, amountFromValue) -import Haspara.Accounting.Side (Side(..)) -import Haspara.Internal.Aeson (commonAesonOptions) -import Haspara.Quantity (Quantity, UnsignedQuantity, sumUnsignedQuantity) +import qualified Data.Aeson as Aeson +import qualified Data.Text as T +import Data.Time (Day) +import GHC.Generics (Generic) +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Accounting.Account (Account (accountKind)) +import Haspara.Accounting.Amount (Amount (..), amountFromValue) +import Haspara.Accounting.Side (Side (..)) +import Haspara.Internal.Aeson (commonAesonOptions) +import Haspara.Quantity (Quantity, UnsignedQuantity, sumUnsignedQuantity) -- | Data definition for the journal entries of interest (like a general @@ -42,9 +43,9 @@ -- of 'JournalEntryItem's. Journal entry definition is polymorphic over the -- precision of the monetary quantities, the account and event objects. data JournalEntry (precision :: Nat) account event = JournalEntry - { journalEntryId :: !T.Text - , journalEntryDate :: !Day - , journalEntryItems :: ![JournalEntryItem precision account event] + { journalEntryId :: !T.Text + , journalEntryDate :: !Day + , journalEntryItems :: ![JournalEntryItem precision account event] , journalEntryDescription :: !T.Text } deriving (Generic, Show) @@ -64,10 +65,10 @@ => JournalEntry precision account event -> UnsignedQuantity precision journalEntryTotalDebit = - sumUnsignedQuantity - . fmap (amountValue . journalEntryItemAmount) - . filter ((==) SideDebit . amountSide . journalEntryItemAmount) - . journalEntryItems + sumUnsignedQuantity + . fmap (amountValue . journalEntryItemAmount) + . filter ((==) SideDebit . amountSide . journalEntryItemAmount) + . journalEntryItems -- | Returns the total credit amount of a journal entry. @@ -76,10 +77,10 @@ => JournalEntry precision account event -> UnsignedQuantity precision journalEntryTotalCredit = - sumUnsignedQuantity - . fmap (amountValue . journalEntryItemAmount) - . filter ((==) SideCredit . amountSide . journalEntryItemAmount) - . journalEntryItems + sumUnsignedQuantity + . fmap (amountValue . journalEntryItemAmount) + . filter ((==) SideCredit . amountSide . journalEntryItemAmount) + . journalEntryItems -- | Predicate to check if a journal entry is balanced or not. @@ -90,9 +91,10 @@ :: KnownNat precision => JournalEntry precision account event -> Bool -isJournalEntryBalanced = (==) - <$> journalEntryTotalDebit - <*> journalEntryTotalCredit +isJournalEntryBalanced = + (==) + <$> journalEntryTotalDebit + <*> journalEntryTotalCredit -- | Data definition for a journal entry item. @@ -102,9 +104,10 @@ -- item definition is polymorphic over the precision of the monetary quantities, -- the account and event objects. data JournalEntryItem (precision :: Nat) account event = JournalEntryItem - { journalEntryItemAmount :: !(Amount precision) + { journalEntryItemAmount :: !(Amount precision) , journalEntryItemAccount :: !(Account account) - , journalEntryItemEvent :: !event + , journalEntryItemEvent :: !event + , journalEntryItemInventoryEvent :: !(Maybe (JournalEntryItemInventoryEvent account event)) } deriving (Eq, Generic, Show) @@ -117,37 +120,66 @@ toJSON = Aeson.genericToJSON $ commonAesonOptions "journalEntryItem" --- | Creates a 'JournalEntryItem' from the given signed /quantity/, the account --- it belongs to and the event it is originating from. +-- | Data definition for inventory event. +data JournalEntryItemInventoryEvent account event = JournalEntryItemInventoryEvent + { journalEntryItemInventoryEventPnlAccount :: !(Account account) + , journalEntryItemInventoryEventEvent :: !event + , journalEntryItemInventoryEventQuantity :: !(Quantity 12) + } + deriving (Eq, Generic, Show) + + +instance (Aeson.FromJSON account, Aeson.FromJSON event) => Aeson.FromJSON (JournalEntryItemInventoryEvent account event) where + parseJSON = Aeson.genericParseJSON $ commonAesonOptions "journalEntryItemInventoryEvent" + + +instance (Aeson.ToJSON account, Aeson.ToJSON event) => Aeson.ToJSON (JournalEntryItemInventoryEvent account event) where + toJSON = Aeson.genericToJSON $ commonAesonOptions "journalEntryItemInventoryEvent" + + +-- | Creates a 'JournalEntryItem' from the given signed /value/, the account it +-- belongs to and the event it is originating from. -- --- The /quantity/ is defined as in 'amountFromQuantity' function. -mkJournalEntryItemFromQuantity +-- The /value/ is defined as in 'amountFromValue' function. +mkJournalEntryItemFromValue :: KnownNat precision => Quantity precision -> Account account -> event -> JournalEntryItem precision account event -mkJournalEntryItemFromQuantity qty acc evt = +mkJournalEntryItemFromValue val acc evt = JournalEntryItem - { journalEntryItemAmount = amountFromQuantity (accountKind acc) qty + { journalEntryItemAmount = amountFromValue (accountKind acc) val , journalEntryItemAccount = acc , journalEntryItemEvent = evt + , journalEntryItemInventoryEvent = Nothing } --- | Creates a 'JournalEntryItem' from the given signed /value/, the account it --- belongs to and the event it is originating from. +-- | Creates a 'JournalEntryItem' with inventory event informationfrom the given +-- signed /value/, the account it belongs to and the event it is originating +-- from. -- -- The /value/ is defined as in 'amountFromValue' function. -mkJournalEntryItemFromValue +mkInventoryJournalEntryItemFromValue :: KnownNat precision => Quantity precision -> Account account -> event + -> Account account + -> event + -> Quantity 12 -> JournalEntryItem precision account event -mkJournalEntryItemFromValue val acc evt = +mkInventoryJournalEntryItemFromValue val acc evt pnlacc pnlevt evtqty = JournalEntryItem { journalEntryItemAmount = amountFromValue (accountKind acc) val , journalEntryItemAccount = acc , journalEntryItemEvent = evt + , journalEntryItemInventoryEvent = + Just $ + JournalEntryItemInventoryEvent + { journalEntryItemInventoryEventPnlAccount = pnlacc + , journalEntryItemInventoryEventQuantity = evtqty + , journalEntryItemInventoryEventEvent = pnlevt + } } diff --git a/src/Haspara/Accounting/Ledger.hs b/src/Haspara/Accounting/Ledger.hs --- a/src/Haspara/Accounting/Ledger.hs +++ b/src/Haspara/Accounting/Ledger.hs @@ -1,25 +1,30 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + -- | This module provides data definitions and functions for ledgers and -- postings. - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} - module Haspara.Accounting.Ledger where -import qualified Data.Aeson as Aeson -import qualified Data.Map.Strict as HM -import Data.Maybe (fromMaybe, listToMaybe) -import qualified Data.Text as T -import Data.Time (Day) -import GHC.Generics (Generic) -import GHC.TypeLits (KnownNat, Nat) -import Haspara.Accounting.Account (Account(accountKind)) -import Haspara.Accounting.Amount (Amount, amountFromQuantity, amountFromValue) -import Haspara.Accounting.Balance (Balance(Balance), updateBalance) -import Haspara.Accounting.Journal (JournalEntry(..), JournalEntryItem(JournalEntryItem)) -import Haspara.Accounting.Side (normalSideByAccountKind) -import Haspara.Internal.Aeson (commonAesonOptions) -import Haspara.Quantity (Quantity) +import qualified Data.Aeson as Aeson +import Data.Default (def) +import Data.Foldable (foldl') +import qualified Data.Map.Strict as HM +import Data.Maybe (fromMaybe, listToMaybe, maybeToList) +import qualified Data.Text as T +import Data.Time (Day) +import GHC.Generics (Generic) +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Accounting.Account (Account (accountKind)) +import Haspara.Accounting.Amount (Amount, amountFromQuantity, amountFromValue) +import Haspara.Accounting.Balance (Balance (Balance), updateBalance, updateBalanceWithInventory) +import Haspara.Accounting.Inventory (InventoryHistoryItem (MkInventoryHistoryItem, inventoryHistoryItemPnl), updateInventoryVV) +import Haspara.Accounting.Journal (JournalEntry (..), JournalEntryItem (..), JournalEntryItemInventoryEvent (JournalEntryItemInventoryEvent)) +import Haspara.Accounting.Side (normalSideByAccountKind) +import Haspara.Internal.Aeson (commonAesonOptions) +import Haspara.Quantity (Quantity) -- | Data definition for a general ledger. @@ -65,12 +70,12 @@ -- | Type encoding of a ledger item. data LedgerEntry (precision :: Nat) event = LedgerEntry - { ledgerEntryDate :: !Day - , ledgerEntryAmount :: !(Amount precision) + { ledgerEntryDate :: !Day + , ledgerEntryAmount :: !(Amount precision) , ledgerEntryDescription :: !T.Text - , ledgerEntryEvent :: !event - , ledgerEntryPostingId :: !T.Text - , ledgerEntryBalance :: !(Balance precision) + , ledgerEntryEvent :: !event + , ledgerEntryPostingId :: !T.Text + , ledgerEntryBalance :: !(Balance precision) } deriving (Eq, Generic, Show) @@ -90,7 +95,7 @@ -> Ledger precision account event initLedger acc = Ledger acc balance [] where - balance = Balance (normalSideByAccountKind (accountKind acc)) 0 + balance = Balance (normalSideByAccountKind (accountKind acc)) 0 def -- | Initializes a ledger with the given opening balance. @@ -108,12 +113,15 @@ initLedgerWithOpeningValue :: KnownNat precision => Account account - -> Quantity precision + -> (Maybe (Quantity 12), Quantity precision) -> Ledger precision account event -initLedgerWithOpeningValue acc qty = initLedgerWithOpeningBalance acc balance +initLedgerWithOpeningValue acc (mstk, qty) = initLedgerWithOpeningBalance acc balance where + inventory = snd $ case mstk of + Nothing -> def + Just sq -> updateInventoryVV (read "1970-01-01") qty sq def amount = amountFromValue (accountKind acc) qty - balance0 = Balance (normalSideByAccountKind (accountKind acc)) 0 + balance0 = Balance (normalSideByAccountKind (accountKind acc)) 0 inventory balance = updateBalance balance0 amount @@ -123,12 +131,15 @@ initLedgerWithOpeningQuantity :: KnownNat precision => Account account - -> Quantity precision + -> (Maybe (Quantity 12), Quantity precision) -> Ledger precision account event -initLedgerWithOpeningQuantity acc qty = initLedgerWithOpeningBalance acc balance +initLedgerWithOpeningQuantity acc (mstk, qty) = initLedgerWithOpeningBalance acc balance where + inventory = snd $ case mstk of + Nothing -> def + Just sq -> updateInventoryVV (read "1970-01-01") qty sq def amount = amountFromQuantity (accountKind acc) qty - balance0 = Balance (normalSideByAccountKind (accountKind acc)) 0 + balance0 = Balance (normalSideByAccountKind (accountKind acc)) 0 inventory balance = updateBalance balance0 amount @@ -166,17 +177,20 @@ -> JournalEntry precision account event -> JournalEntryItem precision account event -> GeneralLedger precision account event -postEntryItem gl je (JournalEntryItem amt acc evt) = - let - ledgers = generalLedgerLedgers gl - ledgersDb = HM.fromList $ zip (fmap ledgerAccount ledgers) ledgers - ledgerCurr = fromMaybe (initLedger acc) $ HM.lookup acc ledgersDb - ledgerNext = postItem ledgerCurr (journalEntryDate je) amt (journalEntryDescription je) evt (journalEntryId je) - ledgersDbNext = HM.insert acc ledgerNext ledgersDb - in - GeneralLedger - { generalLedgerLedgers = HM.elems ledgersDbNext - } +postEntryItem gl je (JournalEntryItem amt acc evt invevt) = + let ledgers = generalLedgerLedgers gl + ledgersDb = HM.fromList $ zip (fmap ledgerAccount ledgers) ledgers + ledgerCurr = fromMaybe (initLedger acc) $ HM.lookup acc ledgersDb + jeDate = journalEntryDate je + jeDesc = journalEntryDescription je + jeCode = journalEntryId je + (jePnl, ledgerNext) = postItem ledgerCurr jeDate amt jeDesc evt jeCode invevt + ledgersDbNext = HM.insert acc ledgerNext ledgersDb + ngl = + GeneralLedger + { generalLedgerLedgers = HM.elems ledgersDbNext + } + in postEntries ngl (maybeToList jePnl) -- | Performs a posting to the given ledger. @@ -188,20 +202,76 @@ -> T.Text -> event -> T.Text - -> Ledger precision account event -postItem ledger date amt dsc evt pid = - let - balanceLast = ledgerClosing ledger - balanceNext = updateBalance balanceLast amt - item = LedgerEntry - { ledgerEntryDate = date - , ledgerEntryAmount = amt - , ledgerEntryDescription = dsc - , ledgerEntryEvent = evt - , ledgerEntryPostingId = pid - , ledgerEntryBalance = balanceNext - } - in - ledger - { ledgerRunning = item : ledgerRunning ledger - } + -> Maybe (JournalEntryItemInventoryEvent account event) + -> (Maybe (JournalEntry precision account event), Ledger precision account event) +postItem ledger date amt dsc evt pid Nothing = + let balanceLast = ledgerClosing ledger + balanceNext = updateBalance balanceLast amt + item = + LedgerEntry + { ledgerEntryDate = date + , ledgerEntryAmount = amt + , ledgerEntryDescription = dsc + , ledgerEntryEvent = evt + , ledgerEntryPostingId = pid + , ledgerEntryBalance = balanceNext + } + in ( Nothing + , ledger + { ledgerRunning = item : ledgerRunning ledger + } + ) +postItem ledger date amt dsc evt pid (Just (JournalEntryItemInventoryEvent pnlacc pnlevt evtqty)) = + let balanceLast = ledgerClosing ledger + (histitems, balanceNext) = updateBalanceWithInventory date balanceLast amt evtqty + item = + LedgerEntry + { ledgerEntryDate = date + , ledgerEntryAmount = amt + , ledgerEntryDescription = dsc + , ledgerEntryEvent = evt + , ledgerEntryPostingId = pid + , ledgerEntryBalance = balanceNext + } + mje = case histitems of + [] -> Nothing + _ -> + Just $ + JournalEntry + { journalEntryId = pid + , journalEntryDate = date + , journalEntryItems = foldl' (\a c -> a <> histItemToJournalEntryItem pnlevt (ledgerAccount ledger) pnlacc c) [] histitems + , journalEntryDescription = "Realized PnL due to: " <> dsc + } + in ( mje + , ledger + { ledgerRunning = item : ledgerRunning ledger + } + ) + + +-- | Creates 2 journal entry items for the captured non-zero PnL. +histItemToJournalEntryItem + :: KnownNat precision + => event + -> Account account + -> Account account + -> InventoryHistoryItem 8 12 precision + -> [JournalEntryItem precision account event] +histItemToJournalEntryItem event accAsset accRevenue MkInventoryHistoryItem {..} = + if inventoryHistoryItemPnl == 0 + then [] + else + [ JournalEntryItem + { journalEntryItemAmount = amountFromQuantity (accountKind accAsset) inventoryHistoryItemPnl + , journalEntryItemAccount = accAsset + , journalEntryItemEvent = event + , journalEntryItemInventoryEvent = Nothing + } + , JournalEntryItem + { journalEntryItemAmount = amountFromQuantity (accountKind accRevenue) inventoryHistoryItemPnl + , journalEntryItemAccount = accRevenue + , journalEntryItemEvent = event + , journalEntryItemInventoryEvent = Nothing + } + ] diff --git a/src/Haspara/Accounting/Side.hs b/src/Haspara/Accounting/Side.hs --- a/src/Haspara/Accounting/Side.hs +++ b/src/Haspara/Accounting/Side.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | This module provides definitions for and functions to work with -- Debit/Credit dichotomy which is essential to double-entry bookkeeping. -- @@ -9,14 +11,13 @@ -- This module provides 'Aeson.FromJSON' and 'Aeson.ToJSON' instances for 'Side' -- as well. Following accounting conventions, we chose the JSON value for -- "Debit" as @"db"@, and for "Credit" as @"cr"@. - module Haspara.Accounting.Side where -import qualified Data.Aeson as Aeson -import qualified Data.Text as T -import GHC.TypeLits (KnownNat) -import Haspara.Accounting.Account (AccountKind(..)) -import Haspara.Quantity (Quantity) +import qualified Data.Aeson as Aeson +import qualified Data.Text as T +import GHC.TypeLits (KnownNat) +import Haspara.Accounting.Account (AccountKind (..)) +import Haspara.Quantity (Quantity) -- | Data definition for encoding the debit/credit indicator. @@ -26,6 +27,7 @@ -- | 'Aeson.FromJSON' instance for 'Side'. -- +-- >>> :set -XOverloadedStrings -- >>> Aeson.eitherDecode "\"db\"" :: Either String Side -- Right SideDebit -- >>> Aeson.eitherDecode "\"cr\"" :: Either String Side @@ -36,7 +38,7 @@ parseJSON = Aeson.withText "Side" $ \t -> case t of "db" -> pure SideDebit "cr" -> pure SideCredit - _ -> fail $ "Unkown side indicator: \"" <> T.unpack t <> "\". Expecting one of \"db\" or \"cr\"" + _ -> fail $ "Unkown side indicator: \"" <> T.unpack t <> "\". Expecting one of \"db\" or \"cr\"" -- | 'Aeson.ToJSON' instance for 'Side'. @@ -50,7 +52,7 @@ -- >>> Aeson.decode (Aeson.encode SideCredit) == Just SideCredit -- True instance Aeson.ToJSON Side where - toJSON SideDebit = Aeson.String "db" + toJSON SideDebit = Aeson.String "db" toJSON SideCredit = Aeson.String "cr" @@ -61,7 +63,7 @@ -- >>> otherSide SideCredit -- SideDebit otherSide :: Side -> Side -otherSide SideDebit = SideCredit +otherSide SideDebit = SideCredit otherSide SideCredit = SideDebit @@ -112,16 +114,16 @@ -> Quantity precision -> Side sideByAccountKind k q = case (k, signum q >= 0) of - (AccountKindAsset, False) -> SideCredit - (AccountKindAsset, True) -> SideDebit + (AccountKindAsset, False) -> SideCredit + (AccountKindAsset, True) -> SideDebit (AccountKindLiability, False) -> SideDebit - (AccountKindLiability, True) -> SideCredit - (AccountKindEquity, False) -> SideDebit - (AccountKindEquity, True) -> SideCredit - (AccountKindRevenue, False) -> SideDebit - (AccountKindRevenue, True) -> SideCredit - (AccountKindExpense, False) -> SideCredit - (AccountKindExpense, True) -> SideDebit + (AccountKindLiability, True) -> SideCredit + (AccountKindEquity, False) -> SideDebit + (AccountKindEquity, True) -> SideCredit + (AccountKindRevenue, False) -> SideDebit + (AccountKindRevenue, True) -> SideCredit + (AccountKindExpense, False) -> SideCredit + (AccountKindExpense, True) -> SideDebit -- | Returns the "normal" side for a given 'AccountKind'. @@ -142,8 +144,8 @@ -- | Expense | Debit | Credit | -- +-----------------+----------------+------------------+ normalSideByAccountKind :: AccountKind -> Side -normalSideByAccountKind AccountKindAsset = SideDebit +normalSideByAccountKind AccountKindAsset = SideDebit normalSideByAccountKind AccountKindLiability = SideCredit -normalSideByAccountKind AccountKindEquity = SideCredit -normalSideByAccountKind AccountKindRevenue = SideCredit -normalSideByAccountKind AccountKindExpense = SideDebit +normalSideByAccountKind AccountKindEquity = SideCredit +normalSideByAccountKind AccountKindRevenue = SideCredit +normalSideByAccountKind AccountKindExpense = SideDebit diff --git a/src/Haspara/Accounting/TrialBalance.hs b/src/Haspara/Accounting/TrialBalance.hs --- a/src/Haspara/Accounting/TrialBalance.hs +++ b/src/Haspara/Accounting/TrialBalance.hs @@ -1,17 +1,19 @@ --- | This module provides data definitions and functions for trial balances. - {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE KindSignatures #-} +-- | This module provides data definitions and functions for trial balances. module Haspara.Accounting.TrialBalance where -import qualified Data.Aeson as Aeson -import GHC.Generics (Generic) -import GHC.TypeLits (KnownNat, Nat) -import Haspara.Accounting.Amount (Amount) -import Haspara.Accounting.Balance (Balance(Balance, balanceSide), amountFromBalance, updateBalance) -import Haspara.Accounting.Ledger (GeneralLedger(generalLedgerLedgers), Ledger, ledgerClosing) -import Haspara.Accounting.Side (Side(..)) -import Haspara.Internal.Aeson (commonAesonOptions) +import qualified Data.Aeson as Aeson +import Data.Default (def) +import GHC.Generics (Generic) +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Accounting.Amount (Amount) +import Haspara.Accounting.Balance (Balance (Balance, balanceSide), amountFromBalance, updateBalance) +import Haspara.Accounting.Ledger (GeneralLedger (generalLedgerLedgers), Ledger, ledgerClosing) +import Haspara.Accounting.Side (Side (..)) +import Haspara.Internal.Aeson (commonAesonOptions) -- | Data definition for a trial balance. @@ -31,7 +33,7 @@ -- | Data definition for a trial balance item. data TrialBalanceItem (precision :: Nat) account event = TrialBalanceItem - { trialBalanceItemLedger :: !(Ledger precision account event) + { trialBalanceItemLedger :: !(Ledger precision account event) , trialBalanceItemBalance :: !(Balance precision) } deriving (Eq, Generic, Show) @@ -78,10 +80,8 @@ => TrialBalance precision account event -> (Balance precision, Balance precision) trialBalanceTotals (TrialBalance items) = - let - itemsFromDb = amountFromBalance . trialBalanceItemBalance <$> filter ((==) SideDebit . balanceSide . trialBalanceItemBalance) items - itemsFromCr = amountFromBalance . trialBalanceItemBalance <$> filter ((==) SideCredit . balanceSide . trialBalanceItemBalance) items - totalDb = foldl updateBalance (Balance SideDebit 0) itemsFromDb - totalCr = foldl updateBalance (Balance SideCredit 0) itemsFromCr - in - (totalDb, totalCr) + let itemsFromDb = amountFromBalance . trialBalanceItemBalance <$> filter ((==) SideDebit . balanceSide . trialBalanceItemBalance) items + itemsFromCr = amountFromBalance . trialBalanceItemBalance <$> filter ((==) SideCredit . balanceSide . trialBalanceItemBalance) items + totalDb = foldl updateBalance (Balance SideDebit 0 def) itemsFromDb + totalCr = foldl updateBalance (Balance SideCredit 0 def) itemsFromCr + in (totalDb, totalCr) diff --git a/src/Haspara/Currency.hs b/src/Haspara/Currency.hs --- a/src/Haspara/Currency.hs +++ b/src/Haspara/Currency.hs @@ -1,24 +1,26 @@ --- | This module provides definitions for modeling and working with currencies. - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +-- | This module provides definitions for modeling and working with currencies. module Haspara.Currency where -import Control.Monad.Except (MonadError(throwError)) -import qualified Data.Aeson as Aeson -import Data.Hashable (Hashable) -import Data.String (IsString(..)) -import qualified Data.Text as T -import Data.Void (Void) -import GHC.Generics (Generic) -import Haspara.Internal.Aeson (commonAesonOptions) +import Control.Monad.Except (MonadError (throwError)) +import qualified Data.Aeson as Aeson +import Data.Hashable (Hashable) +import Data.String (IsString (..)) +import qualified Data.Text as T +import Data.Void (Void) +import GHC.Generics (Generic) +import Haspara.Internal.Aeson (commonAesonOptions) import qualified Language.Haskell.TH.Syntax as TH -import qualified Text.Megaparsec as MP +import qualified Text.Megaparsec as MP -- * Currency --- $currency -- | Type encoding for currency symbol values with a syntax of @[A-Z]{3}[A-Z]*@. @@ -26,6 +28,7 @@ -- 'Currency' values can be constructed via 'mkCurrencyError' that works in -- @'MonadError' 'T.Text'@ context: -- +-- >>> :set -XOverloadedStrings -- >>> mkCurrencyError "EUR" :: Either T.Text Currency -- Right EUR -- @@ -38,20 +41,22 @@ -- -- >>> "EUR" :: Currency -- EUR -newtype Currency = MkCurrency { currencyCode :: T.Text } +newtype Currency = MkCurrency {currencyCode :: T.Text} deriving (Eq, Hashable, Ord, TH.Lift) -- | 'IsString' instance for 'Currency'. -- +-- >>> :set -XOverloadedStrings -- >>> "USD" :: Currency -- USD instance IsString Currency where - fromString = either (error . T.unpack) id . mkCurrencyError . T.pack + fromString = either (error . T.unpack) id . mkCurrencyError . T.pack -- | 'Show' instance for 'Currency'. -- +-- >>> :set -XOverloadedStrings -- >>> "USD" :: Currency -- USD instance Show Currency where @@ -60,6 +65,7 @@ -- | 'Aeson.FromJSON' instance for 'Currency'. -- +-- >>> :set -XOverloadedStrings -- >>> Aeson.eitherDecode "\"\"" :: Either String Currency -- Left "Error in $: Currency code error! Expecting at least 3 uppercase ASCII letters, but received: " -- >>> Aeson.eitherDecode "\"A\"" :: Either String Currency @@ -76,6 +82,7 @@ -- | 'Aeson.ToJSON' instance for 'Currency'. -- +-- >>> :set -XOverloadedStrings -- >>> Aeson.encode ("USD" :: Currency) -- "\"USD\"" instance Aeson.ToJSON Currency where @@ -84,6 +91,7 @@ -- | Smart constructor for 'Currency' values within 'MonadError' context. -- +-- >>> :set -XOverloadedStrings -- >>> mkCurrencyError "" :: Either T.Text Currency -- Left "Currency code error! Expecting at least 3 uppercase ASCII letters, but received: " -- >>> mkCurrencyError " " :: Either T.Text Currency @@ -95,14 +103,16 @@ -- >>> mkCurrencyError "ABC" :: Either T.Text Currency -- Right ABC mkCurrencyError :: MonadError T.Text m => T.Text -> m Currency -mkCurrencyError x = either - (const . throwError $ "Currency code error! Expecting at least 3 uppercase ASCII letters, but received: " <> x) - (pure . MkCurrency) - (MP.runParser currencyCodeParser "Currency Code" x) +mkCurrencyError x = + either + (const . throwError $ "Currency code error! Expecting at least 3 uppercase ASCII letters, but received: " <> x) + (pure . MkCurrency) + (MP.runParser currencyCodeParser "Currency Code" x) -- | Smart constructor for 'Currency' values within 'MonadFail' context. -- +-- >>> :set -XOverloadedStrings -- >>> mkCurrencyFail "" :: Maybe Currency -- Nothing -- >>> mkCurrencyFail "US" :: Maybe Currency @@ -117,6 +127,7 @@ -- | Parser that parses currency codes. -- +-- >>> :set -XOverloadedStrings -- >>> MP.runParser currencyCodeParser "Example" "" -- Left (ParseErrorBundle {bundleErrors = TrivialError 0 (Just EndOfInput) (fromList []) :| [], bundlePosState = PosState {pstateInput = "", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}}) -- >>> MP.runParser currencyCodeParser "Example" " " @@ -139,17 +150,17 @@ optionals <- MP.many validChar pure . T.pack $ mandatory <> optionals where - validChar = MP.oneOf ['A'..'Z'] + validChar = MP.oneOf ['A' .. 'Z'] -- * Currency Pair --- $currencyPair -- | Type encoding of a currency pair. -- -- 'CurrencyPair' values are constructed via the data constructor: -- +-- >>> :set -XOverloadedStrings -- >>> CurrencyPair "EUR" "USD" -- EUR/USD -- @@ -160,8 +171,10 @@ -- >>> Aeson.encode (CurrencyPair "EUR" "USD") -- "{\"base\":\"EUR\",\"quote\":\"USD\"}" data CurrencyPair = CurrencyPair - { currencyPairBase :: !Currency -- ^ /Base currency/ of the currency pair. Also referred to as /counter currency/. - , currencyPairQuote :: !Currency -- ^ /Quote currency/ of the currency pair. Also referred to as /transaction currency/. + { currencyPairBase :: !Currency + -- ^ /Base currency/ of the currency pair. Also referred to as /counter currency/. + , currencyPairQuote :: !Currency + -- ^ /Quote currency/ of the currency pair. Also referred to as /transaction currency/. } deriving (Eq, Generic, Ord, TH.Lift) @@ -176,6 +189,7 @@ -- | 'Show' instance for 'CurrencyPair'. -- +-- >>> :set -XOverloadedStrings -- >>> CurrencyPair "EUR" "USD" -- EUR/USD instance Show CurrencyPair where @@ -184,6 +198,7 @@ -- | Converts a 'CurrencyPair' to a 2-tuple of 'Currency' values. -- +-- >>> :set -XOverloadedStrings -- >>> toCurrencyTuple (CurrencyPair "EUR" "USD") -- (EUR,USD) toCurrencyTuple :: CurrencyPair -> (Currency, Currency) @@ -192,6 +207,7 @@ -- | Converts a 2-tuple of 'Currency' values to a 'CurrencyPair'. -- +-- >>> :set -XOverloadedStrings -- >>> fromCurrencyTuple ("EUR", "USD") -- EUR/USD fromCurrencyTuple :: (Currency, Currency) -> CurrencyPair diff --git a/src/Haspara/FxQuote.hs b/src/Haspara/FxQuote.hs --- a/src/Haspara/FxQuote.hs +++ b/src/Haspara/FxQuote.hs @@ -1,28 +1,29 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} + -- | This module provides definitions for modeling and working with foreign -- exchange (FX) rate quotations. - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} - module Haspara.FxQuote where -import Control.Monad.Except (MonadError(throwError)) -import qualified Data.Aeson as Aeson -import Data.Foldable (foldl') -import qualified Data.Map.Strict as SM -import Data.Scientific (Scientific) -import qualified Data.Text as T -import Data.Time (Day, addDays) -import GHC.Generics (Generic) -import GHC.TypeLits (KnownNat, Nat) -import Haspara.Currency (Currency, CurrencyPair(CurrencyPair)) -import Haspara.Internal.Aeson (commonAesonOptions) -import Haspara.Quantity (Quantity(..), mkQuantity) -import Refined (Positive, Refined, refineError) +import Control.Monad.Except (MonadError (throwError)) +import qualified Data.Aeson as Aeson +import Data.Foldable (foldl') +import qualified Data.Map.Strict as SM +import Data.Scientific (Scientific) +import qualified Data.Text as T +import Data.Time (Day, addDays) +import GHC.Generics (Generic) +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Currency (Currency, CurrencyPair (CurrencyPair)) +import Haspara.Internal.Aeson (commonAesonOptions) +import Haspara.Quantity (Quantity (..), mkQuantity) +import Refined (Positive, Refined, refineError) -- * FX Rate Quotation --- $fxRateQuotation -- | Type encoding for FX rate quotations with fixed precision. @@ -33,9 +34,12 @@ -- 2. a date that the quotation is effective as of, -- 3. a (positive) rate as the value of the quotation. data FxQuote (s :: Nat) = MkFxQuote - { fxQuotePair :: !CurrencyPair -- ^ Currency pair of the FX rate. - , fxQuoteDate :: !Day -- ^ Actual date of the FX rate. - , fxQuoteRate :: !(Refined Positive (Quantity s)) -- ^ (Positive) rate value of the FX rate. + { fxQuotePair :: !CurrencyPair + -- ^ Currency pair of the FX rate. + , fxQuoteDate :: !Day + -- ^ Actual date of the FX rate. + , fxQuoteRate :: !(Refined Positive (Quantity s)) + -- ^ (Positive) rate value of the FX rate. } deriving (Eq, Generic, Ord, Show) @@ -54,6 +58,7 @@ -- The rate is expected to be a positive value. If it is not, the function will -- throw an error. -- +-- >>> :set -XTypeApplications -- >>> mkFxQuoteError @(Either _) @2 "EUR" "USD" (read "2021-12-31") 1.16 -- Right (MkFxQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16}) -- >>> mkFxQuoteError @(Either _) @2 "EUR" "USD" (read "2021-12-31") (-1.16) @@ -61,10 +66,14 @@ mkFxQuoteError :: MonadError T.Text m => KnownNat s - => Currency -- ^ Base currency (from) of the FX quotation. - -> Currency -- ^ Quote currency (to) of the FX quotation. - -> Day -- ^ Date of the FX quotation. - -> Scientific -- ^ FX quotation rate, expected to be positive. + => Currency + -- ^ Base currency (from) of the FX quotation. + -> Currency + -- ^ Quote currency (to) of the FX quotation. + -> Day + -- ^ Date of the FX quotation. + -> Scientific + -- ^ FX quotation rate, expected to be positive. -> m (FxQuote s) mkFxQuoteError ccy1 ccy2 date rate = either (throwError . (<>) "Can not create FX Rate. Error was: ") pure $ do @@ -76,6 +85,8 @@ -- -- The rate is expected to be a positive value. If it is not, the function will -- fail. +-- +-- >>> :set -XTypeApplications -- >>> mkFxQuoteFail @Maybe @2 "EUR" "USD" (read "2021-12-31") 1.16 -- Just (MkFxQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16}) -- >>> mkFxQuoteFail @Maybe @2 "EUR" "USD" (read "2021-12-31") (-1.16) @@ -83,10 +94,14 @@ mkFxQuoteFail :: MonadFail m => KnownNat s - => Currency -- ^ Base currency (from) of the FX quotation. - -> Currency -- ^ Quote currency (to) of the FX quotation. - -> Day -- ^ Date of the FX quotation. - -> Scientific -- ^ FX quotation rate, expected to be positive. + => Currency + -- ^ Base currency (from) of the FX quotation. + -> Currency + -- ^ Quote currency (to) of the FX quotation. + -> Day + -- ^ Date of the FX quotation. + -> Scientific + -- ^ FX quotation rate, expected to be positive. -> m (FxQuote s) mkFxQuoteFail ccy1 ccy2 date = either (fail . T.unpack) pure . mkFxQuoteError ccy1 ccy2 date @@ -94,6 +109,7 @@ -- | Unsafe 'FxQuote' constructor that 'error's if it fails. -- +-- >>> :set -XTypeApplications -- >>> mkFxQuoteUnsafe @2 "EUR" "USD" (read "2021-12-31") 1.16 -- MkFxQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16} -- >>> mkFxQuoteUnsafe @2 "EUR" "USD" (read "2021-12-31") (-1.16) @@ -102,18 +118,25 @@ -- ... mkFxQuoteUnsafe :: KnownNat s - => Currency -- ^ Base currency (from) of the FX quotation. - -> Currency -- ^ Quote currency (to) of the FX quotation. - -> Day -- ^ Date of the FX quotation. - -> Scientific -- ^ FX quotation rate, expected to be positive. + => Currency + -- ^ Base currency (from) of the FX quotation. + -> Currency + -- ^ Quote currency (to) of the FX quotation. + -> Day + -- ^ Date of the FX quotation. + -> Scientific + -- ^ FX quotation rate, expected to be positive. -> FxQuote s mkFxQuoteUnsafe ccy1 ccy2 date = either (error . T.unpack) id . mkFxQuoteError ccy1 ccy2 date -- * FX Rate Quotation Database + + -- $fxRateQuotationDatabase -- +-- >>> :set -XTypeApplications -- >>> let database = addFxQuotes [mkFxQuoteUnsafe @8 "EUR" "USD" (read "2021-12-31") 1.13, mkFxQuoteUnsafe @8 "EUR" "TRY" (read "2021-12-31") 15.14] emptyFxQuoteDatabase -- >>> findFxQuote database (CurrencyPair "EUR" "USD") (read "2021-12-31") -- Just (MkFxQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.13000000}) @@ -132,21 +155,24 @@ -- | Type encoding for FX rate quotation database for a 'CurrencyPair'. data FxQuotePairDatabase (n :: Nat) = FxQuotePairDatabase - { fxQuotePairDatabasePair :: !CurrencyPair + { fxQuotePairDatabasePair :: !CurrencyPair , fxQuotePairDatabaseTable :: !(SM.Map Day (FxQuote n)) , fxQuotePairDatabaseSince :: !Day , fxQuotePairDatabaseUntil :: !Day } - deriving Show + deriving (Show) -- | Attempts to find and return the FX quotation for a given 'CurrencyPair' as -- of a give 'Day' in a given 'FxQuoteDatabase'. findFxQuote :: KnownNat n - => FxQuoteDatabase n -- ^ FX quotation database to perform the lookup on. - -> CurrencyPair -- ^ Currency pair we are looking for the quotation for. - -> Day -- ^ Date the quotation we look for is valid as of. + => FxQuoteDatabase n + -- ^ FX quotation database to perform the lookup on. + -> CurrencyPair + -- ^ Currency pair we are looking for the quotation for. + -> Day + -- ^ Date the quotation we look for is valid as of. -> Maybe (FxQuote n) findFxQuote db pair date = SM.lookup pair db >>= findFxQuoteAux date @@ -163,6 +189,7 @@ -- | Returns empty FX rate quotation database. -- +-- >>> :set -XTypeApplications -- >>> emptyFxQuoteDatabase @8 -- fromList [] emptyFxQuoteDatabase @@ -173,6 +200,7 @@ -- | Adds a list of FX rate quotations to the given database. -- +-- >>> :set -XTypeApplications -- >>> let database = emptyFxQuoteDatabase @8 -- >>> addFxQuotes [] database -- fromList [] @@ -195,12 +223,11 @@ -> FxQuoteDatabase n -> FxQuoteDatabase n addFxQuote quote@(MkFxQuote pair _ _) database = case SM.lookup pair database of - Nothing -> SM.insert pair (initFxQuotePairDatabase quote) database + Nothing -> SM.insert pair (initFxQuotePairDatabase quote) database Just fpd -> SM.insert pair (updateFxQuotePairDatabase quote fpd) database -- * Internal --- $internal -- | Initializes FX quote pair database with the given FX quote. @@ -210,7 +237,7 @@ -> FxQuotePairDatabase n initFxQuotePairDatabase quote@(MkFxQuote pair date _) = FxQuotePairDatabase - { fxQuotePairDatabasePair = pair + { fxQuotePairDatabasePair = pair , fxQuotePairDatabaseTable = SM.singleton date quote , fxQuotePairDatabaseSince = date , fxQuotePairDatabaseUntil = date diff --git a/src/Haspara/Internal/Aeson.hs b/src/Haspara/Internal/Aeson.hs --- a/src/Haspara/Internal/Aeson.hs +++ b/src/Haspara/Internal/Aeson.hs @@ -1,11 +1,10 @@ -- | This module provides helper definitions for "Data.Aeson". - module Haspara.Internal.Aeson where import qualified Data.Aeson as Aeson -import qualified Data.Char as C -import Data.List (stripPrefix) -import Data.Maybe (fromMaybe) +import qualified Data.Char as C +import Data.List (stripPrefix) +import Data.Maybe (fromMaybe) -- | Common Aeson encoding/decoding options. @@ -15,10 +14,11 @@ { Aeson.omitNothingFields = True , Aeson.fieldLabelModifier = \l -> Aeson.camelTo2 '_' . fromMaybe l $ stripPrefix prefix l , Aeson.constructorTagModifier = \l -> Aeson.camelTo2 '_' . fromMaybe l $ stripPrefix prefix l - , Aeson.sumEncoding = Aeson.TaggedObject - { Aeson.tagFieldName = "type" - , Aeson.contentsFieldName = "value" - } + , Aeson.sumEncoding = + Aeson.TaggedObject + { Aeson.tagFieldName = "type" + , Aeson.contentsFieldName = "value" + } } diff --git a/src/Haspara/Monetary.hs b/src/Haspara/Monetary.hs --- a/src/Haspara/Monetary.hs +++ b/src/Haspara/Monetary.hs @@ -1,24 +1,27 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} + -- | This module provides definitions for modeling and working with monetary -- values. - -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} - module Haspara.Monetary where -import Control.Exception (Exception) -import Control.Monad (when) -import Control.Monad.Catch (MonadThrow(throwM)) -import qualified Data.Aeson as Aeson -import Data.Time (Day) -import GHC.Generics (Generic) -import GHC.Stack (HasCallStack) -import GHC.TypeLits (KnownNat, Nat) -import Haspara.Currency (Currency, CurrencyPair(..)) -import Haspara.FxQuote (FxQuote(..)) -import Haspara.Internal.Aeson (commonAesonOptions) -import Haspara.Quantity (Quantity, times) -import Refined (unrefine) +import Control.Exception (Exception) +import Control.Monad (when) +import Control.Monad.Catch (MonadThrow (throwM)) +import qualified Data.Aeson as Aeson +import Data.Time (Day) +import GHC.Generics (Generic) +import GHC.Stack (HasCallStack) +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Currency (Currency, CurrencyPair (..)) +import Haspara.FxQuote (FxQuote (..)) +import Haspara.Internal.Aeson (commonAesonOptions) +import Haspara.Quantity (Quantity, times) +import Refined (unrefine) -- | Type encoding for dated monetary values. @@ -29,7 +32,7 @@ -- 2. the currency of the monetary value, and -- 3. the quantity of the monetary value. data Money (s :: Nat) = Money - { moneyDate :: !Day + { moneyDate :: !Day , moneyCurrency :: !Currency , moneyQuantity :: !(Quantity s) } @@ -57,6 +60,7 @@ -> Money s -> m (Money s) + -- | Converts the given monetary value in one currency to another currency as -- of the given date. -- @@ -106,21 +110,25 @@ -- | Indicates that we received a currency other than the expected currency. IncompatibleCurrenciesException :: HasCallStack - => Currency -- ^ Expected currency - -> Currency -- ^ Received currency + => Currency + -- ^ Expected currency + -> Currency + -- ^ Received currency -> MonetaryException - -- | Indicates that we received a currency other than the expected currency. IncompatibleDatesException :: HasCallStack - => Day -- ^ Date on and onwards of interest - -> Day -- ^ Date received + => Day + -- ^ Date on and onwards of interest + -> Day + -- ^ Date received -> MonetaryException - -- | Indicates that we received a currency other than the expected currency. InconsistentFxQuoteException - :: forall (s :: Nat). (HasCallStack, KnownNat s) - => FxQuote s -- ^ FX rate quotation that is interpreted as inconsistent. + :: forall (s :: Nat) + . (HasCallStack, KnownNat s) + => FxQuote s + -- ^ FX rate quotation that is interpreted as inconsistent. -> MonetaryException diff --git a/src/Haspara/Quantity.hs b/src/Haspara/Quantity.hs --- a/src/Haspara/Quantity.hs +++ b/src/Haspara/Quantity.hs @@ -1,28 +1,35 @@ --- | This module provides definitions for modeling and working with quantities --- with fixed decimal points. - {-# LANGUAGE DataKinds #-} - +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} +-- | This module provides definitions for modeling and working with quantities +-- with fixed decimal points. module Haspara.Quantity where -import Control.Applicative (liftA2) -import Control.Monad.Except (MonadError(throwError)) -import qualified Data.Aeson as Aeson -import Data.Either (fromRight) -import Data.Proxy (Proxy(..)) -import Data.Scientific (FPFormat(Fixed), Scientific, formatScientific) -import GHC.Generics (Generic) -import GHC.TypeLits (KnownNat, Nat, natVal, type (+)) +import Control.Applicative (liftA2) +import Control.Monad.Except (MonadError (throwError)) +import qualified Data.Aeson as Aeson +import Data.Either (fromRight) +import Data.Proxy (Proxy (..)) +import Data.Scientific (FPFormat (Fixed), Scientific, formatScientific) +import GHC.Generics (Generic) +import GHC.TypeLits (KnownNat, Nat, natVal, type (+)) import qualified Language.Haskell.TH.Syntax as TH -import qualified Numeric.Decimal as D -import Refined (NonNegative, Refined, unrefine) -import Refined.Unsafe (unsafeRefine) +import qualified Numeric.Decimal as D +import Refined (NonNegative, Refined, unrefine) +import Refined.Unsafe (unsafeRefine) -- * Data Definition --- $dataDefinition -- | Type encoding for quantity values with a given scaling (digits after the @@ -56,7 +63,7 @@ -- Right 0.42 -- >>> mkQuantityLossless 0.415 :: Either String (Quantity 2) -- Left "Underflow while trying to create quantity: 0.415" -newtype Quantity (s :: Nat) = MkQuantity { unQuantity :: D.Decimal D.RoundHalfEven s Integer } +newtype Quantity (s :: Nat) = MkQuantity {unQuantity :: D.Decimal D.RoundHalfEven s Integer} deriving (Eq, Ord, Generic, Num) @@ -76,6 +83,7 @@ -- | 'Aeson.FromJSON' instance for 'Quantity'. -- +-- >>> :set -XOverloadedStrings -- >>> Aeson.decode "0.42" :: Maybe (Quantity 2) -- Just 0.42 -- >>> Aeson.decode "0.415" :: Maybe (Quantity 2) @@ -159,7 +167,6 @@ -- * Smart Constructors --- $smartConstructors -- | Constructs 'Quantity' values from 'Scientific' values in a lossy way. @@ -214,7 +221,7 @@ -- 0.160 mkQuantity :: KnownNat s => Scientific -> Quantity s mkQuantity s = case mkQuantityLossless s of - Left _ -> mkQuantityAux s + Left _ -> mkQuantityAux s Right dv -> dv @@ -267,7 +274,6 @@ -- * Utilities --- $utilities -- | Rounds given quantity by @k@ digits. @@ -296,6 +302,68 @@ timesLossless (MkQuantity d1) (MkQuantity d2) = MkQuantity (D.timesDecimal d1 d2) +-- | Divides two quantities with same scales with possible loss. +-- +-- >>> divide (mkQuantity 10 :: Quantity 2) (mkQuantity 3 :: Quantity 2) +-- Just 3.33 +-- >>> divide (mkQuantity 0.42 :: Quantity 2) (mkQuantity 0 :: Quantity 2) +-- Nothing +-- >>> divide (mkQuantity 0.42 :: Quantity 2) (mkQuantity 1 :: Quantity 2) +-- Just 0.42 +-- >>> divide (mkQuantity 0.42 :: Quantity 2) (mkQuantity 0.42 :: Quantity 2) +-- Just 1.00 +-- >>> divide (mkQuantity 0.42 :: Quantity 2) (mkQuantity 0.21 :: Quantity 2) +-- Just 2.00 +-- >>> divide (mkQuantity 0.42 :: Quantity 2) (mkQuantity (-0.21) :: Quantity 2) +-- Just -2.00 +divide :: (KnownNat s) => Quantity s -> Quantity s -> Maybe (Quantity s) +divide (MkQuantity d1) (MkQuantity d2) = MkQuantity <$> D.divideDecimalWithRounding d1 d2 + + +-- | Divides two quantities with different scales with possible loss preserving +-- dividend's precision. +-- +-- >>> divideL (mkQuantity 10 :: Quantity 1) (mkQuantity 3 :: Quantity 2) +-- Just 3.3 +-- >>> divideL (mkQuantity 10 :: Quantity 2) (mkQuantity 3 :: Quantity 2) +-- Just 3.33 +-- >>> divideL (mkQuantity 10 :: Quantity 3) (mkQuantity 3 :: Quantity 2) +-- Just 3.333 +divideL :: (KnownNat s, KnownNat k) => Quantity s -> Quantity k -> Maybe (Quantity s) +divideL (MkQuantity d1) d2 = MkQuantity <$> D.divideDecimalWithRounding d1 (unQuantity $ 1 `times` d2) + + +-- | Divides two quantities with different scales with possible loss preserving +-- divisor's precision. +-- +-- >>> divideR (mkQuantity 10 :: Quantity 2) (mkQuantity 3 :: Quantity 1) +-- Just 3.3 +-- >>> divideR (mkQuantity 10 :: Quantity 2) (mkQuantity 3 :: Quantity 2) +-- Just 3.33 +-- >>> divideR (mkQuantity 10 :: Quantity 2) (mkQuantity 3 :: Quantity 3) +-- Just 3.333 +divideR :: (KnownNat s, KnownNat k) => Quantity s -> Quantity k -> Maybe (Quantity k) +divideR d1 (MkQuantity d2) = MkQuantity <$> D.divideDecimalWithRounding (unQuantity $ 1 `times` d1) d2 + + +-- | Divides two quantities with different scales with possible loss with a +-- target precision of result. +-- +-- >>> :set -XTypeApplications +-- >>> divideD @0 (mkQuantity 10 :: Quantity 2) (mkQuantity 3 :: Quantity 2) +-- Just 3 +-- >>> divideD @1 (mkQuantity 10 :: Quantity 2) (mkQuantity 3 :: Quantity 2) +-- Just 3.3 +-- >>> divideD @2 (mkQuantity 10 :: Quantity 2) (mkQuantity 3 :: Quantity 2) +-- Just 3.33 +-- >>> divideD @3 (mkQuantity 10 :: Quantity 2) (mkQuantity 3 :: Quantity 2) +-- Just 3.333 +-- >>> divideD @8 (mkQuantity 1111 :: Quantity 2) (mkQuantity 3333 :: Quantity 12) +-- Just 0.33333333 +divideD :: (KnownNat r, KnownNat s, KnownNat k) => Quantity s -> Quantity k -> Maybe (Quantity r) +divideD d1 d2 = MkQuantity <$> D.divideDecimalWithRounding (unQuantity $ 1 `times` d1) (unQuantity $ 1 `times` d2) + + -- | Returns the total of a list of unsigned quantities. -- -- >>> sumUnsignedQuantity [] :: UnsignedQuantity 2 @@ -323,7 +391,6 @@ -- * Internal --- $internal -- | Auxiliary function for constructing 'Quantity' values. diff --git a/src/Haspara/TH.hs b/src/Haspara/TH.hs --- a/src/Haspara/TH.hs +++ b/src/Haspara/TH.hs @@ -1,19 +1,22 @@ -- | This module provides template-haskell functions for various "Haspara" -- definitions. - module Haspara.TH where -import Data.Function (fix) -import Data.Scientific (Scientific) -import qualified Data.Text as T -import GHC.TypeLits (KnownNat) -import Haspara.Currency (Currency, CurrencyPair(CurrencyPair), mkCurrencyError) -import Haspara.Quantity (Quantity, mkQuantityLossless) -import qualified Language.Haskell.TH.Syntax as TH +import Data.Function (fix) +import Data.Scientific (Scientific) +import qualified Data.Text as T +import GHC.TypeLits (KnownNat) +import Haspara.Currency (Currency, CurrencyPair (CurrencyPair), mkCurrencyError) +import Haspara.Quantity (Quantity, mkQuantityLossless) +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Syntax as TH.Syntax -- | Constructs a 'Quantity' value at compile-time using @-XTemplateHaskell@. -- +-- >>> :set -XDataKinds +-- >>> :set -XOverloadedStrings +-- >>> :set -XTemplateHaskell -- >>> $$(quantityTH 0.00) :: Quantity 2 -- 0.00 -- >>> $$(quantityTH 0.09) :: Quantity 2 @@ -24,39 +27,43 @@ -- ... -- >>> $$(quantityTH 0.009) :: Quantity 3 -- 0.009 -quantityTH :: KnownNat s => Scientific -> TH.Q (TH.TExp (Quantity s)) -quantityTH = fix $ \loop -> fmap TH.TExp . either (fail . show) TH.lift . quantityWE (loop undefined) +quantityTH :: KnownNat s => Scientific -> TH.Code TH.Q (Quantity s) +quantityTH = fix $ \loop -> either (TH.Syntax.liftCode . fail . show) TH.Syntax.liftTyped . quantityWE (loop undefined) where -- This provides a work-around for the type-inference due the `s` type parameter. -- Trick is borrowed from the Haskell `refined` library. - quantityWE :: KnownNat s => TH.Q (TH.TExp (Quantity s)) -> Scientific -> Either String (Quantity s) + quantityWE :: KnownNat s => TH.Code TH.Q (Quantity s) -> Scientific -> Either String (Quantity s) quantityWE = const mkQuantityLossless -- | Constructs a 'Currency' value at compile-time using @-XTemplateHaskell@. -- +-- >>> :set -XOverloadedStrings +-- >>> :set -XTemplateHaskell -- >>> $$(currencyTH "USD") -- USD -- >>> $$(currencyTH "usd") -- ... -- ...Currency code error! Expecting at least 3 uppercase ASCII letters, but received: usd -- ... -currencyTH :: T.Text -> TH.Q (TH.TExp Currency) -currencyTH = either (fail . T.unpack) (fmap TH.TExp . TH.lift) . mkCurrencyError +currencyTH :: T.Text -> TH.Code TH.Q Currency +currencyTH = either (TH.Syntax.liftCode . fail . T.unpack) TH.Syntax.liftTyped . mkCurrencyError -- | Constructs a 'CurrencyPair' value at compile-time using @-XTemplateHaskell@. -- +-- >>> :set -XOverloadedStrings +-- >>> :set -XTemplateHaskell -- >>> $$(currencyPairTH "EUR" "USD") -- EUR/USD -- >>> $$(currencyPairTH "USD" "USD") -- USD/USD -- >>> $$(currencyPairTH "USD" "eur") -- ... --- ...Currency code error! Expecting at least 3 uppercase ASCII letters, but received: eur +-- ... Currency code error! Expecting at least 3 uppercase ASCII letters, but received: eur -- ... -currencyPairTH :: T.Text -> T.Text -> TH.Q (TH.TExp CurrencyPair) -currencyPairTH = (either (fail . T.unpack) (fmap TH.TExp . TH.lift) .) . mkPair +currencyPairTH :: T.Text -> T.Text -> TH.Code TH.Q CurrencyPair +currencyPairTH cf ct = either (TH.Syntax.liftCode . fail . T.unpack) TH.Syntax.liftTyped (mkPair cf ct) where mkPair :: T.Text -> T.Text -> Either T.Text CurrencyPair mkPair x y = CurrencyPair <$> mkCurrencyError x <*> mkCurrencyError y diff --git a/test/Tests/Haspara/Accounting/Inventory.hs b/test/Tests/Haspara/Accounting/Inventory.hs new file mode 100644 --- /dev/null +++ b/test/Tests/Haspara/Accounting/Inventory.hs @@ -0,0 +1,182 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} + +module Tests.Haspara.Accounting.Inventory where + +import Data.Default (def) +import Data.Foldable (foldl') +import qualified Data.Sequence as Seq +import qualified Data.Time as Time +import Haspara.Accounting.Inventory (Inventory (..), InventoryEvent (..), InventoryHistoryItem (..), updateInventory, updateInventoryVP) +import Haspara.Quantity (Quantity) +import Test.Hspec (SpecWith, describe, hspec, it, shouldBe) + + +-- * Core Definitions + + +-- | Type definition for the inventory type used in this module. +type TestInventory = Inventory 8 12 2 + + +-- | Type definition for the inventory type used in this module. +type TestInventoryEvent = InventoryEvent 8 12 + + +-- | Type definition for the inventory history item used in this module. +type TestInventoryHistoryItem = InventoryHistoryItem 8 12 2 + + +-- | Initial inventory. +initInventory :: TestInventory +initInventory = def @TestInventory + + +testInventory :: IO () +testInventory = hspec $ do + describe "Inventory Functionality" $ do + testInitialInventory + testInitialInventoryEvent + testInventoryCloseProfit + testInventoryAlternate + testInventoryScenario1 + + +-- * Test Specs + + +testInitialInventory :: SpecWith () +testInitialInventory = + it "initial inventory is empty" $ do + inventoryTotal initInventory `shouldBe` 0 + inventoryCurrent initInventory `shouldBe` mempty + inventoryHistory initInventory `shouldBe` mempty + + +testInitialInventoryEvent :: SpecWith () +testInitialInventoryEvent = do + it "can add initial inventory increment event" $ do + let (historyItem, newInventory) = updateInventoryVP (day 1) 1 10 initInventory + + inventoryTotal newInventory `shouldBe` 10 + length (inventoryCurrent newInventory) `shouldBe` 1 + inventoryHistory newInventory `shouldBe` mempty + historyItem `shouldBe` mempty + + it "can add initial inventory decrement event" $ do + let (historyItem, newInventory) = updateInventoryVP (day 1) 1 (-10) initInventory + + inventoryTotal newInventory `shouldBe` (-10) + length (inventoryCurrent newInventory) `shouldBe` 1 + inventoryHistory newInventory `shouldBe` mempty + historyItem `shouldBe` mempty + + +testInventoryCloseProfit :: SpecWith () +testInventoryCloseProfit = do + it "can close initial stock item with no-profit" $ do + let (historyItem, newInventory) = updateManyVP [(day 1, 1, 10), (day 2, 1, -10)] + + inventoryTotal newInventory `shouldBe` 0 + inventoryCurrent newInventory `shouldBe` mempty + length (inventoryHistory newInventory) `shouldBe` 1 + length historyItem `shouldBe` 1 + foldl' (\x y -> x + inventoryHistoryItemPnl y) 0 historyItem `shouldBe` 0 + + it "can close initial stock item with profit" $ do + let (historyItem, newInventory) = updateManyVP [(day 1, 1, 10), (day 2, 2, -10)] + + inventoryTotal newInventory `shouldBe` 0 + inventoryCurrent newInventory `shouldBe` mempty + length (inventoryHistory newInventory) `shouldBe` 1 + length historyItem `shouldBe` 1 + foldl' (\x y -> x + inventoryHistoryItemPnl y) 0 historyItem `shouldBe` 10 + + it "can close initial stock item with loss" $ do + let (historyItem, newInventory) = updateManyVP [(day 1, 2, 10), (day 2, 1, -10)] + + inventoryTotal newInventory `shouldBe` 0 + inventoryCurrent newInventory `shouldBe` mempty + length (inventoryHistory newInventory) `shouldBe` 1 + length historyItem `shouldBe` 1 + foldl' (\x y -> x + inventoryHistoryItemPnl y) 0 historyItem `shouldBe` -10 + + +testInventoryAlternate :: SpecWith () +testInventoryAlternate = do + it "can switch from long to short" $ do + let (historyItem, newInventory) = updateManyVP [(day 1, 1, 10), (day 2, 1, -15)] + + inventoryTotal newInventory `shouldBe` -5 + length (inventoryCurrent newInventory) `shouldBe` 1 + length (inventoryHistory newInventory) `shouldBe` 1 + length historyItem `shouldBe` 1 + foldl' (\x y -> x + inventoryHistoryItemPnl y) 0 historyItem `shouldBe` 0 + + it "can switch from short to long" $ do + let (historyItem, newInventory) = updateManyVP [(day 1, 1, -10), (day 2, 1, 15)] + + inventoryTotal newInventory `shouldBe` 5 + length (inventoryCurrent newInventory) `shouldBe` 1 + length (inventoryHistory newInventory) `shouldBe` 1 + length historyItem `shouldBe` 1 + foldl' (\x y -> x + inventoryHistoryItemPnl y) 0 historyItem `shouldBe` 0 + + it "can alternate between long and short" $ do + let (historyItem, newInventory) = updateManyVP [(day 1, 1, 10), (day 2, 1, -15), (day 3, 1, 20)] + + inventoryTotal newInventory `shouldBe` 15 + length (inventoryCurrent newInventory) `shouldBe` 1 + length (inventoryHistory newInventory) `shouldBe` 2 + length historyItem `shouldBe` 1 + foldl' (\x y -> x + inventoryHistoryItemPnl y) 0 historyItem `shouldBe` 0 + + +testInventoryScenario1 :: SpecWith () +testInventoryScenario1 = do + it "can perform complex stuff" $ do + let events = + [ (day 1, 1, 10) + , (day 2, 2, -15) + , (day 3, 1, 0) + , (day 4, 1, 5) + , (day 5, 1, 0) + , (day 6, 1, 5) + , (day 7, 1, -5) + , (day 8, 1, -15) + , (day 9, 1, -10) + , (day 10, 1, 25) + , (day 11, 1, 0) + , (day 12, 1, 15) + , (day 13, 2, 10) + , (day 14, 3, -10) + , (day 15, 4, -15) + ] + + let (historyItem, newInventory) = updateManyVP events + + inventoryTotal newInventory `shouldBe` 0 + inventoryTotal newInventory `shouldBe` foldl' (\a (_, _, x) -> a + x) 0 events + length (inventoryCurrent newInventory) `shouldBe` 0 + length (inventoryHistory newInventory) `shouldBe` 8 + length historyItem `shouldBe` 2 + foldl' (\x y -> x + inventoryHistoryItemPnl y) 0 (inventoryHistory newInventory) `shouldBe` 70 + + +-- * Helper Functions + + +day :: Integer -> Time.Day +day t = Time.addDays t (read "2020-01-01") + + +updateMany + :: [TestInventoryEvent] + -> (Seq.Seq TestInventoryHistoryItem, TestInventory) +updateMany = foldl' (\(_, s) i -> updateInventory i s) (mempty, initInventory) + + +updateManyVP + :: [(Time.Day, Quantity 8, Quantity 12)] + -> (Seq.Seq TestInventoryHistoryItem, TestInventory) +updateManyVP = updateMany . fmap (\(x, y, z) -> InventoryEvent x y z) diff --git a/test/doctest.hs b/test/doctest.hs deleted file mode 100644 --- a/test/doctest.hs +++ /dev/null @@ -1,49 +0,0 @@ -import Test.DocTest (doctest) - - -main :: IO () -main = doctest - [ "-XDataKinds" - , "-XOverloadedStrings" - , "-XTemplateHaskell" - -- Begin: Haskell 2021 Extensions List - , "-XBangPatterns" - , "-XBinaryLiterals" - , "-XConstrainedClassMethods" - , "-XConstraintKinds" - , "-XDeriveDataTypeable" - , "-XDeriveFoldable" - , "-XDeriveFunctor" - , "-XDeriveGeneric" - , "-XDeriveLift" - , "-XDeriveTraversable" - , "-XEmptyCase" - , "-XEmptyDataDeriving" - , "-XExistentialQuantification" - , "-XExplicitForAll" - , "-XFlexibleContexts" - , "-XFlexibleInstances" - , "-XGADTSyntax" - , "-XGeneralisedNewtypeDeriving" - , "-XHexFloatLiterals" - , "-XImportQualifiedPost" - , "-XInstanceSigs" - , "-XKindSignatures" - , "-XMultiParamTypeClasses" - , "-XNamedFieldPuns" - , "-XNamedWildCards" - , "-XNumericUnderscores" - , "-XPolyKinds" - , "-XPostfixOperators" - , "-XRankNTypes" - , "-XScopedTypeVariables" - , "-XStandaloneDeriving" - , "-XStandaloneKindSignatures" - , "-XTupleSections" - , "-XTypeApplications" - , "-XTypeOperators" - , "-XTypeSynonymInstances" - -- End: Haskell 2021 Extensions List - , "-isrc" - , "src" - ] diff --git a/test/test.hs b/test/test.hs new file mode 100644 --- /dev/null +++ b/test/test.hs @@ -0,0 +1,6 @@ +import Tests.Haspara.Accounting.Inventory (testInventory) + + +main :: IO () +main = do + testInventory