diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,11 +2,36 @@ ## [Unreleased] + +## [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 + + ## [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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 -o CHANGELOG.md + ``` + +1. Commit, tag and push: + + ```sh + git commit -am "chore(release): " + git tag -a -m "Release " + 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 " + git push + ``` ## License diff --git a/haspara.cabal b/haspara.cabal --- a/haspara.cabal +++ b/haspara.cabal @@ -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 diff --git a/src/Haspara.hs b/src/Haspara.hs --- a/src/Haspara.hs +++ b/src/Haspara.hs @@ -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 diff --git a/src/Haspara/Accounting.hs b/src/Haspara/Accounting.hs --- a/src/Haspara/Accounting.hs +++ b/src/Haspara/Accounting.hs @@ -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) diff --git a/src/Haspara/Accounting/Account.hs b/src/Haspara/Accounting/Account.hs --- a/src/Haspara/Accounting/Account.hs +++ b/src/Haspara/Accounting/Account.hs @@ -1,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) diff --git a/src/Haspara/Accounting/AccountKind.hs b/src/Haspara/Accounting/AccountKind.hs deleted file mode 100644 --- a/src/Haspara/Accounting/AccountKind.hs +++ /dev/null @@ -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" diff --git a/src/Haspara/Accounting/Entry.hs b/src/Haspara/Accounting/Entry.hs deleted file mode 100644 --- a/src/Haspara/Accounting/Entry.hs +++ /dev/null @@ -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 diff --git a/src/Haspara/Accounting/Event.hs b/src/Haspara/Accounting/Event.hs --- a/src/Haspara/Accounting/Event.hs +++ b/src/Haspara/Accounting/Event.hs @@ -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) diff --git a/src/Haspara/Accounting/Ledger.hs b/src/Haspara/Accounting/Ledger.hs --- a/src/Haspara/Accounting/Ledger.hs +++ b/src/Haspara/Accounting/Ledger.hs @@ -1,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 diff --git a/src/Haspara/Accounting/Posting.hs b/src/Haspara/Accounting/Posting.hs deleted file mode 100644 --- a/src/Haspara/Accounting/Posting.hs +++ /dev/null @@ -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 diff --git a/src/Haspara/Accounting/Types.hs b/src/Haspara/Accounting/Types.hs deleted file mode 100644 --- a/src/Haspara/Accounting/Types.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Haspara.Accounting.Types where - -import Haspara.Quantity (Quantity) -import Refined (NonNegative, Refined) - - -type UnsignedQuantity s = Refined NonNegative (Quantity s) diff --git a/src/Haspara/Currency.hs b/src/Haspara/Currency.hs --- a/src/Haspara/Currency.hs +++ b/src/Haspara/Currency.hs @@ -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 - -- ¤cy - -- - -- ** Data Definition - -- ¤cyDataDefinition - -- - Currency - , currencyCode - -- - -- ** Constructors - -- ¤cyConstructors - -- - , currency - , currencyFail - -- - -- * Currency Pair - -- ¤cyPair - -- - -- ** Data Definition - -- ¤cyPairDataDefinition - -- - , CurrencyPair - , toTuple - , baseCurrency - , quoteCurrency - -- - -- ** Constructors - -- ¤cyPairConstructors - -- - , 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 diff --git a/src/Haspara/Date.hs b/src/Haspara/Date.hs deleted file mode 100644 --- a/src/Haspara/Date.hs +++ /dev/null @@ -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 - ) diff --git a/src/Haspara/FXQuote.hs b/src/Haspara/FXQuote.hs deleted file mode 100644 --- a/src/Haspara/FXQuote.hs +++ /dev/null @@ -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) diff --git a/src/Haspara/FxQuote.hs b/src/Haspara/FxQuote.hs new file mode 100644 --- /dev/null +++ b/src/Haspara/FxQuote.hs @@ -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 diff --git a/src/Haspara/Id.hs b/src/Haspara/Id.hs deleted file mode 100644 --- a/src/Haspara/Id.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Haspara.Id - ( Id(..) - , IdLookup - ) where - -import Haspara.Internal.Id (Id(..), IdLookup) diff --git a/src/Haspara/Internal/Aeson.hs b/src/Haspara/Internal/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Haspara/Internal/Aeson.hs @@ -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 diff --git a/src/Haspara/Internal/Currency.hs b/src/Haspara/Internal/Currency.hs deleted file mode 100644 --- a/src/Haspara/Internal/Currency.hs +++ /dev/null @@ -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 diff --git a/src/Haspara/Internal/Date.hs b/src/Haspara/Internal/Date.hs deleted file mode 100644 --- a/src/Haspara/Internal/Date.hs +++ /dev/null @@ -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) diff --git a/src/Haspara/Internal/FXQuote.hs b/src/Haspara/Internal/FXQuote.hs deleted file mode 100644 --- a/src/Haspara/Internal/FXQuote.hs +++ /dev/null @@ -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 diff --git a/src/Haspara/Internal/FXQuoteDatabase.hs b/src/Haspara/Internal/FXQuoteDatabase.hs deleted file mode 100644 --- a/src/Haspara/Internal/FXQuoteDatabase.hs +++ /dev/null @@ -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 diff --git a/src/Haspara/Internal/Id.hs b/src/Haspara/Internal/Id.hs deleted file mode 100644 --- a/src/Haspara/Internal/Id.hs +++ /dev/null @@ -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 diff --git a/src/Haspara/Internal/Money.hs b/src/Haspara/Internal/Money.hs deleted file mode 100644 --- a/src/Haspara/Internal/Money.hs +++ /dev/null @@ -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) diff --git a/src/Haspara/Internal/Quantity.hs b/src/Haspara/Internal/Quantity.hs deleted file mode 100644 --- a/src/Haspara/Internal/Quantity.hs +++ /dev/null @@ -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 diff --git a/src/Haspara/Monetary.hs b/src/Haspara/Monetary.hs new file mode 100644 --- /dev/null +++ b/src/Haspara/Monetary.hs @@ -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 (Money ) === convertM (Money ) + -- @ + 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 diff --git a/src/Haspara/Money.hs b/src/Haspara/Money.hs deleted file mode 100644 --- a/src/Haspara/Money.hs +++ /dev/null @@ -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 - ) diff --git a/src/Haspara/Quantity.hs b/src/Haspara/Quantity.hs --- a/src/Haspara/Quantity.hs +++ b/src/Haspara/Quantity.hs @@ -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 diff --git a/src/Haspara/TH.hs b/src/Haspara/TH.hs --- a/src/Haspara/TH.hs +++ b/src/Haspara/TH.hs @@ -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 diff --git a/test/doctest.hs b/test/doctest.hs --- a/test/doctest.hs +++ b/test/doctest.hs @@ -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" + ]