diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,22 @@ ## [Unreleased] + +## [0.0.0.3] - 2022-06-17 +### Chore +- drop deriving-aeson dependency +- adopt Stack lts-19.11 (and GHC902), add Nix Shell +- bump development version to 0.0.0.3 +- **build:** specify dependency version ranges + +### Refactor +- revisit Haspara.FxQuote module, add new definitions + +### Pull Requests +- Merge pull request [#6](https://github.com/telostat/haspara/issues/6) from telostat/chores-fixes-improvements +- Merge pull request [#7](https://github.com/telostat/haspara/issues/7) from telostat/vst/ghc902 + + ## [0.0.0.2] - 2022-03-03 ### Chore @@ -10,6 +26,7 @@ - **dev:** add HLint configuration - **dev:** produce .hie files during compilation - **docs:** update README.md, fix haddock warnings +- **release:** 0.0.0.2 ### Refactor - revisit Haspara.Accounting module and its submodules @@ -62,6 +79,7 @@ - Merge pull request [#1](https://github.com/telostat/haspara/issues/1) from telostat/init -[Unreleased]: https://github.com/telostat/haspara/compare/0.0.0.2...HEAD +[Unreleased]: https://github.com/telostat/haspara/compare/0.0.0.3...HEAD +[0.0.0.3]: https://github.com/telostat/haspara/compare/0.0.0.2...0.0.0.3 [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 @@ -92,13 +92,13 @@ 1. Release to Hackage as a candidate first and check the result: ```sh - stack upload --pvp-bounds both --candidate . + stack upload --candidate . ``` 1. If the candidate package release works fine, release to Hackage: ```sh - stack upload --pvp-bounds both . + stack upload . ``` 1. Checkout to `develop` and rebase onto `main`: diff --git a/haspara.cabal b/haspara.cabal --- a/haspara.cabal +++ b/haspara.cabal @@ -1,97 +1,124 @@ -cabal-version: 1.12 -name: haspara -version: 0.0.0.2 -license: MIT -license-file: LICENSE -copyright: Copyright (c) 2021-2022 Telostat Pte Ltd -maintainer: vst@vsthost.com -author: Vehbi Sinan Tunalioglu -homepage: https://github.com/telostat/haspara#readme -bug-reports: https://github.com/telostat/haspara/issues -synopsis: - A library providing definitions to work with monetary values. +cabal-version: 1.12 -description: - Please see the README on GitHub at +-- This file has been generated from package.yaml by hpack version 0.34.7. +-- +-- see: https://github.com/sol/hpack -category: Finance -build-type: Simple +name: haspara +version: 0.0.0.3 +synopsis: A library providing definitions to work with monetary values. +description: Please see the README on GitHub at +category: Finance +homepage: https://github.com/telostat/haspara#readme +bug-reports: https://github.com/telostat/haspara/issues +author: Vehbi Sinan Tunalioglu +maintainer: vst@vsthost.com +copyright: Copyright (c) 2021-2022 Telostat Pte Ltd +license: MIT +license-file: LICENSE +build-type: Simple extra-source-files: README.md CHANGELOG.md source-repository head - type: git - location: https://github.com/telostat/haspara + type: git + location: https://github.com/telostat/haspara library - exposed-modules: - Haspara - Haspara.Accounting - Haspara.Accounting.Account - Haspara.Accounting.Event - Haspara.Accounting.Ledger - Haspara.Currency - Haspara.FxQuote - Haspara.Internal.Aeson - Haspara.Monetary - Haspara.Quantity - Haspara.TH - - hs-source-dirs: src - other-modules: Paths_haspara - default-language: Haskell2010 - 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, - refined >=0.6.3 && <0.7, - safe-decimal >=0.2.1.0 && <0.3, - scientific >=0.3.7.0 && <0.4, - template-haskell >=2.16.0.0 && <2.17, - text >=1.2.4.1 && <1.3, - time >=1.9.3 && <1.10 + exposed-modules: + Haspara + Haspara.Accounting + Haspara.Accounting.Account + Haspara.Accounting.Event + Haspara.Accounting.Ledger + Haspara.Currency + Haspara.FxQuote + Haspara.Internal.Aeson + Haspara.Monetary + Haspara.Quantity + Haspara.TH + other-modules: + Paths_haspara + hs-source-dirs: + src + default-extensions: + BangPatterns + BinaryLiterals + ConstrainedClassMethods + ConstraintKinds + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + EmptyCase + EmptyDataDeriving + ExistentialQuantification + ExplicitForAll + FlexibleContexts + FlexibleInstances + GADTSyntax + GeneralisedNewtypeDeriving + HexFloatLiterals + ImportQualifiedPost + InstanceSigs + KindSignatures + MultiParamTypeClasses + NamedFieldPuns + NamedWildCards + NumericUnderscores + PolyKinds + PostfixOperators + RankNTypes + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + TupleSections + TypeApplications + TypeOperators + TypeSynonymInstances + OverloadedStrings + ghc-options: -Wall -Wunused-packages + build-depends: + aeson >=1.5.6.0 && <2.1 + , base >=4.11 && <5 + , containers >=0.6.4.1 && <0.7 + , exceptions >=0.10.4 && <0.11 + , hashable >=1.3.0.0 && <1.4 + , megaparsec >=9.0.1 && <9.3 + , mtl >=2.2.2 && <2.3 + , refined >=0.6.3 && <0.7 + , safe-decimal >=0.2.1.0 && <0.3 + , scientific >=0.3.7.0 && <0.4 + , template-haskell >=2.16.0.0 && <2.18 + , text >=1.2.4.1 && <1.3 + , time >=1.9.3 && <1.10 + default-language: Haskell2010 test-suite haspara-doctest - type: exitcode-stdio-1.0 - main-is: doctest.hs - hs-source-dirs: test - other-modules: Paths_haspara - default-language: Haskell2010 - ghc-options: -threaded - 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, - mtl >=2.2.2 && <2.3, - refined >=0.6.3 && <0.7, - safe-decimal >=0.2.1.0 && <0.3, - scientific >=0.3.7.0 && <0.4, - template-haskell >=2.16.0.0 && <2.17, - text >=1.2.4.1 && <1.3, - time >=1.9.3 && <1.10 + type: exitcode-stdio-1.0 + main-is: doctest.hs + other-modules: + Paths_haspara + hs-source-dirs: + test + ghc-options: -threaded + build-depends: + aeson >=1.5.6.0 && <2.1 + , base >=4.11 && <5 + , containers >=0.6.4.1 && <0.7 + , doctest + , exceptions >=0.10.4 && <0.11 + , hashable >=1.3.0.0 && <1.4 + , haspara + , megaparsec >=9.0.1 && <9.3 + , mtl >=2.2.2 && <2.3 + , refined >=0.6.3 && <0.7 + , safe-decimal >=0.2.1.0 && <0.3 + , scientific >=0.3.7.0 && <0.4 + , template-haskell >=2.16.0.0 && <2.18 + , text >=1.2.4.1 && <1.3 + , time >=1.9.3 && <1.10 + default-language: Haskell2010 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 @@ -6,11 +6,11 @@ module Haspara.Accounting.Account where +import qualified Data.Aeson as Aeson 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) +import GHC.Generics (Generic) +import Haspara.Internal.Aeson (aesonOptionsForSingleTag, commonAesonOptions) -- * Account Kind @@ -57,13 +57,20 @@ | 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 + deriving (Enum, Eq, Generic, Ord, Show) instance Hashable AccountKind +instance Aeson.FromJSON AccountKind where + parseJSON = Aeson.genericParseJSON $ aesonOptionsForSingleTag "AccountKind" + + +instance Aeson.ToJSON AccountKind where + toJSON = Aeson.genericToJSON $ aesonOptionsForSingleTag "AccountKind" + + -- | Provides textual representation of a given 'AccountKind'. -- -- >>> accountKindText AccountKindAsset @@ -106,8 +113,15 @@ { accountKind :: !AccountKind , accountObject :: !o } - deriving (Eq, DAS.Generic, Ord, Show) - deriving (DAS.FromJSON, DAS.ToJSON) via DAS.PrefixedSnake "account" (Account o) + deriving (Eq, Generic, Ord, Show) instance Hashable o => Hashable (Account o) + + +instance Aeson.FromJSON o => Aeson.FromJSON (Account o) where + parseJSON = Aeson.genericParseJSON $ commonAesonOptions "account" + + +instance Aeson.ToJSON o => Aeson.ToJSON (Account o) where + toJSON = Aeson.genericToJSON $ commonAesonOptions "account" 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 @@ -11,11 +11,11 @@ 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.Generics (Generic) import GHC.TypeLits (KnownNat, Nat) import Haspara.Accounting.Account (Account(accountKind), AccountKind(..)) import Haspara.Accounting.Event (Event(..), eventObject) +import Haspara.Internal.Aeson (commonAesonOptions) import Haspara.Quantity (Quantity, UnsignedQuantity) import Refined (unrefine) @@ -26,19 +26,34 @@ , 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 (Eq, Generic, Ord, Show) +instance (Aeson.FromJSON a, Aeson.FromJSON o, KnownNat s) => Aeson.FromJSON (Ledger a o s) where + parseJSON = Aeson.genericParseJSON $ commonAesonOptions "ledger" + + +instance (Aeson.ToJSON a, Aeson.ToJSON o, KnownNat s) => Aeson.ToJSON (Ledger a o s) where + toJSON = Aeson.genericToJSON $ commonAesonOptions "ledger" + + -- | Type encoding of a ledger item. data LedgerItem o (s :: Nat) = LedgerItem { ledgerItemEntry :: !(Entry o s) , ledgerItemBalance :: !(Quantity s) - } deriving (Eq, Generic, Ord, Show) - deriving (FromJSON, ToJSON) - via PrefixedSnake "ledgerItem" (LedgerItem o s) + } + deriving (Eq, Generic, Ord, Show) +instance (Aeson.FromJSON o, KnownNat s) => Aeson.FromJSON (LedgerItem o s) where + parseJSON = Aeson.genericParseJSON $ commonAesonOptions "ledgerItem" + + +instance (Aeson.ToJSON o, KnownNat s) => Aeson.ToJSON (LedgerItem o s) where + toJSON = Aeson.genericToJSON $ commonAesonOptions "ledgerItem" + + -- | 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 []) @@ -74,8 +89,14 @@ -- 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) + + +instance (Aeson.FromJSON a, Aeson.FromJSON o, KnownNat s) => Aeson.FromJSON (Posting a o s) where + parseJSON = Aeson.genericParseJSON Aeson.defaultOptions + + +instance (Aeson.ToJSON a, Aeson.ToJSON o, KnownNat s) => Aeson.ToJSON (Posting a o s) where + toJSON = Aeson.genericToJSON Aeson.defaultOptions -- | Returns the list of posting event sources. diff --git a/src/Haspara/Currency.hs b/src/Haspara/Currency.hs --- a/src/Haspara/Currency.hs +++ b/src/Haspara/Currency.hs @@ -11,7 +11,8 @@ import Data.String (IsString(..)) import qualified Data.Text as T import Data.Void (Void) -import qualified Deriving.Aeson.Stock as DAS +import GHC.Generics (Generic) +import Haspara.Internal.Aeson (commonAesonOptions) import qualified Language.Haskell.TH.Syntax as TH import qualified Text.Megaparsec as MP @@ -162,8 +163,15 @@ { 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 + deriving (Eq, Generic, Ord, TH.Lift) + + +instance Aeson.FromJSON CurrencyPair where + parseJSON = Aeson.genericParseJSON $ commonAesonOptions "currencyPair" + + +instance Aeson.ToJSON CurrencyPair where + toJSON = Aeson.genericToJSON $ commonAesonOptions "currencyPair" -- | 'Show' instance for 'CurrencyPair'. diff --git a/src/Haspara/FxQuote.hs b/src/Haspara/FxQuote.hs --- a/src/Haspara/FxQuote.hs +++ b/src/Haspara/FxQuote.hs @@ -6,16 +6,19 @@ 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) +import Control.Monad.Except (MonadError(throwError)) +import qualified Data.Aeson as Aeson +import Data.Foldable (foldl') +import qualified Data.Map.Strict as SM +import Data.Scientific (Scientific) +import qualified Data.Text as T +import Data.Time (Day, addDays) +import GHC.Generics (Generic) +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Currency (Currency, CurrencyPair(CurrencyPair)) +import Haspara.Internal.Aeson (commonAesonOptions) +import Haspara.Quantity (Quantity(..), mkQuantity) +import Refined (Positive, Refined, refineError) -- * FX Rate Quotation @@ -29,36 +32,41 @@ -- 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) + deriving (Eq, Generic, Ord, Show) +instance KnownNat s => Aeson.FromJSON (FxQuote s) where + parseJSON = Aeson.genericParseJSON $ commonAesonOptions "fxQuote" + + +instance KnownNat s => Aeson.ToJSON (FxQuote s) where + toJSON = Aeson.genericToJSON $ commonAesonOptions "fxQuote" + + -- | 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 +-- >>> mkFxQuoteError @(Either _) @2 "EUR" "USD" (read "2021-12-31") 1.16 -- Right (MkFxQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16}) --- >>> mkFxQuoteError @(Either _) @2 (read "2021-12-31") "EUR" "USD" (-1.16) +-- >>> mkFxQuoteError @(Either _) @2 "EUR" "USD" (read "2021-12-31") (-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 -- ^ Base currency (from) of the FX quotation. -> Currency -- ^ Quote currency (to) of the FX quotation. + -> Day -- ^ Date of the FX quotation. -> Scientific -- ^ FX quotation rate, expected to be positive. -> m (FxQuote s) -mkFxQuoteError date ccy1 ccy2 rate = +mkFxQuoteError ccy1 ccy2 date 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 @@ -68,43 +76,53 @@ -- -- 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 +-- >>> mkFxQuoteFail @Maybe @2 "EUR" "USD" (read "2021-12-31") 1.16 -- Just (MkFxQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16}) --- >>> mkFxQuoteFail @Maybe @2 (read "2021-12-31") "EUR" "USD" (-1.16) +-- >>> mkFxQuoteFail @Maybe @2 "EUR" "USD" (read "2021-12-31") (-1.16) -- Nothing mkFxQuoteFail :: MonadFail m => KnownNat s - => Day -- ^ Date of the FX quotation. - -> Currency -- ^ Base currency (from) of the FX quotation. + => Currency -- ^ Base currency (from) of the FX quotation. -> Currency -- ^ Quote currency (to) of the FX quotation. + -> Day -- ^ Date of the FX quotation. -> Scientific -- ^ FX quotation rate, expected to be positive. -> m (FxQuote s) -mkFxQuoteFail date ccy1 ccy2 = - either (fail . T.unpack) pure . mkFxQuoteError date ccy1 ccy2 +mkFxQuoteFail ccy1 ccy2 date = + either (fail . T.unpack) pure . mkFxQuoteError ccy1 ccy2 date -- | Unsafe 'FxQuote' constructor that 'error's if it fails. -- --- >>> mkFxQuoteUnsafe @2 (read "2021-12-31") "EUR" "USD" 1.16 +-- >>> mkFxQuoteUnsafe @2 "EUR" "USD" (read "2021-12-31") 1.16 -- MkFxQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16} --- >>> mkFxQuoteUnsafe @2 (read "2021-12-31") "EUR" "USD" (-1.16) +-- >>> mkFxQuoteUnsafe @2 "EUR" "USD" (read "2021-12-31") (-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 -- ^ Base currency (from) of the FX quotation. -> Currency -- ^ Quote currency (to) of the FX quotation. + -> Day -- ^ Date of the FX quotation. -> Scientific -- ^ FX quotation rate, expected to be positive. -> FxQuote s -mkFxQuoteUnsafe date ccy1 ccy2 = - either (error . T.unpack) id . mkFxQuoteError date ccy1 ccy2 +mkFxQuoteUnsafe ccy1 ccy2 date = + either (error . T.unpack) id . mkFxQuoteError ccy1 ccy2 date -- * FX Rate Quotation Database -- $fxRateQuotationDatabase +-- +-- >>> let database = addFxQuotes [mkFxQuoteUnsafe @8 "EUR" "USD" (read "2021-12-31") 1.13, mkFxQuoteUnsafe @8 "EUR" "TRY" (read "2021-12-31") 15.14] emptyFxQuoteDatabase +-- >>> findFxQuote database (CurrencyPair "EUR" "USD") (read "2021-12-31") +-- Just (MkFxQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.13000000}) +-- >>> findFxQuote database (CurrencyPair "EUR" "TRY") (read "2021-12-31") +-- Just (MkFxQuote {fxQuotePair = EUR/TRY, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 15.14000000}) +-- >>> findFxQuote database (CurrencyPair "EUR" "TRY") (read "2021-12-30") +-- Nothing +-- >>> findFxQuote database (CurrencyPair "EUR" "TRY") (read "2022-01-01") +-- Just (MkFxQuote {fxQuotePair = EUR/TRY, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 15.14000000}) -- | Type encoding for a dictionary-based FX rate quotation database for various @@ -119,6 +137,7 @@ , fxQuotePairDatabaseSince :: !Day , fxQuotePairDatabaseUntil :: !Day } + deriving Show -- | Attempts to find and return the FX quotation for a given 'CurrencyPair' as @@ -140,3 +159,73 @@ | otherwise = case SM.lookup date (fxQuotePairDatabaseTable db) of Nothing -> findFxQuoteAux (addDays (-1) date) db Just fx -> Just fx + + +-- | Returns empty FX rate quotation database. +-- +-- >>> emptyFxQuoteDatabase @8 +-- fromList [] +emptyFxQuoteDatabase + :: KnownNat n + => FxQuoteDatabase n +emptyFxQuoteDatabase = SM.empty + + +-- | Adds a list of FX rate quotations to the given database. +-- +-- >>> let database = emptyFxQuoteDatabase @8 +-- >>> addFxQuotes [] database +-- fromList [] +-- >>> addFxQuotes [mkFxQuoteUnsafe @8 "EUR" "USD" (read "2021-01-31") 1.13] database +-- fromList [(EUR/USD,FxQuotePairDatabase {fxQuotePairDatabasePair = EUR/USD, fxQuotePairDatabaseTable = fromList [(2021-01-31,MkFxQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-01-31, fxQuoteRate = Refined 1.13000000})], fxQuotePairDatabaseSince = 2021-01-31, fxQuotePairDatabaseUntil = 2021-01-31})] +-- >>> addFxQuotes [mkFxQuoteUnsafe @8 "EUR" "USD" (read "2021-01-31") 1.13, mkFxQuoteUnsafe @8 "USD" "EUR" (read "2021-01-31") 0.884956] database +-- fromList [(EUR/USD,FxQuotePairDatabase {fxQuotePairDatabasePair = EUR/USD, fxQuotePairDatabaseTable = fromList [(2021-01-31,MkFxQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-01-31, fxQuoteRate = Refined 1.13000000})], fxQuotePairDatabaseSince = 2021-01-31, fxQuotePairDatabaseUntil = 2021-01-31}),(USD/EUR,FxQuotePairDatabase {fxQuotePairDatabasePair = USD/EUR, fxQuotePairDatabaseTable = fromList [(2021-01-31,MkFxQuote {fxQuotePair = USD/EUR, fxQuoteDate = 2021-01-31, fxQuoteRate = Refined 0.88495600})], fxQuotePairDatabaseSince = 2021-01-31, fxQuotePairDatabaseUntil = 2021-01-31})] +addFxQuotes + :: KnownNat n + => [FxQuote n] + -> FxQuoteDatabase n + -> FxQuoteDatabase n +addFxQuotes quotes database = foldl' (flip addFxQuote) database quotes + + +-- | Adds an FX rate quotation to the given database. +addFxQuote + :: KnownNat n + => FxQuote n + -> FxQuoteDatabase n + -> FxQuoteDatabase n +addFxQuote quote@(MkFxQuote pair _ _) database = case SM.lookup pair database of + Nothing -> SM.insert pair (initFxQuotePairDatabase quote) database + Just fpd -> SM.insert pair (updateFxQuotePairDatabase quote fpd) database + + +-- * Internal +-- $internal + + +-- | Initializes FX quote pair database with the given FX quote. +initFxQuotePairDatabase + :: KnownNat n + => FxQuote n + -> FxQuotePairDatabase n +initFxQuotePairDatabase quote@(MkFxQuote pair date _) = + FxQuotePairDatabase + { fxQuotePairDatabasePair = pair + , fxQuotePairDatabaseTable = SM.singleton date quote + , fxQuotePairDatabaseSince = date + , fxQuotePairDatabaseUntil = date + } + + +-- | Updates an existing FX quote pair database with the given FX quote. +updateFxQuotePairDatabase + :: KnownNat n + => FxQuote n + -> FxQuotePairDatabase n + -> FxQuotePairDatabase n +updateFxQuotePairDatabase quote@(MkFxQuote _ date _) before = + before + { fxQuotePairDatabaseTable = SM.insert date quote (fxQuotePairDatabaseTable before) + , fxQuotePairDatabaseSince = min (fxQuotePairDatabaseSince before) date + , fxQuotePairDatabaseUntil = max (fxQuotePairDatabaseUntil before) date + } diff --git a/src/Haspara/Internal/Aeson.hs b/src/Haspara/Internal/Aeson.hs --- a/src/Haspara/Internal/Aeson.hs +++ b/src/Haspara/Internal/Aeson.hs @@ -2,13 +2,29 @@ module Haspara.Internal.Aeson where -import qualified Data.Char as C -import qualified Deriving.Aeson as DA +import qualified Data.Aeson as Aeson +import qualified Data.Char as C +import Data.List (stripPrefix) +import Data.Maybe (fromMaybe) --- | Type definition for string modifiers that uppercase a given symbol. -data UpperCase +-- | Common Aeson encoding/decoding options. +commonAesonOptions :: String -> Aeson.Options +commonAesonOptions prefix = + Aeson.defaultOptions + { Aeson.omitNothingFields = True + , Aeson.fieldLabelModifier = \l -> Aeson.camelTo2 '_' . fromMaybe l $ stripPrefix prefix l + , Aeson.constructorTagModifier = \l -> Aeson.camelTo2 '_' . fromMaybe l $ stripPrefix prefix l + , Aeson.sumEncoding = Aeson.TaggedObject + { Aeson.tagFieldName = "type" + , Aeson.contentsFieldName = "value" + } + } -instance DA.StringModifier UpperCase where - getStringModifier = fmap C.toUpper +-- | Aeson encoding/decoding options for uppercase constructor tag modifiers +aesonOptionsForSingleTag :: String -> Aeson.Options +aesonOptionsForSingleTag prefix = + Aeson.defaultOptions + { Aeson.constructorTagModifier = \l -> fmap C.toUpper . Aeson.camelTo2 '_' . fromMaybe l $ stripPrefix prefix l + } diff --git a/src/Haspara/Monetary.hs b/src/Haspara/Monetary.hs --- a/src/Haspara/Monetary.hs +++ b/src/Haspara/Monetary.hs @@ -6,17 +6,19 @@ 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) +import Control.Exception (Exception) +import Control.Monad (when) +import Control.Monad.Catch (MonadThrow(throwM)) +import qualified Data.Aeson as Aeson +import Data.Time (Day) +import GHC.Generics (Generic) +import GHC.Stack (HasCallStack) +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Currency (Currency, CurrencyPair(..)) +import Haspara.FxQuote (FxQuote(..)) +import Haspara.Internal.Aeson (commonAesonOptions) +import Haspara.Quantity (Quantity, times) +import Refined (unrefine) -- | Type encoding for dated monetary values. @@ -31,8 +33,15 @@ , moneyCurrency :: !Currency , moneyQuantity :: !(Quantity s) } - deriving (Eq, DAS.Generic, Ord, Show) - deriving (DAS.FromJSON, DAS.ToJSON) via DAS.PrefixedSnake "money" (Money s) + deriving (Eq, Generic, Ord, Show) + + +instance KnownNat s => Aeson.FromJSON (Money s) where + parseJSON = Aeson.genericParseJSON $ commonAesonOptions "money" + + +instance KnownNat s => Aeson.ToJSON (Money s) where + toJSON = Aeson.genericToJSON $ commonAesonOptions "money" -- | Type encoding of a monetary context.