haspara 0.0.0.1 → 0.0.0.2

raw patch · 30 files changed

+1378/−1629 lines, 30 filesdep +containersdep +exceptionsdep −unordered-containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: containers, exceptions

Dependencies removed: unordered-containers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +27/−1
• README.md +112/−2
• haspara.cabal +23/−21
• src/Haspara.hs +9/−8
• src/Haspara/Accounting.hs +13/−8
• src/Haspara/Accounting/Account.hs +97/−16
• src/Haspara/Accounting/AccountKind.hs +0/−75
• src/Haspara/Accounting/Entry.hs +0/−109
• src/Haspara/Accounting/Event.hs +38/−23
• src/Haspara/Accounting/Ledger.hs +162/−13
• src/Haspara/Accounting/Posting.hs +0/−52
• src/Haspara/Accounting/Types.hs +0/−7
• src/Haspara/Currency.hs +188/−46
• src/Haspara/Date.hs +0/−55
• src/Haspara/FXQuote.hs +0/−32
• src/Haspara/FxQuote.hs +142/−0
• src/Haspara/Id.hs +0/−6
• src/Haspara/Internal/Aeson.hs +14/−0
• src/Haspara/Internal/Currency.hs +0/−158
• src/Haspara/Internal/Date.hs +0/−195
• src/Haspara/Internal/FXQuote.hs +0/−121
• src/Haspara/Internal/FXQuoteDatabase.hs +0/−35
• src/Haspara/Internal/Id.hs +0/−67
• src/Haspara/Internal/Money.hs +0/−116
• src/Haspara/Internal/Quantity.hs +0/−365
• src/Haspara/Monetary.hs +121/−0
• src/Haspara/Money.hs +0/−38
• src/Haspara/Quantity.hs +375/−23
• src/Haspara/TH.hs +11/−35
• test/doctest.hs +46/−2

@@ -2,11 +2,36 @@ ## [Unreleased]  +<a name="0.0.0.2"></a>+## [0.0.0.2] - 2022-03-03+### Chore+- bump development version to 0.0.0.2+- **dev:** add Weeder configuration+- **dev:** add HLint configuration+- **dev:** produce .hie files during compilation+- **docs:** update README.md, fix haddock warnings++### Refactor+- revisit Haspara.Accounting module and its submodules+- refactor and move definitions from Haspara.Money to Haspara.Monetary+- revisit Haspara.FxQuote module+- revisit Haspara.Quantity module+- revisit Haspara.Currency module+- adopt Haskell 2021 extensions+- move definitions from Haspara.Internal.* to Haspara.*+- remove Date type in favour of Day type+- remove Id type and related definitions++### Pull Requests+- Merge pull request [#5](https://github.com/telostat/haspara/issues/5) from telostat/slim-down++ <a name="0.0.0.1"></a> ## [0.0.0.1] - 2022-03-01 ### Chore - bump development version to 0.0.0.1 - **deps:** upgrade to lts-18.27+- **release:** 0.0.0.1  ### Feat - add rudimentary accounting functionality@@ -37,5 +62,6 @@ - Merge pull request [#1](https://github.com/telostat/haspara/issues/1) from telostat/init  -[Unreleased]: https://github.com/telostat/haspara/compare/0.0.0.1...HEAD+[Unreleased]: https://github.com/telostat/haspara/compare/0.0.0.2...HEAD+[0.0.0.2]: https://github.com/telostat/haspara/compare/0.0.0.1...0.0.0.2 [0.0.0.1]: https://github.com/telostat/haspara/compare/0.0.0.0...0.0.0.1

@@ -10,8 +10,118 @@ > reach the first minor version. Until then, we will keep bumping the patch > version. -*haspara* is a Haskell library providing data definitions and functions to work-with monetary values.+*haspara* is a Haskell library that provides monetary definitions and a+rudimentary (and experimental) accounting functionality.++## Development++Before committing code to repository, reformat the code:++```sh+stylish-haskell -i -r src/+```++Compile the codebase, check warnings and errors:++```sh+stack test+stack build+stack haddock+```++Run [hlint](https://github.com/ndmitchell/hlint):++```sh+hlint src/+```++Run [weeder](https://hackage.haskell.org/package/weeder):++```sh+weeder --require-hs-files+```++## 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`:++    ```sh+    git merge --no-ff develop+    ```++1. Update the `version` information in [package.yaml](./package.yaml) if+   required and recompile the project to reflect the change on the `.cabal`+   file:++    ```sh+    stack build+    ```++1. Update [CHANGELOG.md](./CHANGELOG.md) file:++    ```sh+    git-chglog --next-tag <NEW-VERSION> -o CHANGELOG.md+    ```++1. Commit, tag and push:++    ```sh+    git commit -am "chore(release): <NEW-VERSION>"+    git tag -a -m "Release <NEW-VERSION>" <NEW-VERSION>+    git push --follow-tags origin main+    ```++1. Release to Hackage as a candidate first and check the result:++    ```sh+    stack upload --pvp-bounds both --candidate .+    ```++1. If the candidate package release works fine, release to Hackage:++    ```sh+    stack upload --pvp-bounds both .+    ```++1. Checkout to `develop` and rebase onto `main`:++    ```sh+    git checkout develop+    git rebase main+    ```++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:++    ```sh+    git commit -am "chore: bump development version to <UPCOMING-VERSION>"+    git push+    ```  ## License 

@@ -1,6 +1,6 @@ cabal-version:      1.12 name:               haspara-version:            0.0.0.1+version:            0.0.0.2 license:            MIT license-file:       LICENSE copyright:          Copyright (c) 2021-2022 Telostat Pte Ltd@@ -29,36 +29,38 @@         Haspara         Haspara.Accounting         Haspara.Accounting.Account-        Haspara.Accounting.AccountKind-        Haspara.Accounting.Entry         Haspara.Accounting.Event         Haspara.Accounting.Ledger-        Haspara.Accounting.Posting-        Haspara.Accounting.Types         Haspara.Currency-        Haspara.Date-        Haspara.FXQuote-        Haspara.Id-        Haspara.Internal.Currency-        Haspara.Internal.Date-        Haspara.Internal.FXQuote-        Haspara.Internal.FXQuoteDatabase-        Haspara.Internal.Id-        Haspara.Internal.Money-        Haspara.Internal.Quantity-        Haspara.Money+        Haspara.FxQuote+        Haspara.Internal.Aeson+        Haspara.Monetary         Haspara.Quantity         Haspara.TH      hs-source-dirs:     src     other-modules:      Paths_haspara     default-language:   Haskell2010-    default-extensions: OverloadedStrings+    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 && <1.6,         base >=4.11 && <5,+        containers >=0.6.5.1 && <0.7,         deriving-aeson >=0.2.8 && <0.3,+        exceptions >=0.10.4 && <0.11,         hashable >=1.3.0.0 && <1.4,         megaparsec >=9.0.1 && <9.1,         mtl >=2.2.2 && <2.3,@@ -67,8 +69,7 @@         scientific >=0.3.7.0 && <0.4,         template-haskell >=2.16.0.0 && <2.17,         text >=1.2.4.1 && <1.3,-        time >=1.9.3 && <1.10,-        unordered-containers >=0.2.16.0 && <0.3+        time >=1.9.3 && <1.10  test-suite haspara-doctest     type:             exitcode-stdio-1.0@@ -80,8 +81,10 @@     build-depends:         aeson >=1.5.6.0 && <1.6,         base >=4.11 && <5,+        containers >=0.6.5.1 && <0.7,         deriving-aeson >=0.2.8 && <0.3,         doctest ==0.17.*,+        exceptions >=0.10.4 && <0.11,         hashable >=1.3.0.0 && <1.4,         haspara -any,         megaparsec >=9.0.1 && <9.1,@@ -91,5 +94,4 @@         scientific >=0.3.7.0 && <0.4,         template-haskell >=2.16.0.0 && <2.17,         text >=1.2.4.1 && <1.3,-        time >=1.9.3 && <1.10,-        unordered-containers >=0.2.16.0 && <0.3+        time >=1.9.3 && <1.10

@@ -1,15 +1,16 @@+-- | This module provides high-level definitions of @haspara@ library.+--+-- @haspara@ provides rudimentary (and experimental) accounting functionality,+-- too. These definitions can be found under "Haspara.Accounting" module.+ module Haspara   ( module Haspara.Currency-  , module Haspara.Date-  , module Haspara.FXQuote-  , module Haspara.Id-  , module Haspara.Money+  , module Haspara.FxQuote+  , module Haspara.Monetary   , module Haspara.Quantity   ) where  import Haspara.Currency-import Haspara.Date-import Haspara.FXQuote-import Haspara.Id-import Haspara.Money+import Haspara.FxQuote+import Haspara.Monetary import Haspara.Quantity

@@ -1,3 +1,6 @@+-- | This module provides a collection of definitions for a rudimentary+-- accounting functionality.+ module Haspara.Accounting   ( Account(..)   , AccountKind(..)@@ -12,7 +15,6 @@   , Posting(..)   , postingEvents   , post-  , UnsignedQuantity   , Ledger(..)   , LedgerItem(..)   , mkLedger@@ -25,18 +27,21 @@   ) where  -import Haspara.Accounting.Account     (Account(..))-import Haspara.Accounting.AccountKind (AccountKind(..), accountKindText)-import Haspara.Accounting.Entry+import Haspara.Accounting.Account (Account(..), AccountKind(..), accountKindText)+import Haspara.Accounting.Event   (Event(..), eventDate, eventObject, mkEvent, negateEvent)+import Haspara.Accounting.Ledger        ( Entry(..)+       , Ledger(..)+       , LedgerItem(..)+       , Posting(..)+       , addEntry        , buildEntry        , entryCredit        , entryDate        , entryDebit        , entryObject        , entryQuantity+       , mkLedger+       , post+       , postingEvents        )-import Haspara.Accounting.Event       (Event(..), eventDate, eventObject, mkEvent, negateEvent)-import Haspara.Accounting.Ledger      (Ledger(..), LedgerItem(..), addEntry, mkLedger)-import Haspara.Accounting.Posting     (Posting(..), post, postingEvents)-import Haspara.Accounting.Types       (UnsignedQuantity)

@@ -1,32 +1,113 @@-{-# LANGUAGE DataKinds     #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingVia   #-}+-- | 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 Data.Hashable                  (Hashable)-import Deriving.Aeson                 (CustomJSON(CustomJSON), FromJSON, Generic, ToJSON)-import Deriving.Aeson.Stock           (PrefixedSnake)-import Haspara.Accounting.AccountKind (AccountKind)+import           Data.Hashable          (Hashable)+import qualified Data.Text              as T+import qualified Deriving.Aeson         as DA+import qualified Deriving.Aeson.Stock   as DAS+import           Haspara.Internal.Aeson (UpperCase)  --- | Account model.+-- * Account Kind+-- $accountKind+++-- | Type encoding for ledger account type. ----- >>> import Haspara.Accounting.AccountKind (AccountKind(..))--- >>> import qualified Data.Aeson as Aeson+-- This type covers both balance sheet and income statement account types:+--+-- 1. For balance sheet accounts:+--     1. Asset ('AccountKindAsset')+--     2. Liability ('AccountKindLiability')+--     3. Equity ('AccountKindEquity')+-- 2. For income statement accounts:+--     1. Revenue ('AccountKindRevenue')+--     2. Expense ('AccountKindExpense')+--+-- 'Data.Aeson.FromJSON' and 'Data.Aeson.ToJSON' instances, too:+--+-- >>> Data.Aeson.decode @AccountKind "\"ASSET\""+-- Just AccountKindAsset+-- >>> Data.Aeson.decode @AccountKind "\"LIABILITY\""+-- Just AccountKindLiability+-- >>> Data.Aeson.decode @AccountKind "\"EQUITY\""+-- Just AccountKindEquity+-- >>> Data.Aeson.decode @AccountKind "\"REVENUE\""+-- Just AccountKindRevenue+-- >>> Data.Aeson.decode @AccountKind "\"EXPENSE\""+-- Just AccountKindExpense+-- >>> Data.Aeson.encode AccountKindAsset+-- "\"ASSET\""+-- >>> Data.Aeson.encode AccountKindLiability+-- "\"LIABILITY\""+-- >>> Data.Aeson.encode AccountKindEquity+-- "\"EQUITY\""+-- >>> Data.Aeson.encode AccountKindRevenue+-- "\"REVENUE\""+-- >>> Data.Aeson.encode AccountKindExpense+-- "\"EXPENSE\""+data AccountKind =+    AccountKindAsset+  | AccountKindLiability+  | AccountKindEquity+  | AccountKindRevenue+  | AccountKindExpense+  deriving (Enum, Eq, DA.Generic, Ord, Show)+  deriving (DA.FromJSON, DA.ToJSON) via DA.CustomJSON '[DA.ConstructorTagModifier (DA.StripPrefix "AccountKind", UpperCase)] AccountKind+++instance Hashable AccountKind+++-- | Provides textual representation of a given 'AccountKind'.+--+-- >>> accountKindText AccountKindAsset+-- "Asset"+-- >>> accountKindText AccountKindLiability+-- "Liability"+-- >>> accountKindText AccountKindEquity+-- "Equity"+-- >>> accountKindText AccountKindRevenue+-- "Revenue"+-- >>> accountKindText AccountKindExpense+-- "Expense"+accountKindText :: AccountKind -> T.Text+accountKindText AccountKindAsset     = "Asset"+accountKindText AccountKindLiability = "Liability"+accountKindText AccountKindEquity    = "Equity"+accountKindText AccountKindRevenue   = "Revenue"+accountKindText AccountKindExpense   = "Expense"+++-- * Account+-- $account+++-- | Type encoding for account values.+--+-- This definition provides both the 'AccountKind' and an arbitrary object+-- identifying the account. This arbitrary nature provides flexibility to+-- use-site to use its own account identity and accompanying information when+-- required.+-- -- >>> let acc = Account AccountKindAsset (1 ::Int)--- >>> Aeson.encode acc+-- >>> Data.Aeson.encode acc -- "{\"kind\":\"ASSET\",\"object\":1}"--- >>> Aeson.decode (Aeson.encode acc) :: Maybe (Account Int)+-- >>> Data.Aeson.decode @(Account Int) (Data.Aeson.encode acc) -- Just (Account {accountKind = AccountKindAsset, accountObject = 1})--- >>> Aeson.decode (Aeson.encode acc) == Just acc+-- >>> Data.Aeson.decode (Data.Aeson.encode acc) == Just acc -- True data Account o = Account   { accountKind   :: !AccountKind   , accountObject :: !o-  } deriving (Eq, Generic, Ord, Show)-  deriving (FromJSON, ToJSON)-  via PrefixedSnake "account" (Account o)+  }+  deriving (Eq, DAS.Generic, Ord, Show)+  deriving (DAS.FromJSON, DAS.ToJSON) via DAS.PrefixedSnake "account" (Account o)   instance Hashable o => Hashable (Account o)

@@ -1,75 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}--module Haspara.Accounting.AccountKind where--import qualified Data.Aeson    as Aeson-import qualified Data.Char     as C-import           Data.Hashable (Hashable)-import qualified Data.Text     as T-import           GHC.Generics  (Generic)---data AccountKind =-    AccountKindAsset-  | AccountKindLiability-  | AccountKindEquity-  | AccountKindRevenue-  | AccountKindExpense-  deriving (Enum, Eq, Generic, Ord, Show)---instance Hashable AccountKind----- | 'Aeson.FromJSON' instance for 'AccountKind'.------ >>> Aeson.decode "\"Asset\"" :: Maybe AccountKind--- Just AccountKindAsset--- >>> Aeson.decode "\"aSSET\"" :: Maybe AccountKind--- Just AccountKindAsset--- >>> Aeson.decode "\"ASSET\"" :: Maybe AccountKind--- Just AccountKindAsset--- >>> Aeson.decode "\"LIABILITY\"" :: Maybe AccountKind--- Just AccountKindLiability--- >>> Aeson.decode "\"EQUITY\"" :: Maybe AccountKind--- Just AccountKindEquity--- >>> Aeson.decode "\"REVENUE\"" :: Maybe AccountKind--- Just AccountKindRevenue--- >>> Aeson.decode "\"EXPENSE\"" :: Maybe AccountKind--- Just AccountKindExpense-instance Aeson.FromJSON AccountKind where-  parseJSON = Aeson.withText "AccountKind" $ \t -> case T.map C.toUpper t of-    "ASSET"     -> pure AccountKindAsset-    "LIABILITY" -> pure AccountKindLiability-    "EQUITY"    -> pure AccountKindEquity-    "REVENUE"   -> pure AccountKindRevenue-    "EXPENSE"   -> pure AccountKindExpense-    _           -> fail $ "Unknown account kind: " <> show t----- | 'Aeson.ToJSON' instance for 'AccountKind'.------ >>> Aeson.encode AccountKindAsset--- "\"ASSET\""--- >>> Aeson.encode AccountKindLiability--- "\"LIABILITY\""--- >>> Aeson.encode AccountKindEquity--- "\"EQUITY\""--- >>> Aeson.encode AccountKindRevenue--- "\"REVENUE\""--- >>> Aeson.encode AccountKindExpense--- "\"EXPENSE\""-instance Aeson.ToJSON AccountKind where-  toJSON AccountKindAsset     = Aeson.String "ASSET"-  toJSON AccountKindLiability = Aeson.String "LIABILITY"-  toJSON AccountKindEquity    = Aeson.String "EQUITY"-  toJSON AccountKindRevenue   = Aeson.String "REVENUE"-  toJSON AccountKindExpense   = Aeson.String "EXPENSE"---accountKindText :: AccountKind -> T.Text-accountKindText AccountKindAsset     = "Asset"-accountKindText AccountKindLiability = "Liability"-accountKindText AccountKindEquity    = "Equity"-accountKindText AccountKindRevenue   = "Revenue"-accountKindText AccountKindExpense   = "Expense"

