diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,25 @@ + +## [Unreleased] + + + +## 0.0.0.0 - 2022-03-01 +### Chore +- integrate git-chglog +- init repository +- warn about unused packages during build +- add synopsis and category to package info +- update copyright notice +- init codebase +- **deps:** upgrade to lts-18.17 +- **docs:** update README + +### Feat +- add Aeson instances to Money data type + +### Pull Requests +- Merge pull request [#2](https://github.com/telostat/haspara/issues/2) from telostat/release-chores +- Merge pull request [#1](https://github.com/telostat/haspara/issues/1) from telostat/init + + +[Unreleased]: https://github.com/telostat/haspara/compare/0.0.0.0...HEAD diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +MIT License + +Copyright (c) 2021-2022 Telostat Pte Ltd + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE +LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION +WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,20 @@ +# haspara + +[![Hackage version](https://img.shields.io/hackage/v/haspara.svg?label=Hackage)](https://hackage.haskell.org/package/haspara) +![GitHub release (latest by date)](https://img.shields.io/github/v/release/telostat/haspara) +![GitHub contributors](https://img.shields.io/github/contributors/telostat/haspara) +![GitHub](https://img.shields.io/github/license/telostat/haspara) + +> **Note:** This software is under development and of prototype quality at the +> moment. Expect significant breaking changes without notification until we +> 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. + +## License + +Copyright Telostat Pte Ltd (c) 2021-2022. + +This work is licensed under MIT license. See [LICENSE](./LICENSE). diff --git a/haspara.cabal b/haspara.cabal new file mode 100644 --- /dev/null +++ b/haspara.cabal @@ -0,0 +1,85 @@ +cabal-version: 1.12 +name: haspara +version: 0.0.0.0 +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. + +description: + Please see the README on GitHub at + +category: Finance +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/telostat/haspara + +library + exposed-modules: + Haspara + 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.Quantity + Haspara.TH + + hs-source-dirs: src + other-modules: Paths_haspara + default-language: Haskell2010 + default-extensions: OverloadedStrings + ghc-options: -Wall -Wunused-packages + build-depends: + aeson >=1.5.6.0 && <1.6, + base >=4.11 && <5, + hashable >=1.3.0.0 && <1.4, + megaparsec >=9.0.1 && <9.1, + mtl >=2.2.2 && <2.3, + refined >=0.6.2 && <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, + unordered-containers >=0.2.15.0 && <0.3 + +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, + doctest ==0.17.*, + hashable >=1.3.0.0 && <1.4, + haspara -any, + megaparsec >=9.0.1 && <9.1, + mtl >=2.2.2 && <2.3, + refined >=0.6.2 && <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, + unordered-containers >=0.2.15.0 && <0.3 diff --git a/src/Haspara.hs b/src/Haspara.hs new file mode 100644 --- /dev/null +++ b/src/Haspara.hs @@ -0,0 +1,15 @@ +module Haspara + ( module Haspara.Currency + , module Haspara.Date + , module Haspara.FXQuote + , module Haspara.Id + , module Haspara.Money + , module Haspara.Quantity + ) where + +import Haspara.Currency +import Haspara.Date +import Haspara.FXQuote +import Haspara.Id +import Haspara.Money +import Haspara.Quantity diff --git a/src/Haspara/Currency.hs b/src/Haspara/Currency.hs new file mode 100644 --- /dev/null +++ b/src/Haspara/Currency.hs @@ -0,0 +1,48 @@ +-- | This module provides base data definitions and functions for 'Haspara' +-- library. +-- +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 + +import Haspara.Internal.Currency + ( Currency(currencyCode) + , CurrencyPair + , baseCurrency + , currency + , currencyFail + , currencyPair + , currencyPairFail + , quoteCurrency + , toTuple + ) diff --git a/src/Haspara/Date.hs b/src/Haspara/Date.hs new file mode 100644 --- /dev/null +++ b/src/Haspara/Date.hs @@ -0,0 +1,55 @@ +-- | 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 new file mode 100644 --- /dev/null +++ b/src/Haspara/FXQuote.hs @@ -0,0 +1,32 @@ +-- | 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/Id.hs b/src/Haspara/Id.hs new file mode 100644 --- /dev/null +++ b/src/Haspara/Id.hs @@ -0,0 +1,6 @@ +module Haspara.Id + ( Id(..) + , IdLookup + ) where + +import Haspara.Internal.Id (Id(..), IdLookup) diff --git a/src/Haspara/Internal/Currency.hs b/src/Haspara/Internal/Currency.hs new file mode 100644 --- /dev/null +++ b/src/Haspara/Internal/Currency.hs @@ -0,0 +1,158 @@ +-- | 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 new file mode 100644 --- /dev/null +++ b/src/Haspara/Internal/Date.hs @@ -0,0 +1,195 @@ +-- | 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 new file mode 100644 --- /dev/null +++ b/src/Haspara/Internal/FXQuote.hs @@ -0,0 +1,121 @@ +-- | 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 new file mode 100644 --- /dev/null +++ b/src/Haspara/Internal/FXQuoteDatabase.hs @@ -0,0 +1,35 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Haspara/Internal/Id.hs @@ -0,0 +1,67 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Haspara/Internal/Money.hs @@ -0,0 +1,116 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Haspara/Internal/Quantity.hs @@ -0,0 +1,365 @@ +{-# 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/Money.hs b/src/Haspara/Money.hs new file mode 100644 --- /dev/null +++ b/src/Haspara/Money.hs @@ -0,0 +1,38 @@ +-- | 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 new file mode 100644 --- /dev/null +++ b/src/Haspara/Quantity.hs @@ -0,0 +1,25 @@ +-- | This module provides definitions and functions to encode and work on +-- quantities with fixed decimal points. +-- +module Haspara.Quantity + ( -- * Data Definition + -- &dataDefinition + -- + Quantity + , unQuantity + -- + -- ** Constructors + -- &constructors + -- + , quantity + , quantityLossless + -- + -- ** Operations + -- &operations + -- + , roundQuantity + , times + , timesLossless + ) where + +import Haspara.Internal.Quantity (Quantity(unQuantity), quantity, quantityLossless, roundQuantity, times, timesLossless) diff --git a/src/Haspara/TH.hs b/src/Haspara/TH.hs new file mode 100644 --- /dev/null +++ b/src/Haspara/TH.hs @@ -0,0 +1,86 @@ +-- | This module provides template-haskell functions for various 'Haspara.Core.Base' +-- 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 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 +-- 0.09 +-- >>> $$(quantityTH 0.009) :: Quantity 2 +-- ... +-- ..."Underflow while trying to create quantity: 9.0e-3" +-- ... +-- >>> $$(quantityTH 0.009) :: Quantity 3 +-- 0.009 +quantityTH :: KnownNat s => Scientific -> TH.Q (TH.TExp (Quantity s)) +quantityTH = fix $ \loop -> fmap TH.TExp . either (fail . show) TH.lift . quantityWE (loop undefined) + where + -- This provides a work-around for the type-inference due the `s` type parameter. + -- Trick is borrowed from the Haskell `refined` library. + quantityWE :: KnownNat s => TH.Q (TH.TExp (Quantity s)) -> Scientific -> Either String (Quantity s) + quantityWE = const quantityLossless + + +-- | Constructs a 'Currency' value at compile-time using @-XTemplateHaskell@. +-- +-- >>> $$(currencyTH "USD") +-- USD +-- >>> $$(currencyTH "usd") +-- ... +-- ...Currency code error! Expecting at least 3 uppercase characters, but received: "usd" +-- ... +currencyTH :: T.Text -> TH.Q (TH.TExp Currency) +currencyTH = either fail (fmap TH.TExp . TH.lift) . currency + + +-- | Constructs a 'CurrencyPair' value at compile-time using @-XTemplateHaskell@. +-- +-- >>> $$(currencyPairTH "EUR" "USD") +-- EUR/USD +-- >>> $$(currencyPairTH "USD" "USD") +-- ... +-- ...Can not create currency pair from same currencies: USD and USD +-- ... +-- >>> $$(currencyPairTH "USD" "eur") +-- ... +-- ...Currency code error! Expecting at least 3 uppercase characters, but received: "eur" +-- ... +currencyPairTH :: T.Text -> T.Text -> TH.Q (TH.TExp CurrencyPair) +currencyPairTH = (either fail (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 diff --git a/test/doctest.hs b/test/doctest.hs new file mode 100644 --- /dev/null +++ b/test/doctest.hs @@ -0,0 +1,5 @@ +import Test.DocTest ( doctest ) + + +main :: IO () +main = doctest ["-XOverloadedStrings", "-XTemplateHaskell", "-isrc", "src"]