haspara 0.0.0.5 → 0.0.0.7

raw patch · 23 files changed

+1255/−554 lines, 23 filesdep +data-defaultdep +hspecdep ~containersdep ~time

Dependencies added: data-default, hspec

Dependency ranges changed: containers, time

Files

• CHANGELOG.md +50/−1
• README.md +25/−50
• doctest.hs +7/−0
• haspara.cabal +22/−53
• src/Haspara.hs +7/−7
• src/Haspara/Accounting.hs +10/−10
• src/Haspara/Accounting/Account.hs +18/−18
• src/Haspara/Accounting/Amount.hs +47/−42
• src/Haspara/Accounting/Balance.hs +79/−51
• src/Haspara/Accounting/Inventory.hs +300/−0
• src/Haspara/Accounting/Journal.hs +71/−39
• src/Haspara/Accounting/Ledger.hs +128/−58
• src/Haspara/Accounting/Side.hs +24/−22
• src/Haspara/Accounting/TrialBalance.hs +18/−18
• src/Haspara/Currency.hs +40/−24
• src/Haspara/FxQuote.hs +68/−41
• src/Haspara/Internal/Aeson.hs +8/−8
• src/Haspara/Monetary.hs +34/−26
• src/Haspara/Quantity.hs +88/−21
• src/Haspara/TH.hs +23/−16
• test/Tests/Haspara/Accounting/Inventory.hs +182/−0
• test/doctest.hs +0/−49
• test/test.hs +6/−0

@@ -2,10 +2,57 @@ ## [Unreleased]  +<a name="0.0.0.7"></a>+## [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+++<a name="0.0.0.6"></a>+## [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++ <a name="0.0.0.5"></a> ## [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

@@ -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 <NEW-VERSION> -o CHANGELOG.md     ``` -1. Commit, tag and push:+5. Commit, tag and push:      ```sh     git commit -am "chore(release): <NEW-VERSION>"@@ -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 <path to .tar.gz archive>     ``` -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 <UPCOMING-VERSION>"-    git push+    cabal upload --publish <path to .tar.gz archive>     ```  ## License

@@ -0,0 +1,7 @@+import Test.DocTest (doctest)+++main :: IO ()+main =+  doctest+    ["-isrc" , "src"]

@@ -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 <https://github.com/telostat/haspara#readme> 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

@@ -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+

@@ -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+

@@ -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)

@@ -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

@@ -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)  

@@ -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

@@ -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+            }     }

@@ -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+          }+      ]

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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"+          }     }  

@@ -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  

@@ -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.

@@ -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

@@ -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)

@@ -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"-  ]

@@ -0,0 +1,6 @@+import Tests.Haspara.Accounting.Inventory (testInventory)+++main :: IO ()+main = do+  testInventory