@@ -1,109 +0,0 @@-{-# LANGUAGE DataKinds      #-}-{-# LANGUAGE KindSignatures #-}--module Haspara.Accounting.Entry where--import           Data.Aeson                     ((.:), (.=))-import qualified Data.Aeson                     as Aeson-import qualified Data.Char                      as C-import qualified Data.Text                      as T-import           GHC.TypeLits                   (KnownNat, Nat)-import qualified Haspara                        as H-import           Haspara.Accounting.AccountKind (AccountKind(..))-import           Haspara.Accounting.Event       (Event(..))-import           Haspara.Accounting.Types       (UnsignedQuantity)-import           Refined                        (unrefine)----- | Encoding of a posting entry.------ >>> :set -XDataKinds--- >>> import Refined--- >>> let date = read "2021-01-01"--- >>> let oid = 1 :: Int--- >>> let qty = $$(refineTH 42) :: UnsignedQuantity 2--- >>> let entry = EntryDebit date oid qty--- >>> let json = Aeson.encode entry--- >>> json--- "{\"qty\":42.0,\"obj\":1,\"date\":\"2021-01-01\",\"type\":\"DEBIT\"}"--- >>> Aeson.decode json :: Maybe (Entry Int 2)--- Just (EntryDebit 2021-01-01 1 (Refined 42.00))--- >>> Aeson.decode json == Just entry--- True-data Entry o (s :: Nat) =-    EntryDebit H.Date o (UnsignedQuantity s)-  | EntryCredit H.Date o (UnsignedQuantity s)-  deriving (Eq, Ord, Show)---instance (Aeson.FromJSON o, KnownNat s) => Aeson.FromJSON (Entry o s) where-  parseJSON = Aeson.withObject "Entry" $ \o -> do-    dorc <- o .: "type"-    cons <- case T.map C.toUpper dorc of-      "DEBIT"  -> pure EntryDebit-      "CREDIT" -> pure EntryCredit-      x        -> fail ("Unknown entry type: " <> T.unpack x)-    date <- o .: "date"-    obj <- o .: "obj"-    qty <- o .: "qty"-    pure (cons date obj qty)---instance (Aeson.ToJSON o, KnownNat s) => Aeson.ToJSON (Entry o s) where-  toJSON x = case x of-    EntryDebit d o q  -> Aeson.object ["type" .= ("DEBIT" :: T.Text), "date" .= d, "obj" .= o, "qty" .= q]-    EntryCredit d o q -> Aeson.object ["type" .= ("CREDIT" :: T.Text), "date" .= d, "obj" .= o, "qty" .= q]---entryDate :: KnownNat s => Entry o s -> H.Date-entryDate (EntryDebit d _ _)  = d-entryDate (EntryCredit d _ _) = d---entryQuantity :: KnownNat s => Entry o s -> H.Quantity s-entryQuantity (EntryDebit _ _ q)  = unrefine q-entryQuantity (EntryCredit _ _ q) = -(unrefine q)---entryObject :: KnownNat s => Entry o s -> o-entryObject (EntryDebit _ o _)  = o-entryObject (EntryCredit _ o _) = o---entryDebit :: KnownNat s => Entry o s -> Maybe (UnsignedQuantity s)-entryDebit (EntryDebit _ _ x) = Just x-entryDebit EntryCredit {}     = Nothing---entryCredit :: KnownNat s => Entry o s -> Maybe (UnsignedQuantity s)-entryCredit EntryDebit {}       = Nothing-entryCredit (EntryCredit _ _ x) = Just x----- |------ +-----------------------+----------+----------+--- | Kind of account       | Debit    | Credit   |--- +-----------------------+----------+----------+--- | Asset                 | Increase | Decrease |--- +-----------------------+----------+----------+--- | Liability             | Decrease | Increase |--- +-----------------------+----------+----------+--- | Equity/Capital        | Decrease | Increase |--- +-----------------------+----------+----------+--- | Income/Revenue        | Decrease | Increase |--- +-----------------------+----------+----------+--- | Expense/Cost/Dividend | Increase | Decrease |--- +-----------------------+----------+----------+----buildEntry :: (KnownNat s) => Event o s -> AccountKind -> Entry o s-buildEntry (EventDecrement d o x) AccountKindAsset     = EntryCredit d o x-buildEntry (EventIncrement d o x) AccountKindAsset     = EntryDebit  d o x-buildEntry (EventDecrement d o x) AccountKindLiability = EntryDebit  d o x-buildEntry (EventIncrement d o x) AccountKindLiability = EntryCredit d o x-buildEntry (EventDecrement d o x) AccountKindEquity    = EntryDebit  d o x-buildEntry (EventIncrement d o x) AccountKindEquity    = EntryCredit d o x-buildEntry (EventDecrement d o x) AccountKindRevenue   = EntryDebit  d o x-buildEntry (EventIncrement d o x) AccountKindRevenue   = EntryCredit d o x-buildEntry (EventDecrement d o x) AccountKindExpense   = EntryCredit d o x-buildEntry (EventIncrement d o x) AccountKindExpense   = EntryDebit  d o x

@@ -1,38 +1,43 @@-{-# LANGUAGE DataKinds        #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures   #-}+-- | This module provides definitions for economic events.+--+-- /Note: The concept is not YET REA-compatible although we want to achieve it+-- at some point/. +{-# LANGUAGE DataKinds #-}+ module Haspara.Accounting.Event where -import           Control.Monad.Except     (MonadError(throwError))-import           Data.Aeson               ((.:), (.=))-import qualified Data.Aeson               as Aeson-import qualified Data.Char                as C-import qualified Data.Text                as T-import           GHC.TypeLits             (KnownNat, Nat)-import qualified Haspara                  as H-import           Haspara.Accounting.Types (UnsignedQuantity)-import           Refined                  (refine)+import           Control.Monad.Except (MonadError(throwError))+import           Data.Aeson           ((.:), (.=))+import qualified Data.Aeson           as Aeson+import qualified Data.Char            as C+import qualified Data.Text            as T+import           Data.Time            (Day)+import           GHC.TypeLits         (KnownNat, Nat)+import           Haspara.Quantity     (Quantity, UnsignedQuantity)+import           Refined              (refine)  --- | Encoding of an increment/decrement event.+-- | Type encoding of an economic increment/decrement event. --+-- The event explicitly carries the date and quantity information along with a+-- parameterized, arbitrary object providing the source of the event.+-- -- >>> :set -XDataKinds--- >>> import Refined -- >>> let date = read "2021-01-01" -- >>> let oid = 1 :: Int--- >>> let qty = $$(refineTH 42) :: UnsignedQuantity 2+-- >>> let qty = $$(Refined.refineTH 42) :: UnsignedQuantity 2 -- >>> let event = EventDecrement date oid qty--- >>> let json = Aeson.encode event+-- >>> let json = Data.Aeson.encode event -- >>> json--- "{\"qty\":42.0,\"obj\":1,\"date\":\"2021-01-01\",\"type\":\"DECREMENT\"}"--- >>> Aeson.decode json :: Maybe (Event Int 2)+-- "{\"qty\":42.0,\"type\":\"DECREMENT\",\"obj\":1,\"date\":\"2021-01-01\"}"+-- >>> Data.Aeson.decode @(Event Int 2) json -- Just (EventDecrement 2021-01-01 1 (Refined 42.00))--- >>> Aeson.decode json == Just event+-- >>> Data.Aeson.decode json == Just event -- True data Event o (s :: Nat) =-    EventDecrement H.Date o (UnsignedQuantity s)-  | EventIncrement H.Date o (UnsignedQuantity s)+    EventDecrement Day o (UnsignedQuantity s)+  | EventIncrement Day o (UnsignedQuantity s)   deriving (Eq, Ord, Show)  @@ -55,22 +60,32 @@     EventIncrement d o q -> Aeson.object ["type" .= ("INCREMENT" :: T.Text), "date" .= d, "obj" .= o, "qty" .= q]  -eventDate :: (KnownNat s) => Event o s -> H.Date+-- | Returns the date of the event.+eventDate :: (KnownNat s) => Event o s -> Day eventDate (EventDecrement d _ _) = d eventDate (EventIncrement d _ _) = d  +-- | Returns the source object of the event. eventObject :: (KnownNat s) => Event o s -> o eventObject (EventDecrement _ o _) = o eventObject (EventIncrement _ o _) = o  +-- | Negates the event. negateEvent :: (KnownNat s) => Event o s -> Event o s negateEvent (EventDecrement d o x) = EventIncrement d o x negateEvent (EventIncrement d o x) = EventDecrement d o x  -mkEvent :: (MonadError String m, KnownNat s) => H.Date -> o -> H.Quantity s -> m (Event o s)+-- | Smart constuctor for 'Event' values.+mkEvent+  :: MonadError String m+  => KnownNat s+  => Day         -- ^ Date of the event.+  -> o           -- ^ Source object of the event.+  -> Quantity s  -- ^ Quantity of the event.+  -> m (Event o s) mkEvent d o x   | x < 0     = either (throwError . show) pure $ EventDecrement d o <$> refine (abs x)   | otherwise = either (throwError . show) pure $ EventIncrement d o <$> refine (abs x)

@@ -1,29 +1,36 @@-{-# LANGUAGE DataKinds        #-}-{-# LANGUAGE DeriveGeneric    #-}-{-# LANGUAGE DerivingVia      #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures   #-}+-- | This module provides definitions for postings, ledgers and ledger entries. +{-# LANGUAGE DataKinds   #-}+{-# LANGUAGE DerivingVia #-}+ module Haspara.Accounting.Ledger where -import Deriving.Aeson             (CustomJSON(CustomJSON), FromJSON, Generic, ToJSON)-import Deriving.Aeson.Stock       (PrefixedSnake)-import GHC.TypeLits               (KnownNat, Nat)-import Haspara                    (Quantity)-import Haspara.Accounting.Account (Account)-import Haspara.Accounting.Entry   (Entry(..), entryQuantity)+import           Data.Aeson                 ((.:), (.=))+import qualified Data.Aeson                 as Aeson+import qualified Data.Char                  as C+import qualified Data.List.NonEmpty         as NE+import qualified Data.Text                  as T+import           Data.Time                  (Day)+import           Deriving.Aeson             (CustomJSON(CustomJSON), FromJSON, Generic, ToJSON)+import           Deriving.Aeson.Stock       (PrefixedSnake, Vanilla)+import           GHC.TypeLits               (KnownNat, Nat)+import           Haspara.Accounting.Account (Account(accountKind), AccountKind(..))+import           Haspara.Accounting.Event   (Event(..), eventObject)+import           Haspara.Quantity           (Quantity, UnsignedQuantity)+import           Refined                    (unrefine)  +-- | Type encoding of a ledger. data Ledger a o (s :: Nat) = Ledger   { ledgerAccount :: !(Account a)   , ledgerOpening :: !(Quantity s)   , ledgerClosing :: !(Quantity s)   , ledgerRunning :: ![LedgerItem o s]   } deriving (Eq, Generic, Ord, Show)-  deriving (FromJSON, ToJSON)-  via PrefixedSnake "ledger" (Ledger a o s)+  deriving (FromJSON, ToJSON) via PrefixedSnake "ledger" (Ledger a o s)  +-- | Type encoding of a ledger item. data LedgerItem o (s :: Nat) = LedgerItem   { ledgerItemEntry   :: !(Entry o s)   , ledgerItemBalance :: !(Quantity s)@@ -32,12 +39,154 @@   via PrefixedSnake "ledgerItem" (LedgerItem o s)  +-- | Creates a ledger from a given list of 'Entry' values. mkLedger :: KnownNat s => Account a -> Quantity s -> [Entry o s] -> Ledger a o s mkLedger a o = foldl addEntry (Ledger a o o [])  +-- | Adds a new entry to a ledger. addEntry :: KnownNat s => Ledger a o s -> Entry o s -> Ledger a o s addEntry l@(Ledger _ _ c r) e = l { ledgerClosing = balance, ledgerRunning = r <> [item]}   where     balance = c + entryQuantity e     item = LedgerItem e balance+++-- | Type encoding for a posting.+--+-- >>> :set -XDataKinds+-- >>> import Haspara.Accounting+-- >>> import Refined+-- >>> import qualified Data.Aeson as Aeson+-- >>> import qualified Data.List.NonEmpty as NE+-- >>> let date = read "2021-01-01"+-- >>> let oid = 1 :: Int+-- >>> let qty = $$(refineTH 42) :: UnsignedQuantity 2+-- >>> let event = EventDecrement date oid qty+-- >>> let account = Account AccountKindAsset ("Cash" :: String, 1 ::Int)+-- >>> let posting =  Posting . NE.fromList $ [(event, account)]+-- >>> let json = Aeson.encode posting+-- >>> json+-- "[[{\"qty\":42.0,\"type\":\"DECREMENT\",\"obj\":1,\"date\":\"2021-01-01\"},{\"kind\":\"ASSET\",\"object\":[\"Cash\",1]}]]"+-- >>> Aeson.decode json :: Maybe (Posting (String, Int) Int 2)+-- Just (Posting ((EventDecrement 2021-01-01 1 (Refined 42.00),Account {accountKind = AccountKindAsset, accountObject = ("Cash",1)}) :| []))+-- >>> Aeson.decode json == Just posting+-- True+newtype Posting a o (s :: Nat) = Posting (NE.NonEmpty (Event o s, Account a))+  deriving (Eq, Generic, Ord, Show)+  deriving (FromJSON, ToJSON)+  via Vanilla (Posting a o s)+++-- | Returns the list of posting event sources.+postingEvents :: (KnownNat s) => Posting a o s -> [o]+postingEvents (Posting es)  = eventObject . fst <$> NE.toList es+++-- | Posts an event.+post :: (KnownNat s) => Posting a o s -> [(Account a, Entry o s)]+post (Posting xs)       = go (NE.toList xs)+  where+    go []              = []+    go ((ev, ac) : ys) = (ac, buildEntry ev (accountKind ac)) : go ys+++-- | Encoding of a posting entry.+--+-- >>> :set -XDataKinds+-- >>> import Refined+-- >>> let date = read "2021-01-01"+-- >>> let oid = 1 :: Int+-- >>> let qty = $$(refineTH 42) :: UnsignedQuantity 2+-- >>> let entry = EntryDebit date oid qty+-- >>> let json = Aeson.encode entry+-- >>> json+-- "{\"qty\":42.0,\"type\":\"DEBIT\",\"obj\":1,\"date\":\"2021-01-01\"}"+-- >>> Aeson.decode json :: Maybe (Entry Int 2)+-- Just (EntryDebit 2021-01-01 1 (Refined 42.00))+-- >>> Aeson.decode json == Just entry+-- True+data Entry o (s :: Nat) =+    EntryDebit Day o (UnsignedQuantity s)+  | EntryCredit Day o (UnsignedQuantity s)+  deriving (Eq, Ord, Show)+++instance (Aeson.FromJSON o, KnownNat s) => Aeson.FromJSON (Entry o s) where+  parseJSON = Aeson.withObject "Entry" $ \o -> do+    dorc <- o .: "type"+    cons <- case T.map C.toUpper dorc of+      "DEBIT"  -> pure EntryDebit+      "CREDIT" -> pure EntryCredit+      x        -> fail ("Unknown entry type: " <> T.unpack x)+    date <- o .: "date"+    obj <- o .: "obj"+    qty <- o .: "qty"+    pure (cons date obj qty)+++instance (Aeson.ToJSON o, KnownNat s) => Aeson.ToJSON (Entry o s) where+  toJSON x = case x of+    EntryDebit d o q  -> Aeson.object ["type" .= ("DEBIT" :: T.Text), "date" .= d, "obj" .= o, "qty" .= q]+    EntryCredit d o q -> Aeson.object ["type" .= ("CREDIT" :: T.Text), "date" .= d, "obj" .= o, "qty" .= q]+++-- | Returns the date of the posting entry.+entryDate :: KnownNat s => Entry o s -> Day+entryDate (EntryDebit d _ _)  = d+entryDate (EntryCredit d _ _) = d+++-- | Returns the quantity of the posting entry.+entryQuantity :: KnownNat s => Entry o s -> Quantity s+entryQuantity (EntryDebit _ _ q)  = unrefine q+entryQuantity (EntryCredit _ _ q) = -(unrefine q)+++-- | Returns the source object of the posting entry.+entryObject :: KnownNat s => Entry o s -> o+entryObject (EntryDebit _ o _)  = o+entryObject (EntryCredit _ o _) = o+++-- | Returns the debit quantity of the posting entry.+entryDebit :: KnownNat s => Entry o s -> Maybe (UnsignedQuantity s)+entryDebit (EntryDebit _ _ x) = Just x+entryDebit EntryCredit {}     = Nothing+++-- | Returns the credit quantity of the posting entry.+entryCredit :: KnownNat s => Entry o s -> Maybe (UnsignedQuantity s)+entryCredit EntryDebit {}       = Nothing+entryCredit (EntryCredit _ _ x) = Just x+++-- | Consumes an event and a type of account, and produces a posting entry.+--+-- Note the following map as a guide:+--+-- +-----------------------+----------+----------++-- | Kind of account       | Debit    | Credit   |+-- +-----------------------+----------+----------++-- | Asset                 | Increase | Decrease |+-- +-----------------------+----------+----------++-- | Liability             | Decrease | Increase |+-- +-----------------------+----------+----------++-- | Equity/Capital        | Decrease | Increase |+-- +-----------------------+----------+----------++-- | Income/Revenue        | Decrease | Increase |+-- +-----------------------+----------+----------++-- | Expense/Cost/Dividend | Increase | Decrease |+-- +-----------------------+----------+----------++--+buildEntry :: (KnownNat s) => Event o s -> AccountKind -> Entry o s+buildEntry (EventDecrement d o x) AccountKindAsset     = EntryCredit d o x+buildEntry (EventIncrement d o x) AccountKindAsset     = EntryDebit  d o x+buildEntry (EventDecrement d o x) AccountKindLiability = EntryDebit  d o x+buildEntry (EventIncrement d o x) AccountKindLiability = EntryCredit d o x+buildEntry (EventDecrement d o x) AccountKindEquity    = EntryDebit  d o x+buildEntry (EventIncrement d o x) AccountKindEquity    = EntryCredit d o x+buildEntry (EventDecrement d o x) AccountKindRevenue   = EntryDebit  d o x+buildEntry (EventIncrement d o x) AccountKindRevenue   = EntryCredit d o x+buildEntry (EventDecrement d o x) AccountKindExpense   = EntryCredit d o x+buildEntry (EventIncrement d o x) AccountKindExpense   = EntryDebit  d o x

@@ -1,52 +0,0 @@-{-# LANGUAGE DataKinds       #-}-{-# LANGUAGE DeriveGeneric   #-}-{-# LANGUAGE DerivingVia     #-}-{-# LANGUAGE KindSignatures  #-}-{-# LANGUAGE TemplateHaskell #-}--module Haspara.Accounting.Posting where--import qualified Data.List.NonEmpty         as NE-import           Deriving.Aeson             (CustomJSON(CustomJSON), FromJSON, Generic, ToJSON)-import           Deriving.Aeson.Stock       (Vanilla)-import           GHC.TypeLits               (KnownNat, Nat)-import           Haspara.Accounting.Account (Account(accountKind))-import           Haspara.Accounting.Entry   (Entry, buildEntry)-import           Haspara.Accounting.Event   (Event, eventObject)----- | Type encoding for a posting.------ >>> :set -XDataKinds--- >>> import Haspara.Accounting--- >>> import Refined--- >>> import qualified Data.Aeson as Aeson--- >>> import qualified Data.List.NonEmpty as NE--- >>> let date = read "2021-01-01"--- >>> let oid = 1 :: Int--- >>> let qty = $$(refineTH 42) :: UnsignedQuantity 2--- >>> let event = EventDecrement date oid qty--- >>> let account = Account AccountKindAsset ("Cash" :: String, 1 ::Int)--- >>> let posting =  Posting . NE.fromList $ [(event, account)]--- >>> let json = Aeson.encode posting--- >>> json--- "[[{\"qty\":42.0,\"obj\":1,\"date\":\"2021-01-01\",\"type\":\"DECREMENT\"},{\"kind\":\"ASSET\",\"object\":[\"Cash\",1]}]]"--- >>> Aeson.decode json :: Maybe (Posting (String, Int) Int 2)--- Just (Posting ((EventDecrement 2021-01-01 1 (Refined 42.00),Account {accountKind = AccountKindAsset, accountObject = ("Cash",1)}) :| []))--- >>> Aeson.decode json == Just posting--- True-newtype Posting a o (s :: Nat) = Posting (NE.NonEmpty (Event o s, Account a))-  deriving (Eq, Generic, Ord, Show)-  deriving (FromJSON, ToJSON)-  via Vanilla (Posting a o s)---postingEvents :: (KnownNat s) => Posting a o s -> [o]-postingEvents (Posting es)  = eventObject . fst <$> NE.toList es---post :: (KnownNat s) => Posting a o s -> [(Account a, Entry o s)]-post (Posting xs)       = go (NE.toList xs)-  where-    go []              = []-    go ((ev, ac) : ys) = (ac, buildEntry ev (accountKind ac)) : go ys

@@ -1,7 +0,0 @@-module Haspara.Accounting.Types where--import Haspara.Quantity (Quantity)-import Refined          (NonNegative, Refined)---type UnsignedQuantity s = Refined NonNegative (Quantity s)

@@ -1,48 +1,190 @@--- | This module provides base data definitions and functions for 'Haspara'--- library.+-- | This module provides definitions for modeling and working with currencies.++{-# LANGUAGE DataKinds   #-}+{-# LANGUAGE DerivingVia #-}++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 qualified Deriving.Aeson.Stock       as DAS+import qualified Language.Haskell.TH.Syntax as TH+import qualified Text.Megaparsec            as MP+++-- * Currency+-- $currency+++-- | Type encoding for currency symbol values with a syntax of @[A-Z]{3}[A-Z]*@. ---module Haspara.Currency-  ( -- * Currency-    -- &currency-    ---    -- ** Data Definition-    -- &currencyDataDefinition-    ---    Currency-  , currencyCode-    ---    -- ** Constructors-    -- &currencyConstructors-    ---  , currency-  , currencyFail-    ---    -- * Currency Pair-    -- &currencyPair-    ---    -- ** Data Definition-    -- &currencyPairDataDefinition-    ---  , CurrencyPair-  , toTuple-  , baseCurrency-  , quoteCurrency-    ---    -- ** Constructors-    -- &currencyPairConstructors-    ---  , currencyPair-  , currencyPairFail-  ) where+-- 'Currency' values can be constructed via 'mkCurrencyError' that works in+-- @'MonadError' 'T.Text'@ context:+--+-- >>> mkCurrencyError "EUR" :: Either T.Text Currency+-- Right EUR+--+-- ... or via 'mkCurrencyFail' that works in 'MonadFail' context:+--+-- >>> mkCurrencyFail "EUR" :: Maybe Currency+-- Just EUR+--+-- An 'IsString' instance is provided as well which is unsafe but convenient:+--+-- >>> "EUR" :: Currency+-- EUR+newtype Currency = MkCurrency { currencyCode :: T.Text }+  deriving (Eq, Hashable, Ord, TH.Lift) -import Haspara.Internal.Currency-       ( Currency(currencyCode)-       , CurrencyPair-       , baseCurrency-       , currency-       , currencyFail-       , currencyPair-       , currencyPairFail-       , quoteCurrency-       , toTuple-       )++-- | 'IsString' instance for 'Currency'.+--+-- >>> "USD" :: Currency+-- USD+instance IsString Currency where+  fromString =  either (error . T.unpack) id . mkCurrencyError . T.pack+++-- | 'Show' instance for 'Currency'.+--+-- >>> "USD" :: Currency+-- USD+instance Show Currency where+  show (MkCurrency x) = T.unpack x+++-- | 'Aeson.FromJSON' instance for 'Currency'.+--+-- >>> 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+-- Left "Error in $: Currency code error! Expecting at least 3 uppercase ASCII letters, but received: A"+-- >>> Aeson.eitherDecode "\"AB\"" :: Either String Currency+-- Left "Error in $: Currency code error! Expecting at least 3 uppercase ASCII letters, but received: AB"+-- >>> Aeson.eitherDecode "\"ABC\"" :: Either String Currency+-- Right ABC+-- >>> Aeson.eitherDecode "\"ABCD\"" :: Either String Currency+-- Right ABCD+instance Aeson.FromJSON Currency where+  parseJSON = Aeson.withText "Currency" $ either (fail . T.unpack) pure . mkCurrencyError+++-- | 'Aeson.ToJSON' instance for 'Currency'.+--+-- >>> Aeson.encode ("USD" :: Currency)+-- "\"USD\""+instance Aeson.ToJSON Currency where+  toJSON (MkCurrency c) = Aeson.String c+++-- | Smart constructor for 'Currency' values within 'MonadError' context.+--+-- >>> mkCurrencyError "" :: Either T.Text Currency+-- Left "Currency code error! Expecting at least 3 uppercase ASCII letters, but received: "+-- >>> mkCurrencyError " " :: Either T.Text Currency+-- Left "Currency code error! Expecting at least 3 uppercase ASCII letters, but received:  "+-- >>> mkCurrencyError "AB" :: Either T.Text Currency+-- Left "Currency code error! Expecting at least 3 uppercase ASCII letters, but received: AB"+-- >>> mkCurrencyError " ABC " :: Either T.Text Currency+-- Left "Currency code error! Expecting at least 3 uppercase ASCII letters, but received:  ABC "+-- >>> 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)+++-- | Smart constructor for 'Currency' values within 'MonadFail' context.+--+-- >>> mkCurrencyFail "" :: Maybe Currency+-- Nothing+-- >>> mkCurrencyFail "US" :: Maybe Currency+-- Nothing+-- >>> mkCurrencyFail "usd" :: Maybe Currency+-- Nothing+-- >>> mkCurrencyFail "USD" :: Maybe Currency+-- Just USD+mkCurrencyFail :: MonadFail m => T.Text -> m Currency+mkCurrencyFail = either (fail . T.unpack) pure . mkCurrencyError+++-- | Parser that parses currency codes.+--+-- >>> 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" " "+-- Left (ParseErrorBundle {bundleErrors = TrivialError 0 (Just (Tokens (' ' :| ""))) (fromList []) :| [], bundlePosState = PosState {pstateInput = " ", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}})+-- >>> MP.runParser currencyCodeParser "Example" "a"+-- Left (ParseErrorBundle {bundleErrors = TrivialError 0 (Just (Tokens ('a' :| ""))) (fromList []) :| [], bundlePosState = PosState {pstateInput = "a", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}})+-- >>> MP.runParser currencyCodeParser "Example" "A"+-- Left (ParseErrorBundle {bundleErrors = TrivialError 1 (Just EndOfInput) (fromList []) :| [], bundlePosState = PosState {pstateInput = "A", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}})+-- >>> MP.runParser currencyCodeParser "Example" "AB"+-- Left (ParseErrorBundle {bundleErrors = TrivialError 2 (Just EndOfInput) (fromList []) :| [], bundlePosState = PosState {pstateInput = "AB", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}})+-- >>> MP.runParser currencyCodeParser "Example" "ABC"+-- Right "ABC"+-- >>> MP.runParser currencyCodeParser "Example" "ABCD"+-- Right "ABCD"+-- >>> MP.runParser currencyCodeParser "Example" " ABCD "+-- Left (ParseErrorBundle {bundleErrors = TrivialError 0 (Just (Tokens (' ' :| ""))) (fromList []) :| [], bundlePosState = PosState {pstateInput = " ABCD ", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}})+currencyCodeParser :: MP.Parsec Void T.Text T.Text+currencyCodeParser = do+  mandatory <- MP.count 3 validChar+  optionals <- MP.many validChar+  pure . T.pack $ mandatory <> optionals+  where+    validChar = MP.oneOf ['A'..'Z']+++-- * Currency Pair+-- $currencyPair+++-- | Type encoding of a currency pair.+--+-- 'CurrencyPair' values are constructed via the data constructor:+--+-- >>> CurrencyPair "EUR" "USD"+-- EUR/USD+--+-- 'Aeson.FromJSON' and 'Aeson.ToJSON' instances are provided as well:+--+-- >>> Aeson.decode "{\"base\": \"EUR\", \"quote\": \"EUR\"}" :: Maybe CurrencyPair+-- Just EUR/EUR+-- >>> 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/.+  }+  deriving (Eq, DAS.Generic, Ord, TH.Lift)+  deriving (DAS.FromJSON, DAS.ToJSON) via DAS.PrefixedSnake "currencyPair" CurrencyPair+++-- | 'Show' instance for 'CurrencyPair'.+--+-- >>> CurrencyPair "EUR" "USD"+-- EUR/USD+instance Show CurrencyPair where+  show (CurrencyPair x y) = show x <> "/" <> show y+++-- | Converts a 'CurrencyPair' to a 2-tuple of 'Currency' values.+--+-- >>> toCurrencyTuple (CurrencyPair "EUR" "USD")+-- (EUR,USD)+toCurrencyTuple :: CurrencyPair -> (Currency, Currency)+toCurrencyTuple (CurrencyPair x y) = (x, y)+++-- | Converts a 2-tuple of 'Currency' values to a 'CurrencyPair'.+--+-- >>> fromCurrencyTuple ("EUR", "USD")+-- EUR/USD+fromCurrencyTuple :: (Currency, Currency) -> CurrencyPair+fromCurrencyTuple = uncurry CurrencyPair

@@ -1,55 +0,0 @@--- | This module provides definitions and functions to encode and work on date--- values.----module Haspara.Date-  ( -- * Date-    -- &date-    ---    -- ** Definition-    -- &definition-    ---    Date-    ---    ---    -- ** Constructors-    -- &constructors-    ---  , fromDay-  , fromYMD-  , fromString-  , fromFormattedString-  , fromText-  , fromFormattedText-    ---    -- ** Conversions-    -- &conversions-    ---  , toDay-  , toYMD-  , toString-  , toFormattedString-  , toText-  , toFormattedText-    ---    -- ** Operations-    -- &operations-    ---  , addDays-  ) where--import Haspara.Internal.Date-       ( Date-       , addDays-       , fromDay-       , fromFormattedString-       , fromFormattedText-       , fromString-       , fromText-       , fromYMD-       , toDay-       , toFormattedString-       , toFormattedText-       , toString-       , toText-       , toYMD-       )

@@ -1,32 +0,0 @@--- | This module provides base data definitions and functions for 'Haspara'--- library.----module Haspara.FXQuote-  ( ---    -- * FX Quote-    -- &fxquote-    ---    -- ** Data Definition-    -- &fxquoteDataDefinition-    ---    FXQuote-  , fxQuoteDate-  , fxQuotePair-  , fxQuoteRate-    ---    -- ** Constructors-    -- &fxquoteConstructors-    ---  , fxquote-  , fxquoteFail-    ---    -- * FX Quote Database-    -- *fxquoteDatabase-    ---  , FXQuoteDatabase-  , FXQuotePairDatabase(..)-  , findFXQuote-  ) where--import Haspara.Internal.FXQuote         (FXQuote(fxQuoteDate, fxQuotePair, fxQuoteRate), fxquote, fxquoteFail)-import Haspara.Internal.FXQuoteDatabase (FXQuoteDatabase, FXQuotePairDatabase(..), findFXQuote)

@@ -0,0 +1,142 @@+-- | 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.Map.Strict      as SM+import           Data.Scientific      (Scientific)+import qualified Data.Text            as T+import           Data.Time            (Day, addDays)+import qualified Deriving.Aeson.Stock as DAS+import           GHC.TypeLits         (KnownNat, Nat)+import           Haspara.Currency     (Currency, CurrencyPair(CurrencyPair))+import           Haspara.Quantity     (Quantity(..), mkQuantity)+import           Refined              (Positive, Refined, refineError)+++-- * FX Rate Quotation+-- $fxRateQuotation+++-- | Type encoding for FX rate quotations with fixed precision.+--+-- An FX rate quotation is a 3-tuple of:+--+-- 1. a currency pair the rate is quoted for, and+-- 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.+  }+  deriving (Eq, DAS.Generic, Ord, Show)+  deriving (DAS.FromJSON, DAS.ToJSON) via DAS.PrefixedSnake "fxQuote" (FxQuote s)+++-- | Smart constructor for 'FxQuote' values within @'MonadError' 'T.Text'@+-- context.+--+-- The rate is expected to be a positive value. If it is not, the function will+-- throw an error.+--+-- >>> mkFxQuoteError @(Either _) @2 (read "2021-12-31") "EUR" "USD" 1.16+-- Right (MkFxQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16})+-- >>> mkFxQuoteError @(Either _) @2 (read "2021-12-31") "EUR" "USD" (-1.16)+-- Left "Can not create FX Rate. Error was:   The predicate (GreaterThan 0) failed with the message: Value is not greater than 0\n"+mkFxQuoteError+  :: MonadError T.Text m+  => KnownNat s+  => Day         -- ^ Date of the FX quotation.+  -> Currency    -- ^ Base currency (from) of the FX quotation.+  -> Currency    -- ^ Quote currency (to) of the FX quotation.+  -> Scientific  -- ^ FX quotation rate, expected to be positive.+  -> m (FxQuote s)+mkFxQuoteError date ccy1 ccy2 rate =+  either (throwError . (<>) "Can not create FX Rate. Error was: ") pure $ do+    pval <- either (Left . T.pack . show) pure $ refineError (mkQuantity rate)+    pure $ MkFxQuote (CurrencyPair ccy1 ccy2) date pval+++-- | Smart constructor for 'FxQuote' values within 'MonadFail' context.+--+-- The rate is expected to be a positive value. If it is not, the function will+-- fail.+-- >>> mkFxQuoteFail @Maybe @2 (read "2021-12-31") "EUR" "USD" 1.16+-- Just (MkFxQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16})+-- >>> mkFxQuoteFail @Maybe @2 (read "2021-12-31") "EUR" "USD" (-1.16)+-- Nothing+mkFxQuoteFail+  :: MonadFail m+  => KnownNat s+  => Day         -- ^ Date of the FX quotation.+  -> Currency    -- ^ Base currency (from) of the FX quotation.+  -> Currency    -- ^ Quote currency (to) of the FX quotation.+  -> Scientific  -- ^ FX quotation rate, expected to be positive.+  -> m (FxQuote s)+mkFxQuoteFail date ccy1 ccy2 =+  either (fail . T.unpack) pure . mkFxQuoteError date ccy1 ccy2+++-- | Unsafe 'FxQuote' constructor that 'error's if it fails.+--+-- >>> mkFxQuoteUnsafe @2 (read "2021-12-31") "EUR" "USD" 1.16+-- MkFxQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16}+-- >>> mkFxQuoteUnsafe @2 (read "2021-12-31") "EUR" "USD" (-1.16)+-- ...+-- ...Can not create FX Rate. Error was:   The predicate (GreaterThan 0) failed with the message: Value is not greater than 0+-- ...+mkFxQuoteUnsafe+  :: KnownNat s+  => Day         -- ^ Date of the FX quotation.+  -> Currency    -- ^ Base currency (from) of the FX quotation.+  -> Currency    -- ^ Quote currency (to) of the FX quotation.+  -> Scientific  -- ^ FX quotation rate, expected to be positive.+  -> FxQuote s+mkFxQuoteUnsafe date ccy1 ccy2 =+  either (error . T.unpack) id . mkFxQuoteError date ccy1 ccy2+++-- * FX Rate Quotation Database+-- $fxRateQuotationDatabase+++-- | Type encoding for a dictionary-based FX rate quotation database for various+-- 'CurrencyPair' values.+type FxQuoteDatabase (n :: Nat) = SM.Map CurrencyPair (FxQuotePairDatabase n)+++-- | Type encoding for FX rate quotation database for a 'CurrencyPair'.+data FxQuotePairDatabase (n :: Nat) = FxQuotePairDatabase+  { fxQuotePairDatabasePair  :: !CurrencyPair+  , fxQuotePairDatabaseTable :: !(SM.Map Day (FxQuote n))+  , fxQuotePairDatabaseSince :: !Day+  , fxQuotePairDatabaseUntil :: !Day+  }+++-- | 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.+  -> Maybe (FxQuote n)+findFxQuote db pair date = SM.lookup pair db >>= findFxQuoteAux date+++-- | Attempts to find and return the FX quotation as of a give 'Day' in a given+-- 'FxQuotePairDatabase'.+findFxQuoteAux :: KnownNat n => Day -> FxQuotePairDatabase n -> Maybe (FxQuote n)+findFxQuoteAux date db+  | date < fxQuotePairDatabaseSince db = Nothing+  | otherwise = case SM.lookup date (fxQuotePairDatabaseTable db) of+      Nothing -> findFxQuoteAux (addDays (-1) date) db+      Just fx -> Just fx

@@ -1,6 +0,0 @@-module Haspara.Id-  ( Id(..)-  , IdLookup-  ) where--import Haspara.Internal.Id (Id(..), IdLookup)

@@ -0,0 +1,14 @@+-- | This module provides helper definitions for "Data.Aeson".++module Haspara.Internal.Aeson where++import qualified Data.Char      as C+import qualified Deriving.Aeson as DA+++-- | Type definition for string modifiers that uppercase a given symbol.+data UpperCase+++instance DA.StringModifier UpperCase where+  getStringModifier = fmap C.toUpper

@@ -1,158 +0,0 @@--- | This module provides internal definitions for modeling and working with--- currencies.----{-# LANGUAGE DeriveLift                 #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Haspara.Internal.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 qualified Language.Haskell.TH.Syntax as TH-import qualified Text.Megaparsec            as MP----- * Data Definition--- &definition---- | Type encoding for currencies.-newtype Currency = MkCurrency { currencyCode :: T.Text }-  deriving (Eq, Hashable, Ord, TH.Lift)----- | 'Show' instance for 'Currency'.------ >>> MkCurrency "USD"--- USD-instance Show Currency where-  show (MkCurrency x) = T.unpack x----- | 'IsString' instance for 'Currency'.------ >>> "USD" :: Currency--- USD-instance IsString Currency where-  fromString =  either error id . currency . T.pack----- | 'Aeson.FromJSON' instance for 'Currency'.------ >>> Aeson.eitherDecode "\"\"" :: Either String Currency--- Left "Error in $: Currency code error! Expecting at least 3 uppercase characters, but received: \"\""--- >>> Aeson.eitherDecode "\"ABC\"" :: Either String Currency--- Right ABC-instance Aeson.FromJSON Currency where-  parseJSON = Aeson.withText "Currency" $ either fail pure . currency----- | 'Aeson.ToJSON' instance for 'Currency'.------ >>> Aeson.encode (MkCurrency "USD")--- "\"USD\""-instance Aeson.ToJSON Currency where-  toJSON (MkCurrency c) = Aeson.String c----- * Constructors--- &constructors----- | Smart constructor for 'Currency' values within 'MonadError' context.------ >>> currency "" :: Either String Currency--- Left "Currency code error! Expecting at least 3 uppercase characters, but received: \"\""--- >>> currency " " :: Either String Currency--- Left "Currency code error! Expecting at least 3 uppercase characters, but received: \" \""--- >>> currency "AB" :: Either String Currency--- Left "Currency code error! Expecting at least 3 uppercase characters, but received: \"AB\""--- >>> currency " ABC " :: Either String Currency--- Left "Currency code error! Expecting at least 3 uppercase characters, but received: \" ABC \""--- >>> currency "ABC" :: Either String Currency--- Right ABC-currency :: MonadError String m => T.Text -> m Currency-currency x = either-  (const . throwError $ "Currency code error! Expecting at least 3 uppercase characters, but received: " <> show x)-  (pure . MkCurrency)-  (MP.runParser currencyCodeParser "Currency Code" x)----- | Smart constructor for 'Currency' values within 'MonadFail' context.------ >>> currencyFail "" :: Maybe Currency--- Nothing--- >>> currencyFail "US" :: Maybe Currency--- Nothing--- >>> currencyFail "usd" :: Maybe Currency--- Nothing--- >>> currencyFail "USD" :: Maybe Currency--- Just USD-currencyFail :: MonadFail m => T.Text -> m Currency-currencyFail = either fail pure . currency----- * Auxiliaries--- &auxiliaries----- | Parser that parses currency codes.------ >>> 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" " "--- Left (ParseErrorBundle {bundleErrors = TrivialError 0 (Just (Tokens (' ' :| ""))) (fromList []) :| [], bundlePosState = PosState {pstateInput = " ", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}})--- >>> MP.runParser currencyCodeParser "Example" "a"--- Left (ParseErrorBundle {bundleErrors = TrivialError 0 (Just (Tokens ('a' :| ""))) (fromList []) :| [], bundlePosState = PosState {pstateInput = "a", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}})--- >>> MP.runParser currencyCodeParser "Example" "A"--- Left (ParseErrorBundle {bundleErrors = TrivialError 1 (Just EndOfInput) (fromList []) :| [], bundlePosState = PosState {pstateInput = "A", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}})--- >>> MP.runParser currencyCodeParser "Example" "AB"--- Left (ParseErrorBundle {bundleErrors = TrivialError 2 (Just EndOfInput) (fromList []) :| [], bundlePosState = PosState {pstateInput = "AB", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}})--- >>> MP.runParser currencyCodeParser "Example" "ABC"--- Right "ABC"-currencyCodeParser :: MP.Parsec Void T.Text T.Text-currencyCodeParser = do-  mandatory <- MP.count 3 parserChar-  optionals <- MP.many parserChar-  pure . T.pack $ mandatory <> optionals-  where-    validChars = ['A'..'Z']-    parserChar = MP.oneOf validChars---newtype CurrencyPair = MkCurrencyPair { unCurrencyPair :: (Currency, Currency) }-  deriving (Eq, Hashable, Ord, TH.Lift)----- | 'Show' instance for currency pairs.------ >>> MkCurrencyPair ("EUR", "USD")--- EUR/USD-instance Show CurrencyPair where-  show (MkCurrencyPair (x, y)) = show x <> "/" <> show y---toTuple :: CurrencyPair -> (Currency, Currency)-toTuple = unCurrencyPair---baseCurrency :: CurrencyPair -> Currency-baseCurrency = fst . unCurrencyPair---quoteCurrency :: CurrencyPair -> Currency-quoteCurrency = snd . unCurrencyPair---currencyPair :: MonadError String m => Currency -> Currency -> m CurrencyPair-currencyPair c1 c2-  | c1 == c2 = throwError $ "Can not create currency pair from same currencies: " <> show c1 <> " and " <> show c2-  | otherwise = pure (MkCurrencyPair (c1, c2))---currencyPairFail :: MonadFail m => Currency -> Currency -> m CurrencyPair-currencyPairFail = (either fail pure .) . currencyPair

@@ -1,195 +0,0 @@--- | This module provides data definitions and functions for date values.----{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Haspara.Internal.Date where--import qualified Data.Aeson     as Aeson-import           Data.Bifunctor (first)-import           Data.Hashable  (Hashable(..))-import qualified Data.Text      as T-import qualified Data.Time      as DT----- * Data Definition--- &dataDefinition----- | Type encoding for date values.------ This is a convenience wrapper around 'Day' type. It helps us to avoid--- defining orphan instances.-newtype Date = MkDate DT.Day deriving (Eq, Enum, Ord)----- | 'Hashable' instance for 'Date'.-instance Hashable Date where-  hashWithSalt salt (MkDate (DT.ModifiedJulianDay i)) = hashWithSalt salt i----- | 'Read' instance for 'Date'.------ >>> read "2021-01-01" :: Date--- 2021-01-01--- >>> read "Just 2021-01-01" :: Maybe Date--- Just 2021-01-01-instance Read Date where-  readsPrec _ = readParen False $ fmap (first MkDate) <$> DT.readSTime True DT.defaultTimeLocale "%Y-%m-%d"----- | 'Show' instance for 'Date'.------ >>> fromYMD 2020 12 31--- 2020-12-31-instance Show Date where-  show = toString----- | 'Aeson.FromJSON' instance for 'Date'.------ >>> Aeson.decode "\"2020-12-31\"" :: Maybe Date--- Just 2020-12-31-instance Aeson.FromJSON Date where-  parseJSON = Aeson.withText "Date" fromText----- | 'Aeson.ToJSON' instance for 'Date'.------ >>> Aeson.encode (MkDate (read "2021-01-01"))--- "\"2021-01-01\""-instance Aeson.ToJSON Date where-  toJSON = Aeson.String . T.pack . show----- * Constructors--- &constructors----- | Builds a 'Date' from a given 'Day'.------ >>> fromDay (read "2021-01-01")--- 2021-01-01-fromDay :: DT.Day -> Date-fromDay = MkDate----- | Builds a 'Date' from a given year, month and day as in Gregorian calendar.------ >>> fromYMD 2021 1 1--- 2021-01-01-fromYMD :: Integer -> Int -> Int -> Date-fromYMD y m d = fromDay (DT.fromGregorian y m d)----- | Attempts to parse and return 'Date' from a given 'String' with ISO format.------ >>> fromString "2021-01-01" :: Maybe Date--- Just 2021-01-01--- >>> fromString "20210101" :: Maybe Date--- Nothing-fromString :: MonadFail m => String -> m Date-fromString = fromFormattedString "%Y-%m-%d"----- | Attempts to parse and return 'Date' from a given 'String' with given date format.------ >>> fromFormattedString "%Y-%m-%d" "2021-01-01" :: Maybe Date--- Just 2021-01-01--- >>> fromFormattedString "%Y%m%d" "20210101" :: Maybe Date--- Just 2021-01-01--- >>> fromFormattedString "%Y%m%d" "202101" :: Maybe Date--- Nothing-fromFormattedString :: MonadFail m => String -> String -> m Date-fromFormattedString fmt = fmap fromDay . DT.parseTimeM False DT.defaultTimeLocale fmt----- | Attempts to parse and return 'Date' from a given 'T.Text' with ISO format.------ >>> fromText "2021-01-01" :: Maybe Date--- Just 2021-01-01--- >>> fromText "20210101" :: Maybe Date--- Nothing-fromText :: MonadFail m => T.Text -> m Date-fromText = fromString . T.unpack----- | Attempts to parse and return 'Date' from a given 'T.Text' with ISO format.------ >>> fromFormattedText "%Y-%m-%d" "2021-01-01" :: Maybe Date--- Just 2021-01-01--- >>> fromFormattedText "%Y%m%d" "20210101" :: Maybe Date--- Just 2021-01-01--- >>> fromFormattedText "%Y%m%d" "202101" :: Maybe Date--- Nothing-fromFormattedText :: MonadFail m => String -> T.Text -> m Date-fromFormattedText fmt = fromFormattedString fmt  . T.unpack----- * Conversions--- &conversions----- | Converts 'Date' value to a 'DT.Day' value.------ >>> toDay (read "2021-01-01")--- 2021-01-01-toDay :: Date -> DT.Day-toDay (MkDate d) = d----- | Converts 'Date' value to a 3-tuple of year, month and day.------ >>> toYMD (read "2020-12-31")--- (2020,12,31)-toYMD :: Date -> (Integer, Int, Int)-toYMD = DT.toGregorian . toDay----- | Converts 'Date' value into a 'String' value with ISO format.------ >>> toString (read "2021-01-01")--- "2021-01-01"-toString :: Date -> String-toString = toFormattedString "%Y-%m-%d"----- | Converts 'Date' value into a 'String' value with the given format.------ >>> toFormattedString "%Y-%m-%d" (read "2021-01-01")--- "2021-01-01"--- >>> toFormattedString "%d/%m/%Y" (read "2021-01-01")--- "01/01/2021"-toFormattedString :: String -> Date -> String-toFormattedString fmt = DT.formatTime DT.defaultTimeLocale fmt . toDay----- | Converts 'Date' value into a 'T.Text' value with ISO format.------ >>> toText (read "2021-01-01")--- "2021-01-01"-toText :: Date -> T.Text-toText = T.pack . toString----- | Converts 'Date' value into a 'T.Text' value with the given format.------ >>> toFormattedText "%Y-%m-%d" (read "2021-01-01")--- "2021-01-01"--- >>> toFormattedText "%d/%m/%Y" (read "2021-01-01")--- "01/01/2021"-toFormattedText :: String -> Date -> T.Text-toFormattedText fmt = T.pack . toFormattedString fmt----- * Helper Functions--- &helpers----- | Adds (or subtracts) some days.------ >>> addDays (-1) $ fromYMD 2021 1 1--- 2020-12-31--- >>> addDays 1 $ addDays (-1) $ fromYMD 2021 1 1--- 2021-01-01-addDays :: Integer -> Date -> Date-addDays x (MkDate d) = MkDate (DT.addDays x d)

@@ -1,121 +0,0 @@--- | This module provides internal definitions for modeling and working with FX--- rates.----{-# LANGUAGE DataKinds        #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures   #-}--module Haspara.Internal.FXQuote where--import           Control.Monad.Except      (MonadError(throwError), join)-import           Data.Aeson                ((.:), (.=))-import qualified Data.Aeson                as Aeson-import           Data.Scientific           (Scientific)-import           GHC.TypeLits              (KnownNat, Nat)-import           Haspara.Internal.Currency (Currency, CurrencyPair, baseCurrency, currencyPair, quoteCurrency)-import           Haspara.Internal.Date     (Date)-import           Haspara.Internal.Quantity (Quantity(..), quantity)-import           Numeric.Decimal           (toScientificDecimal)-import           Refined                   (Positive, Refined, refineError, unrefine)---- * FX Rate Data Definition--- &fXQuoteValue----- | Type encoding for FX rates.-data FXQuote (s :: Nat) = MkFXQuote-  { -- | Actual date of the FX rate.-    fxQuoteDate :: !Date-    -- | Currency pair of the FX rate.-  , fxQuotePair :: !CurrencyPair-    -- | Rate value of the FX rate.-  , fxQuoteRate :: !(Refined Positive (Quantity s))-  } deriving (Eq, Ord)---instance (KnownNat s) => Show (FXQuote s) where-  show (MkFXQuote d p r) = show (show p, show d, show (unrefine r))----- | 'Aeson.FromJSON' instance for 'Currency'------ >>> :set -XDataKinds--- >>> Aeson.eitherDecode "{\"date\": \"2021-01-01\", \"ccy1\": \"USD\", \"ccy2\": \"SGD\", \"rate\": 1.35}" :: Either String (FXQuote 2)--- Right ("USD/SGD","2021-01-01","1.35")--- >>> Aeson.eitherDecode "{\"date\": \"2021-01-01\", \"ccy1\": \"USD\", \"ccy2\": \"SGD\", \"rate\": 1.354}" :: Either String (FXQuote 2)--- Right ("USD/SGD","2021-01-01","1.35")--- >>> Aeson.eitherDecode "{\"date\": \"2021-01-01\", \"ccy1\": \"USD\", \"ccy2\": \"SGD\", \"rate\": 1.355}" :: Either String (FXQuote 2)--- Right ("USD/SGD","2021-01-01","1.36")--- >>> Aeson.eitherDecode "{\"date\": \"2021-01-01\", \"ccy1\": \"USD\", \"ccy2\": \"SGD\", \"rate\": 1.356}" :: Either String (FXQuote 2)--- Right ("USD/SGD","2021-01-01","1.36")--- >>> Aeson.eitherDecode "{\"date\": \"2021-01-01\", \"ccy1\": \"USD\", \"ccy2\": \"SGD\", \"rate\": 1.364}" :: Either String (FXQuote 2)--- Right ("USD/SGD","2021-01-01","1.36")--- >>> Aeson.eitherDecode "{\"date\": \"2021-01-01\", \"ccy1\": \"USD\", \"ccy2\": \"SGD\", \"rate\": 1.365}" :: Either String (FXQuote 2)--- Right ("USD/SGD","2021-01-01","1.36")--- >>> Aeson.eitherDecode "{\"date\": \"2021-01-01\", \"ccy1\": \"USD\", \"ccy2\": \"SGD\", \"rate\": 1.366}" :: Either String (FXQuote 2)--- Right ("USD/SGD","2021-01-01","1.37")--- >>> Aeson.eitherDecode "{\"date\": \"2021-01-01\", \"ccy1\": \"USD\", \"ccy2\": \"USD\", \"rate\": 1.35}" :: Either String (FXQuote 2)--- Left "Error in $: Can not create FX Rate. Error was: Can not create currency pair from same currencies: USD and USD"--- >>> Aeson.eitherDecode "{\"date\": \"2021-01-01\", \"ccy1\": \"USD\", \"ccy2\": \"SGD\", \"rate\": -1.35}" :: Either String (FXQuote 2)--- Left "Error in $: Can not create FX Rate. Error was:   The predicate (GreaterThan 0) failed with the message: Value is not greater than 0\n"-instance (KnownNat s) => Aeson.FromJSON (FXQuote s) where-  parseJSON = Aeson.withObject "FXQuote" $ \o -> join $ fxquoteFail-    <$> o .: "date"-    <*> o .: "ccy1"-    <*> o .: "ccy2"-    <*> o .: "rate"----- | 'Aeson.ToJSON' instance for 'Currency'------ >>> :set -XDataKinds--- >>> let rate = fxquoteUnsafe (read "2021-01-01") "USD" "SGD" 1.35 :: FXQuote 2--- >>> Aeson.encode rate--- "{\"ccy2\":\"SGD\",\"date\":\"2021-01-01\",\"rate\":1.35,\"ccy1\":\"USD\"}"-instance (KnownNat s) => Aeson.ToJSON (FXQuote s) where-  toJSON (MkFXQuote d cp v) = Aeson.object-    [ "date" .= d-    , "ccy1" .= baseCurrency cp-    , "ccy2" .= quoteCurrency cp-    , "rate" .= (toScientificDecimal . unQuantity . unrefine) v-    ]----- * Constructors--- &constructors----- | Smart constructor for 'FXQuote' values within 'MonadError' context.-fxquote-  :: (KnownNat s, MonadError String m)-  => Date        -- ^ Date of the FX rate.-  -> Currency    -- ^ First currency (from) of the FX rate.-  -> Currency    -- ^ Second currency (to) of the FX rate.-  -> Scientific  -- ^ FX rate value.-  -> m (FXQuote s)-fxquote d c1 c2 v = either (throwError . (<>) "Can not create FX Rate. Error was: ") pure $ do-  pair <- currencyPair c1 c2-  pval <- either (Left . show) pure $ refineError (quantity v)-  pure $ MkFXQuote d pair pval----- | Smart constructor for 'FXQuote' values within 'MonadFail' context.-fxquoteFail-  :: (KnownNat s, MonadFail m)-  => Date        -- ^ Date of the FX rate.-  -> Currency    -- ^ First currency (from) of the FX rate.-  -> Currency    -- ^ Second currency (to) of the FX rate.-  -> Scientific  -- ^ FX rate value.-  -> m (FXQuote s)-fxquoteFail d c1 c2 = either fail pure . fxquote d c1 c2----- | Unsafe 'FXQuote' constructor that 'error's if it fails.-fxquoteUnsafe-  :: KnownNat s-  => Date        -- ^ Date of the FX rate.-  -> Currency    -- ^ First currency (from) of the FX rate.-  -> Currency    -- ^ Second currency (to) of the FX rate.-  -> Scientific  -- ^ FX rate value.-  -> FXQuote s-fxquoteUnsafe d c1 c2 = either error id . fxquote d c1 c2

@@ -1,35 +0,0 @@-{-# LANGUAGE DataKinds      #-}-{-# LANGUAGE KindSignatures #-}--module Haspara.Internal.FXQuoteDatabase where--import qualified Data.HashMap.Strict       as HM-import           GHC.TypeLits              (KnownNat, Nat)-import           Haspara.Internal.Currency (CurrencyPair)-import           Haspara.Internal.Date     (Date, addDays)-import           Haspara.Internal.FXQuote  (FXQuote)---type FXQuoteDatabase (n :: Nat) = HM.HashMap CurrencyPair (FXQuotePairDatabase n)---data FXQuotePairDatabase (n :: Nat) = FXQuotePairDatabase-  { fxQuotePairDatabasePair  :: !CurrencyPair-  , fxQuotePairDatabaseTable :: !(HM.HashMap Date (FXQuote n))-  , fxQuotePairDatabaseSince :: !Date-  , fxQuotePairDatabaseUntil :: !Date-  }---findFXQuote :: KnownNat n => FXQuoteDatabase n -> CurrencyPair -> Date -> Maybe (FXQuote n)-findFXQuote db cp d = case HM.lookup cp db of-  Nothing  -> Nothing-  Just pdb -> findFXQuoteAux d pdb---findFXQuoteAux :: KnownNat n => Date -> FXQuotePairDatabase n -> Maybe (FXQuote n)-findFXQuoteAux d db-  | d < fxQuotePairDatabaseSince db = Nothing-  | otherwise = case HM.lookup d (fxQuotePairDatabaseTable db) of-      Nothing -> findFXQuoteAux (addDays (-1) d) db-      Just fx -> Just fx

@@ -1,67 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Haspara.Internal.Id where--import qualified Data.Aeson          as Aeson-import qualified Data.HashMap.Strict as HM-import           Data.Hashable       (Hashable)----- | Type encoding for entity identifiers.------ This encoding allows us to provide a phantom type for distinguishing between--- identifiers of varying types and an underlying identifier type.------ For example:------ >>> data A = A--- >>> data B = B--- >>> data C = C--- >>> type IdA = Id A Int--- >>> type IdB = Id B Int--- >>> type IdC = Id C String--- >>> let idA = Id 1 :: IdA--- >>> let idB = Id 1 :: IdB--- >>> let idC = Id "C1" :: IdC--- >>> idA--- 1--- >>> idB--- 1--- >>> idC--- "C1"--- >>> idA == idA--- True--- >>> -- idA == idB  -- Compile error as: Couldn't match type ‘B’ with ‘A’------ Hashes, on the otherhand, can be compared:------ >>> import Data.Hashable--- >>> hash idA == hash idB--- True-newtype Id a b = Id { unId :: b }-  deriving(Eq, Ord, Hashable)---instance (Show b) => Show (Id a b) where-  show (Id x) = show x---instance (Aeson.FromJSON b) => Aeson.FromJSON (Id a b) where-  parseJSON = fmap Id . Aeson.parseJSON---instance (Aeson.ToJSON b) => Aeson.ToJSON (Id a b) where-  toJSON (Id x) = Aeson.toJSON x----- | Type encoding for a lookup table from entity 'Id's to corresponding entities.------ >>> data A = A Int String deriving Show--- >>> type IdA = Id A Int--- >>> let a1 = A 1 "a1"--- >>> let a2 = A 2 "a2"--- >>> let a3 = A 3 "a3"--- >>> let table = HM.fromList [(Id 1, a1), (Id 2, a2), (Id 3, a3)] :: IdLookup A Int--- >>> HM.lookup (Id 1) table--- Just (A 1 "a1")-type IdLookup a b = HM.HashMap (Id a b) a

@@ -1,116 +0,0 @@-{-# LANGUAGE DataKinds      #-}-{-# LANGUAGE KindSignatures #-}--module Haspara.Internal.Money where--import           Control.Applicative       ((<|>))-import           Data.Aeson                ((.:), (.=))-import qualified Data.Aeson                as Aeson-import           Data.Scientific           (Scientific)-import           GHC.TypeLits              (KnownNat, Nat)-import           Haspara.Internal.Currency (Currency, baseCurrency, quoteCurrency)-import           Haspara.Internal.Date     (Date)-import           Haspara.Internal.FXQuote  (FXQuote(fxQuotePair, fxQuoteRate))-import           Haspara.Internal.Quantity (Quantity, quantity, times)-import           Refined                   (unrefine)---data Money (s :: Nat) =-    MoneySome Date Currency (Quantity s)-  | MoneyZero-  | MoneyFail String-  deriving (Eq, Ord, Show)----- | 'Aeson.FromJSON' instance for 'Money'.------ >>> Aeson.decode "{\"qty\":42,\"ccy\":\"USD\",\"date\":\"2021-01-01\"}" :: Maybe (Money 2)--- Just (MoneySome 2021-01-01 USD 42.00)--- >>> Aeson.decode "0" :: Maybe (Money 2)--- Just MoneyZero--- >>> Aeson.decode "{\"error\": \"oops\"}" :: Maybe (Money 2)--- Just (MoneyFail "oops")-instance (KnownNat s) => Aeson.FromJSON (Money s) where-  parseJSON (Aeson.Number 0) = pure MoneyZero-  parseJSON (Aeson.Object obj) = parseSome obj <|> parseFail obj-    where-      parseSome o = MoneySome-        <$> o .: "date"-        <*> o .: "ccy"-        <*> o .: "qty"-      parseFail o = MoneyFail <$> o .: "error"-  parseJSON x = fail ("Not a monetary value: " <> show x)------ | 'Aeson.ToJSON' instance for 'Money'.------ >>> Aeson.encode (MoneySome (read "2021-01-01") ("USD" :: Currency) (42 :: Quantity 0))--- "{\"qty\":42,\"ccy\":\"USD\",\"date\":\"2021-01-01\"}"--- >>> Aeson.encode (MoneyZero :: Money 2)--- "0"--- >>> Aeson.encode (MoneyFail "oops" :: Money 2)--- "{\"error\":\"oops\"}"-instance (KnownNat s) => Aeson.ToJSON (Money s) where-  toJSON (MoneySome d c q) = Aeson.object [ "date" .= d, "ccy" .= c, "qty" .= q ]-  toJSON MoneyZero         = Aeson.Number 0-  toJSON (MoneyFail s)     = Aeson.object ["error" .= s]---mkMoney :: KnownNat s => Date -> Currency -> Quantity s -> Money s-mkMoney = MoneySome---mkMoneyFromScientific :: KnownNat s => Date -> Currency -> Scientific -> Money s-mkMoneyFromScientific d c s = mkMoney d c (quantity s)---moneyDate :: KnownNat s => Money s -> Maybe Date-moneyDate (MoneySome d _ _) = Just d-moneyDate MoneyZero         = Nothing-moneyDate (MoneyFail _)     = Nothing---moneyCurrency :: KnownNat s => Money s -> Maybe Currency-moneyCurrency (MoneySome _ c _) = Just c-moneyCurrency MoneyZero         = Nothing-moneyCurrency (MoneyFail _)     = Nothing---moneyQuantity :: KnownNat s => Money s -> Maybe (Quantity s)-moneyQuantity (MoneySome _ _ q) = Just q-moneyQuantity MoneyZero         = Nothing-moneyQuantity (MoneyFail _)     = Nothing----- | Converts the given 'Money' value to another given currency with the given--- rate.------ >>> import Haspara--- >>> let eur = either error id $ currency "EUR"--- >>> let usd = either error id $ currency "USD"--- >>> let date = read "2021-01-01" :: Date--- >>> let eurmoney = mkMoney date eur (quantity 0.42 :: Quantity 2) :: Money 2--- >>> convert eurmoney eur (quantity 1 :: Quantity 4)--- MoneySome 2021-01-01 EUR 0.42--- >>> convert eurmoney usd (quantity 1 :: Quantity 4)--- MoneySome 2021-01-01 USD 0.42--- >>> convert eurmoney usd (quantity 1.1516 :: Quantity 4)--- MoneySome 2021-01-01 USD 0.48-convert :: (KnownNat s, KnownNat k) => Money s -> Currency -> Quantity k -> Money s-convert MoneyZero _ _                    = MoneyZero-convert x@(MoneyFail _) _ _              = x-convert x@(MoneySome d cbase q) cquot rate-  | cbase == cquot && rate == 1 = x-  | cbase == cquot && rate /= 1 = MoneyFail $ "Attempting to convert from same currency with rate != 1: " <> show x <> " to " <> show cquot <> " with " <> show rate-  | otherwise                   = MoneySome d cquot (times q rate)----- | Converts the given 'Money' value to another currency with the given--- 'FXQuote'.-convertWithQuote :: (KnownNat s, KnownNat k) => Money s -> FXQuote k -> Money s-convertWithQuote MoneyZero _                    = MoneyZero-convertWithQuote x@(MoneyFail _) _              = x-convertWithQuote x@(MoneySome _ cbase _) quote-  | cbase /= baseCurrency (fxQuotePair quote) = MoneyFail $ "Attempting to convert with incompatible base currency: " <> show x <> " with " <> show quote-  | otherwise = convert x (quoteCurrency (fxQuotePair quote)) (unrefine $ fxQuoteRate quote)

@@ -1,365 +0,0 @@-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE DeriveGeneric              #-}-{-# LANGUAGE DeriveLift                 #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE KindSignatures             #-}-{-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE StandaloneDeriving         #-}-{-# LANGUAGE TypeOperators              #-}--{-# OPTIONS_GHC -Wno-orphans #-}--module Haspara.Internal.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 qualified Data.Scientific            as S-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----- $setup--- >>> :set -XDataKinds----- | Type encoding for common quantity values with given scaling (digits after--- the decimal point).------ >>> 42 :: Quantity 0--- 42--- >>> 42 :: Quantity 1--- 42.0--- >>> 42 :: Quantity 2--- 42.00--- >>> 41 + 1 :: Quantity 2--- 42.00--- >>> 43 - 1 :: Quantity 2--- 42.00--- >>> 2 * 3 * 7 :: Quantity 2--- 42.00--- >>> negate (-42) :: Quantity 2--- 42.00--- >>> abs (-42) :: Quantity 2--- 42.00--- >>> signum (-42) :: Quantity 2--- -1.00--- >>> fromInteger 42 :: Quantity 2--- 42.00--- >>> quantity 0.415 :: Quantity 2--- 0.42--- >>> quantity 0.425 :: Quantity 2--- 0.42--- >>> quantityLossless 0.42 :: Either String (Quantity 2)--- Right 0.42--- >>> quantityLossless 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 }-  deriving (Eq, Ord, Generic, Num)----- | Orphan 'TH.Lift' instance for 'Quantity'.------ TODO: Avoid having an orphan instance for @Decimal r s p@?-deriving instance TH.Lift (D.Decimal D.RoundHalfEven s Integer)----- | 'TH.Lift' instance for 'Quantity'.-deriving instance TH.Lift (Quantity s)----- | 'Aeson.FromJSON' instance for 'Quantity'.------ >>> Aeson.decode "0.42" :: Maybe (Quantity 2)--- Just 0.42--- >>> Aeson.decode "0.415" :: Maybe (Quantity 2)--- Just 0.42--- >>> Aeson.decode "0.425" :: Maybe (Quantity 2)--- Just 0.42-instance (KnownNat s) => Aeson.FromJSON (Quantity s) where-  parseJSON = Aeson.withScientific "Quantity" (pure . quantity)----- | 'Aeson.ToJSON' instance for 'Quantity'.------ >>> Aeson.encode (quantity 0.42 :: Quantity 2)--- "0.42"-instance (KnownNat s) => Aeson.ToJSON (Quantity s) where-  toJSON = Aeson.Number . D.toScientificDecimal . unQuantity----- | Numeric arithmetic over 'Quantity' values.------ >>> import Numeric.Decimal--- >>> let a = Arith (quantity 10) + Arith (quantity 32) :: Arith (Quantity 2)--- >>> arithMaybe a--- Just 42.00--- >>> arithM (41 + 1) :: Either SomeException (Quantity 2)--- Right 42.00--- >>> arithM (43 - 1) :: Either SomeException (Quantity 2)--- Right 42.00--- >>> arithM (2 * 3 * 7) :: Either SomeException (Quantity 2)--- Right 42.00--- >>> arithM (signum 42) :: Either SomeException (Quantity 2)--- Right 1.00--- >>> arithM (signum (-42)) :: Either SomeException (Quantity 2)--- Right -1.00--- >>> arithM (abs 42) :: Either SomeException (Quantity 2)--- Right 42.00--- >>> arithM (abs (-42)) :: Either SomeException (Quantity 2)--- Right 42.00--- >>> arithM (fromInteger 42) :: Either SomeException (Quantity 2)--- Right 42.00-instance (KnownNat s) => Num (D.Arith (Quantity s)) where-  (+) = liftA2 (+)-  (-) = liftA2 (-)-  (*) = liftA2 (*)-  signum = fmap signum-  abs = fmap abs-  fromInteger = pure . MkQuantity . D.fromIntegerDecimal----- | Fractional arithmetic over 'Quantity' values.------ >>> import Numeric.Decimal--- >>> arithM (fromRational 0.42) :: Either SomeException (Quantity 2)--- Right 0.42--- >>> arithM (fromRational 0.415) :: Either SomeException (Quantity 2)--- Left PrecisionLoss (83 % 200) to 2 decimal spaces--- >>> arithM $ (fromRational 0.84) / (fromRational 2) :: Either SomeException (Quantity 2)--- Right 0.42--- >>> arithM $ (fromRational 0.42) / (fromRational 0) :: Either SomeException (Quantity 2)--- Left divide by zero--- >>> let a = 84 :: Quantity 2--- >>> let b =  2 :: Quantity 2--- >>> let c =  0 :: Quantity 2--- >>> arithM (Arith a / Arith b) :: Either SomeException (Quantity 2)--- Right 42.00--- >>> arithM (Arith a / Arith b / Arith c) :: Either SomeException (Quantity 2)--- Left divide by zero-instance (KnownNat s) => Fractional (D.Arith (Quantity s)) where-  a / b = fmap MkQuantity $ fmap unQuantity a / fmap unQuantity b-  fromRational = fmap MkQuantity . D.fromRationalDecimalWithoutLoss----- | 'Show' instance for 'Quantity'.------ >>> show (42 :: Quantity 2)--- "42.00"--- >>> 42 :: Quantity 2--- 42.00-instance KnownNat s => Show (Quantity s) where-  show = show . unQuantity----- | Constructs 'Quantity' values from 'S.Scientific' values in a lossy way.------ This function uses 'quantityAux' in case that the lossless attempt fails. We--- could have used 'quantityAux' directly. However, 'quantityAux' is doing too--- much (see 'roundScientific'). Therefore, we are first attempting a lossless--- construction (see 'quantityLossless') and we fallback to 'quantityAux' in--- case the lossless construction fails.------ >>> quantity 0 :: Quantity 0--- 0--- >>> quantity 0 :: Quantity 1--- 0.0--- >>> quantity 0 :: Quantity 2--- 0.00--- >>> quantity 0.04 :: Quantity 1--- 0.0--- >>> quantity 0.05 :: Quantity 1--- 0.0--- >>> quantity 0.06 :: Quantity 1--- 0.1--- >>> quantity 0.14 :: Quantity 1--- 0.1--- >>> quantity 0.15 :: Quantity 1--- 0.2--- >>> quantity 0.16 :: Quantity 1--- 0.2--- >>> quantity 0.04 :: Quantity 2--- 0.04--- >>> quantity 0.05 :: Quantity 2--- 0.05--- >>> quantity 0.06 :: Quantity 2--- 0.06--- >>> quantity 0.14 :: Quantity 2--- 0.14--- >>> quantity 0.15 :: Quantity 2--- 0.15--- >>> quantity 0.16 :: Quantity 2--- 0.16--- >>> quantity 0.04 :: Quantity 3--- 0.040--- >>> quantity 0.05 :: Quantity 3--- 0.050--- >>> quantity 0.06 :: Quantity 3--- 0.060--- >>> quantity 0.14 :: Quantity 3--- 0.140--- >>> quantity 0.15 :: Quantity 3--- 0.150--- >>> quantity 0.16 :: Quantity 3--- 0.160-quantity :: KnownNat s => S.Scientific -> Quantity s-quantity s = case quantityLossless s of-  Left _   -> quantityAux s-  Right dv -> dv----- | Auxiliary function for 'quantity' implementation.------ See 'quantity' why we need this function and why we haven't used it as the--- direct implementation of 'quantity'.------ Call-sites should avoid using this function directly due to its performance--- characteristics.-quantityAux :: forall s. KnownNat s => S.Scientific -> Quantity s-quantityAux x = fromRight err $ quantityLossless (roundScientific nof x)-  where-    -- Get the term-level scaling for the target value:-    nof = fromIntegral $ natVal (Proxy :: Proxy s)--    -- This function should NOT fail in practice ever, but theoretically it can-    -- due to type signatures. We will let it error with a message to ourselves:-    err = error $ "PROGRAMMING ERROR: Can not construct 'Quantity " <> show nof <> "' with '" <> show x <> "' in a lossy way."----- | Constructs 'Quantity' values from 'S.Scientific' values in a lossy way.------ >>> quantityLossless 0 :: Either String (Quantity 0)--- Right 0--- >>> quantityLossless 0 :: Either String (Quantity 1)--- Right 0.0--- >>> quantityLossless 0 :: Either String (Quantity 2)--- Right 0.00--- >>> quantityLossless 0.04 :: Either String (Quantity 1)--- Left "Underflow while trying to create quantity: 4.0e-2"--- >>> quantityLossless 0.05 :: Either String (Quantity 1)--- Left "Underflow while trying to create quantity: 5.0e-2"--- >>> quantityLossless 0.06 :: Either String (Quantity 1)--- Left "Underflow while trying to create quantity: 6.0e-2"--- >>> quantityLossless 0.14 :: Either String (Quantity 1)--- Left "Underflow while trying to create quantity: 0.14"--- >>> quantityLossless 0.15 :: Either String (Quantity 1)--- Left "Underflow while trying to create quantity: 0.15"--- >>> quantityLossless 0.16 :: Either String (Quantity 1)--- Left "Underflow while trying to create quantity: 0.16"--- >>> quantityLossless 0.04 :: Either String (Quantity 2)--- Right 0.04--- >>> quantityLossless 0.05 :: Either String (Quantity 2)--- Right 0.05--- >>> quantityLossless 0.06 :: Either String (Quantity 2)--- Right 0.06--- >>> quantityLossless 0.14 :: Either String (Quantity 2)--- Right 0.14--- >>> quantityLossless 0.15 :: Either String (Quantity 2)--- Right 0.15--- >>> quantityLossless 0.16 :: Either String (Quantity 2)--- Right 0.16--- >>> quantityLossless 0.04 :: Either String (Quantity 3)--- Right 0.040--- >>> quantityLossless 0.05 :: Either String (Quantity 3)--- Right 0.050--- >>> quantityLossless 0.06 :: Either String (Quantity 3)--- Right 0.060--- >>> quantityLossless 0.14 :: Either String (Quantity 3)--- Right 0.140--- >>> quantityLossless 0.15 :: Either String (Quantity 3)--- Right 0.150--- >>> quantityLossless 0.16 :: Either String (Quantity 3)--- Right 0.160-quantityLossless :: (KnownNat s, MonadError String m) => S.Scientific -> m (Quantity s)-quantityLossless s = either (const $ throwError ("Underflow while trying to create quantity: " <> show s)) (pure . MkQuantity) $ D.fromScientificDecimal s----- | Rounds given quantity by @k@ digits.------ >>> roundQuantity (quantity 0.415 :: Quantity 3) :: Quantity 2--- 0.42--- >>> roundQuantity (quantity 0.425 :: Quantity 3) :: Quantity 2--- 0.42-roundQuantity :: KnownNat k => Quantity (n + k) -> Quantity n-roundQuantity (MkQuantity d) = MkQuantity (D.roundDecimal d)----- | Multiplies two quantities with different scales and rounds back to the scale of the frst operand.------ >>> times (quantity 0.42 :: Quantity 2) (quantity 0.42 :: Quantity 2)--- 0.18-times :: (KnownNat s, KnownNat k) => Quantity s -> Quantity k -> Quantity s-times q1 q2 = roundQuantity (timesLossless q1 q2)----- | Multiplies two quantities with different scales.------ >>> timesLossless (quantity 0.42 :: Quantity 2) (quantity 0.42 :: Quantity 2)--- 0.1764-timesLossless :: (KnownNat s, KnownNat k) => Quantity s -> Quantity k -> Quantity (s + k)-timesLossless (MkQuantity d1) (MkQuantity d2) = MkQuantity (D.timesDecimal d1 d2)----- | Rounds a given scientific into a new scientific with given max digits after--- decimal point.------ This uses half-even rounding method.------ >>> roundScientific 0 0.4--- 0.0--- >>> roundScientific 0 0.5--- 0.0--- >>> roundScientific 0 0.6--- 1.0--- >>> roundScientific 0 1.4--- 1.0--- >>> roundScientific 0 1.5--- 2.0--- >>> roundScientific 0 1.6--- 2.0--- >>> roundScientific 1 0.04--- 0.0--- >>> roundScientific 1 0.05--- 0.0--- >>> roundScientific 1 0.06--- 0.1--- >>> roundScientific 1 0.14--- 0.1--- >>> roundScientific 1 0.15--- 0.2--- >>> roundScientific 1 0.16--- 0.2--- >>> roundScientific 1 3.650--- 3.6--- >>> roundScientific 1 3.740--- 3.7--- >>> roundScientific 1 3.749--- 3.7--- >>> roundScientific 1 3.750--- 3.8--- >>> roundScientific 1 3.751--- 3.8--- >>> roundScientific 1  3.760--- 3.8--- >>> roundScientific 1 (-3.650)--- -3.6--- >>> roundScientific 1 (-3.740)--- -3.7--- >>> roundScientific 1 (-3.749)--- -3.7--- >>> roundScientific 1 (-3.750)--- -3.8--- >>> roundScientific 1 (-3.751)--- -3.8--- >>> roundScientific 1 (-3.760)--- -3.8------ TODO: Refactor to improve the performance of this function.-roundScientific :: Int -> S.Scientific -> S.Scientific-roundScientific = (read .) . S.formatScientific S.Fixed . Just

@@ -0,0 +1,121 @@+-- | 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           Data.Time            (Day)+import qualified Deriving.Aeson.Stock as DAS+import           GHC.Stack            (HasCallStack)+import           GHC.TypeLits         (KnownNat, Nat)+import           Haspara.Currency     (Currency, CurrencyPair(..))+import           Haspara.FxQuote      (FxQuote(..))+import           Haspara.Quantity     (Quantity, times)+import           Refined              (unrefine)+++-- | Type encoding for dated monetary values.+--+-- A dated monetary value is a 3-tuple of:+--+-- 1. a date when the monetary value is effective as of,+-- 2. the currency of the monetary value, and+-- 3. the quantity of the monetary value.+data Money (s :: Nat) = Money+  { moneyDate     :: !Day+  , moneyCurrency :: !Currency+  , moneyQuantity :: !(Quantity s)+  }+  deriving (Eq, DAS.Generic, Ord, Show)+  deriving (DAS.FromJSON, DAS.ToJSON) via DAS.PrefixedSnake "money" (Money s)+++-- | Type encoding of a monetary context.+class MonadThrow m => Monetary m where+  -- | Converts the given monetary value in one currency to another currency.+  --+  -- Note that the conversion is performed with an FX rate quotation as of the+  -- date of the given monetary value.+  convertM+    :: HasCallStack+    => KnownNat s+    => Currency+    -> Money s+    -> m (Money s)++  -- | Converts the given monetary value in one currency to another currency as+  -- of the given date.+  --+  -- The rule is:+  --+  -- @+  -- convertAsofM <DATE2> <CCY2> (Money <DATE1> <CCY1> <QTY1>) === convertM <CCY2> (Money <DATE2> <CCY1> <QTY1>)+  -- @+  convertAsofM+    :: HasCallStack+    => KnownNat s+    => Day+    -> Currency+    -> Money s+    -> m (Money s)+  convertAsofM date ccyN (Money _ ccy qty) = convertM ccyN (Money date ccy qty)+++-- | Attempts to convert the given 'Money' to another using the given 'FxQuote'+-- value.+--+-- This function runs some guards before attempting to do the conversion:+--+-- 1. Base currency of the FX rate quotation should be the same as the currency+--    of the monetary value, throws 'IncompatibleCurrenciesException' otherwise.+-- 2. Date of the FX rate quotation should be equal to or greater than the date+--    of the monetary value, throws 'IncompatibleDatesException' otherwise.+-- 3. Rate of the FX rate quotation should be @1@ if the base and quote+--    quotation are same, throws 'InconsistentFxQuoteException' otherwise.+convert+  :: HasCallStack+  => MonadThrow m+  => KnownNat s+  => KnownNat k+  => Money s+  -> FxQuote k+  -> m (Money s)+convert (Money date ccy qty) quote@(MkFxQuote (CurrencyPair ccy1 ccy2) asof rate) = do+  when (ccy /= ccy1) (throwM (IncompatibleCurrenciesException ccy ccy1))+  when (asof < date) (throwM (IncompatibleDatesException date asof))+  when (ccy1 == ccy2 && unrefine rate /= 1) (throwM (InconsistentFxQuoteException quote))+  pure (Money asof ccy2 (times qty (unrefine rate)))+++-- | Type encoding of exceptions thrown by the `Haspara.Monetary` module.+data MonetaryException where+  -- | Indicates that we received a currency other than the expected currency.+  IncompatibleCurrenciesException+    :: HasCallStack+    => 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+    -> 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.+    -> MonetaryException+++deriving instance Show MonetaryException+++instance Exception MonetaryException

@@ -1,38 +0,0 @@--- | This module provides base data definitions and functions for 'Haspara'--- library.----module Haspara.Money-  ( ---    -- * Money-    -- &money-    ---    -- ** Data Definition-    -- &quantityDataDefinition-    ---    Money(..)-  , moneyDate-  , moneyCurrency-  , moneyQuantity-    ---    -- ** Constructors-    -- &fxquoteConstructors-    ---  , mkMoney-  , mkMoneyFromScientific-    ---    -- ** Operations-    -- &operations-  , convert-  , convertWithQuote-  ) where--import Haspara.Internal.Money-       ( Money(..)-       , convert-       , convertWithQuote-       , mkMoney-       , mkMoneyFromScientific-       , moneyCurrency-       , moneyDate-       , moneyQuantity-       )

@@ -1,25 +1,377 @@--- | This module provides definitions and functions to encode and work on--- quantities with fixed decimal points.+-- | This module provides definitions for modeling and working with quantities+-- with fixed decimal points.++{-# LANGUAGE DataKinds #-}++{-# OPTIONS_GHC -Wno-orphans #-}++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 qualified Language.Haskell.TH.Syntax as TH+import qualified Numeric.Decimal            as D+import           Refined                    (NonNegative, Refined)+++-- * Data Definition+-- $dataDefinition+++-- | Type encoding for quantity values with a given scaling (digits after the+-- decimal point). ---module Haspara.Quantity-  ( -- * Data Definition-    -- &dataDefinition-    ---    Quantity-  , unQuantity-    ---    -- ** Constructors-    -- &constructors-    ---  , quantity-  , quantityLossless-    ---    -- ** Operations-    -- &operations-    ---  , roundQuantity-  , times-  , timesLossless-  ) where+-- >>> 42 :: Quantity 0+-- 42+-- >>> 42 :: Quantity 1+-- 42.0+-- >>> 42 :: Quantity 2+-- 42.00+-- >>> 41 + 1 :: Quantity 2+-- 42.00+-- >>> 43 - 1 :: Quantity 2+-- 42.00+-- >>> 2 * 3 * 7 :: Quantity 2+-- 42.00+-- >>> negate (-42) :: Quantity 2+-- 42.00+-- >>> abs (-42) :: Quantity 2+-- 42.00+-- >>> signum (-42) :: Quantity 2+-- -1.00+-- >>> fromInteger 42 :: Quantity 2+-- 42.00+-- >>> mkQuantity 0.415 :: Quantity 2+-- 0.42+-- >>> mkQuantity 0.425 :: Quantity 2+-- 0.42+-- >>> mkQuantityLossless 0.42 :: Either String (Quantity 2)+-- 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 }+  deriving (Eq, Ord, Generic, Num) -import Haspara.Internal.Quantity (Quantity(unQuantity), quantity, quantityLossless, roundQuantity, times, timesLossless)++-- | Type definition for unsigned 'Quantity' values.+type UnsignedQuantity s = Refined NonNegative (Quantity s)+++-- | Orphan 'TH.Lift' instance for 'Quantity'.+--+-- TODO: Avoid having an orphan instance for @Decimal r s p@?+deriving instance TH.Lift (D.Decimal D.RoundHalfEven s Integer)+++-- | 'TH.Lift' instance for 'Quantity'.+deriving instance TH.Lift (Quantity s)+++-- | 'Aeson.FromJSON' instance for 'Quantity'.+--+-- >>> Aeson.decode "0.42" :: Maybe (Quantity 2)+-- Just 0.42+-- >>> Aeson.decode "0.415" :: Maybe (Quantity 2)+-- Just 0.42+-- >>> Aeson.decode "0.425" :: Maybe (Quantity 2)+-- Just 0.42+instance (KnownNat s) => Aeson.FromJSON (Quantity s) where+  parseJSON = Aeson.withScientific "Quantity" (pure . mkQuantity)+++-- | 'Aeson.ToJSON' instance for 'Quantity'.+--+-- >>> Aeson.encode (mkQuantity 0.42 :: Quantity 2)+-- "0.42"+instance (KnownNat s) => Aeson.ToJSON (Quantity s) where+  toJSON = Aeson.Number . D.toScientificDecimal . unQuantity+++-- | Numeric arithmetic over 'Quantity' values.+--+-- >>> import Numeric.Decimal+-- >>> let a = Arith (mkQuantity 10) + Arith (mkQuantity 32) :: Arith (Quantity 2)+-- >>> arithMaybe a+-- Just 42.00+-- >>> arithM (41 + 1) :: Either SomeException (Quantity 2)+-- Right 42.00+-- >>> arithM (43 - 1) :: Either SomeException (Quantity 2)+-- Right 42.00+-- >>> arithM (2 * 3 * 7) :: Either SomeException (Quantity 2)+-- Right 42.00+-- >>> arithM (signum 42) :: Either SomeException (Quantity 2)+-- Right 1.00+-- >>> arithM (signum (-42)) :: Either SomeException (Quantity 2)+-- Right -1.00+-- >>> arithM (abs 42) :: Either SomeException (Quantity 2)+-- Right 42.00+-- >>> arithM (abs (-42)) :: Either SomeException (Quantity 2)+-- Right 42.00+-- >>> arithM (fromInteger 42) :: Either SomeException (Quantity 2)+-- Right 42.00+instance (KnownNat s) => Num (D.Arith (Quantity s)) where+  (+) = liftA2 (+)+  (-) = liftA2 (-)+  (*) = liftA2 (*)+  signum = fmap signum+  abs = fmap abs+  fromInteger = pure . MkQuantity . D.fromIntegerDecimal+++-- | Fractional arithmetic over 'Quantity' values.+--+-- >>> import Numeric.Decimal+-- >>> arithM (fromRational 0.42) :: Either SomeException (Quantity 2)+-- Right 0.42+-- >>> arithM (fromRational 0.415) :: Either SomeException (Quantity 2)+-- Left PrecisionLoss (83 % 200) to 2 decimal spaces+-- >>> arithM $ (fromRational 0.84) / (fromRational 2) :: Either SomeException (Quantity 2)+-- Right 0.42+-- >>> arithM $ (fromRational 0.42) / (fromRational 0) :: Either SomeException (Quantity 2)+-- Left divide by zero+-- >>> let a = 84 :: Quantity 2+-- >>> let b =  2 :: Quantity 2+-- >>> let c =  0 :: Quantity 2+-- >>> arithM (Arith a / Arith b) :: Either SomeException (Quantity 2)+-- Right 42.00+-- >>> arithM (Arith a / Arith b / Arith c) :: Either SomeException (Quantity 2)+-- Left divide by zero+instance (KnownNat s) => Fractional (D.Arith (Quantity s)) where+  a / b = fmap MkQuantity $ fmap unQuantity a / fmap unQuantity b+  fromRational = fmap MkQuantity . D.fromRationalDecimalWithoutLoss+++-- | 'Show' instance for 'Quantity'.+--+-- >>> show (42 :: Quantity 2)+-- "42.00"+-- >>> 42 :: Quantity 2+-- 42.00+instance KnownNat s => Show (Quantity s) where+  show = show . unQuantity+++-- * Smart Constructors+-- $smartConstructors+++-- | Constructs 'Quantity' values from 'Scientific' values in a lossy way.+--+-- This function uses 'mkQuantityAux' in case that the lossless attempt fails.+-- We could have used 'mkQuantityAux' directly. However, 'mkQuantityAux' is+-- doing too much (see 'roundScientific'). Therefore, we are first attempting a+-- lossless construction (see 'mkQuantityLossless') and we fallback to+-- 'mkQuantityAux' in case the lossless construction fails.+--+-- >>> mkQuantity 0 :: Quantity 0+-- 0+-- >>> mkQuantity 0 :: Quantity 1+-- 0.0+-- >>> mkQuantity 0 :: Quantity 2+-- 0.00+-- >>> mkQuantity 0.04 :: Quantity 1+-- 0.0+-- >>> mkQuantity 0.05 :: Quantity 1+-- 0.0+-- >>> mkQuantity 0.06 :: Quantity 1+-- 0.1+-- >>> mkQuantity 0.14 :: Quantity 1+-- 0.1+-- >>> mkQuantity 0.15 :: Quantity 1+-- 0.2+-- >>> mkQuantity 0.16 :: Quantity 1+-- 0.2+-- >>> mkQuantity 0.04 :: Quantity 2+-- 0.04+-- >>> mkQuantity 0.05 :: Quantity 2+-- 0.05+-- >>> mkQuantity 0.06 :: Quantity 2+-- 0.06+-- >>> mkQuantity 0.14 :: Quantity 2+-- 0.14+-- >>> mkQuantity 0.15 :: Quantity 2+-- 0.15+-- >>> mkQuantity 0.16 :: Quantity 2+-- 0.16+-- >>> mkQuantity 0.04 :: Quantity 3+-- 0.040+-- >>> mkQuantity 0.05 :: Quantity 3+-- 0.050+-- >>> mkQuantity 0.06 :: Quantity 3+-- 0.060+-- >>> mkQuantity 0.14 :: Quantity 3+-- 0.140+-- >>> mkQuantity 0.15 :: Quantity 3+-- 0.150+-- >>> mkQuantity 0.16 :: Quantity 3+-- 0.160+mkQuantity :: KnownNat s => Scientific -> Quantity s+mkQuantity s = case mkQuantityLossless s of+  Left _   -> mkQuantityAux s+  Right dv -> dv+++-- | Constructs 'Quantity' values from 'Scientific' values in a lossy way.+--+-- >>> mkQuantityLossless 0 :: Either String (Quantity 0)+-- Right 0+-- >>> mkQuantityLossless 0 :: Either String (Quantity 1)+-- Right 0.0+-- >>> mkQuantityLossless 0 :: Either String (Quantity 2)+-- Right 0.00+-- >>> mkQuantityLossless 0.04 :: Either String (Quantity 1)+-- Left "Underflow while trying to create quantity: 4.0e-2"+-- >>> mkQuantityLossless 0.05 :: Either String (Quantity 1)+-- Left "Underflow while trying to create quantity: 5.0e-2"+-- >>> mkQuantityLossless 0.06 :: Either String (Quantity 1)+-- Left "Underflow while trying to create quantity: 6.0e-2"+-- >>> mkQuantityLossless 0.14 :: Either String (Quantity 1)+-- Left "Underflow while trying to create quantity: 0.14"+-- >>> mkQuantityLossless 0.15 :: Either String (Quantity 1)+-- Left "Underflow while trying to create quantity: 0.15"+-- >>> mkQuantityLossless 0.16 :: Either String (Quantity 1)+-- Left "Underflow while trying to create quantity: 0.16"+-- >>> mkQuantityLossless 0.04 :: Either String (Quantity 2)+-- Right 0.04+-- >>> mkQuantityLossless 0.05 :: Either String (Quantity 2)+-- Right 0.05+-- >>> mkQuantityLossless 0.06 :: Either String (Quantity 2)+-- Right 0.06+-- >>> mkQuantityLossless 0.14 :: Either String (Quantity 2)+-- Right 0.14+-- >>> mkQuantityLossless 0.15 :: Either String (Quantity 2)+-- Right 0.15+-- >>> mkQuantityLossless 0.16 :: Either String (Quantity 2)+-- Right 0.16+-- >>> mkQuantityLossless 0.04 :: Either String (Quantity 3)+-- Right 0.040+-- >>> mkQuantityLossless 0.05 :: Either String (Quantity 3)+-- Right 0.050+-- >>> mkQuantityLossless 0.06 :: Either String (Quantity 3)+-- Right 0.060+-- >>> mkQuantityLossless 0.14 :: Either String (Quantity 3)+-- Right 0.140+-- >>> mkQuantityLossless 0.15 :: Either String (Quantity 3)+-- Right 0.150+-- >>> mkQuantityLossless 0.16 :: Either String (Quantity 3)+-- Right 0.160+mkQuantityLossless :: (KnownNat s, MonadError String m) => Scientific -> m (Quantity s)+mkQuantityLossless s = either (const $ throwError ("Underflow while trying to create quantity: " <> show s)) (pure . MkQuantity) $ D.fromScientificDecimal s+++-- * Utilities+-- $utilities+++-- | Rounds given quantity by @k@ digits.+--+-- >>> roundQuantity (mkQuantity 0.415 :: Quantity 3) :: Quantity 2+-- 0.42+-- >>> roundQuantity (mkQuantity 0.425 :: Quantity 3) :: Quantity 2+-- 0.42+roundQuantity :: KnownNat k => Quantity (n + k) -> Quantity n+roundQuantity (MkQuantity d) = MkQuantity (D.roundDecimal d)+++-- | Multiplies two quantities with different scales and rounds back to the scale of the frst operand.+--+-- >>> times (mkQuantity 0.42 :: Quantity 2) (mkQuantity 0.42 :: Quantity 2)+-- 0.18+times :: (KnownNat s, KnownNat k) => Quantity s -> Quantity k -> Quantity s+times q1 q2 = roundQuantity (timesLossless q1 q2)+++-- | Multiplies two quantities with different scales.+--+-- >>> timesLossless (mkQuantity 0.42 :: Quantity 2) (mkQuantity 0.42 :: Quantity 2)+-- 0.1764+timesLossless :: (KnownNat s, KnownNat k) => Quantity s -> Quantity k -> Quantity (s + k)+timesLossless (MkQuantity d1) (MkQuantity d2) = MkQuantity (D.timesDecimal d1 d2)+++-- * Internal+-- $internal+++-- | Auxiliary function for constructing 'Quantity' values.+--+-- See 'mkQuantity' why we need this function and why we haven't used it as the+-- direct implementation of 'mkQuantity'.+--+-- Call-sites should avoid using this function directly due to its performance+-- characteristics.+mkQuantityAux :: forall s. KnownNat s => Scientific -> Quantity s+mkQuantityAux x = fromRight err $ mkQuantityLossless (roundScientific nof x)+  where+    -- Get the term-level scaling for the target value:+    nof = fromIntegral $ natVal (Proxy :: Proxy s)++    -- This function should NOT fail in practice ever, but it can fail due to+    -- type signatures by right. We will let it error with a message for+    -- ourselves:+    err = error $ "PROGRAMMING ERROR: Can not construct 'Quantity " <> show nof <> "' with '" <> show x <> "' in a lossy way."+++-- | Rounds a given scientific into a new scientific with given max digits after+-- decimal point.+--+-- This uses half-even rounding method.+--+-- >>> roundScientific 0 0.4+-- 0.0+-- >>> roundScientific 0 0.5+-- 0.0+-- >>> roundScientific 0 0.6+-- 1.0+-- >>> roundScientific 0 1.4+-- 1.0+-- >>> roundScientific 0 1.5+-- 2.0+-- >>> roundScientific 0 1.6+-- 2.0+-- >>> roundScientific 1 0.04+-- 0.0+-- >>> roundScientific 1 0.05+-- 0.0+-- >>> roundScientific 1 0.06+-- 0.1+-- >>> roundScientific 1 0.14+-- 0.1+-- >>> roundScientific 1 0.15+-- 0.2+-- >>> roundScientific 1 0.16+-- 0.2+-- >>> roundScientific 1 3.650+-- 3.6+-- >>> roundScientific 1 3.740+-- 3.7+-- >>> roundScientific 1 3.749+-- 3.7+-- >>> roundScientific 1 3.750+-- 3.8+-- >>> roundScientific 1 3.751+-- 3.8+-- >>> roundScientific 1  3.760+-- 3.8+-- >>> roundScientific 1 (-3.650)+-- -3.6+-- >>> roundScientific 1 (-3.740)+-- -3.7+-- >>> roundScientific 1 (-3.749)+-- -3.7+-- >>> roundScientific 1 (-3.750)+-- -3.8+-- >>> roundScientific 1 (-3.751)+-- -3.8+-- >>> roundScientific 1 (-3.760)+-- -3.8+--+-- TODO: Refactor to improve the performance of this function.+roundScientific :: Int -> Scientific -> Scientific+roundScientific = (read .) . formatScientific Fixed . Just

@@ -1,24 +1,19 @@--- | This module provides template-haskell functions for various 'Haspara.Core.Base'+-- | This module provides template-haskell functions for various "Haspara" -- definitions.----{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}  module Haspara.TH where -import           Control.Monad              (join) import           Data.Function              (fix) import           Data.Scientific            (Scientific) import qualified Data.Text                  as T import           GHC.TypeLits               (KnownNat)-import           Haspara.Currency           (Currency, CurrencyPair, currency, currencyPair)-import           Haspara.Quantity           (Quantity, quantityLossless)+import           Haspara.Currency           (Currency, CurrencyPair(CurrencyPair), mkCurrencyError)+import           Haspara.Quantity           (Quantity, mkQuantityLossless) import qualified Language.Haskell.TH.Syntax as TH   -- | Constructs a 'Quantity' value at compile-time using @-XTemplateHaskell@. ----- >>> :set -XDataKinds -- >>> $$(quantityTH 0.00) :: Quantity 2 -- 0.00 -- >>> $$(quantityTH 0.09) :: Quantity 2@@ -35,7 +30,7 @@     -- 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 = const quantityLossless+    quantityWE = const mkQuantityLossless   -- | Constructs a 'Currency' value at compile-time using @-XTemplateHaskell@.@@ -44,10 +39,10 @@ -- USD -- >>> $$(currencyTH "usd") -- ...--- ...Currency code error! Expecting at least 3 uppercase characters, but received: "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 (fmap TH.TExp . TH.lift) . currency+currencyTH = either (fail . T.unpack) (fmap TH.TExp . TH.lift) . mkCurrencyError   -- | Constructs a 'CurrencyPair' value at compile-time using @-XTemplateHaskell@.@@ -55,32 +50,13 @@ -- >>> $$(currencyPairTH "EUR" "USD") -- EUR/USD -- >>> $$(currencyPairTH "USD" "USD")--- ...--- ...Can not create currency pair from same currencies: USD and USD--- ...+-- USD/USD -- >>> $$(currencyPairTH "USD" "eur") -- ...--- ...Currency code error! Expecting at least 3 uppercase characters, 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 (fmap TH.TExp . TH.lift) .) . mkPair+currencyPairTH = (either (fail . T.unpack) (fmap TH.TExp . TH.lift) .) . mkPair   where-    mkPair :: T.Text -> T.Text -> Either String CurrencyPair-    mkPair x y = join $ currencyPair <$> currency x <*> currency y----- -- | Constructs an 'FXQuote' value at compile-time using @-XTemplateHaskell@.--- ----- -- >>> :set -XDataKinds--- -- >>> $$(fxquoteTH (read "2021-01-01") "EUR" "USD" 10) :: FXQuote 2--- -- ("EUR/USD","2021-01-01","10.00")--- fxquoteTH :: KnownNat s => Date -> T.Text -> T.Text -> Scientific -> TH.Q (TH.TExp (FXQuote s))--- fxquoteTH d c1 c2 = fix $ \loop -> fmap TH.TExp . either (fail . show) TH.lift . fxquoteWE (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.---     fxquoteWE :: KnownNat s => TH.Q (TH.TExp (FXQuote s)) -> Scientific -> Either String (FXQuote s)---     fxquoteWE _ v = do---       xc1 <- currency c1---       xc2 <- currency c2---       either (Left . show) Right $ fxquote d xc1 xc2 v+    mkPair :: T.Text -> T.Text -> Either T.Text CurrencyPair+    mkPair x y = CurrencyPair <$> mkCurrencyError x <*> mkCurrencyError y

@@ -1,5 +1,49 @@-import Test.DocTest ( doctest )+import Test.DocTest (doctest)   main :: IO ()-main = doctest ["-XOverloadedStrings", "-XTemplateHaskell", "-isrc", "src"]+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"+  ]