packages feed

haspara (empty) → 0.0.0.0

raw patch · 20 files changed

+1519/−0 lines, 20 filesdep +aesondep +basedep +doctest

Dependencies added: aeson, base, doctest, hashable, haspara, megaparsec, mtl, refined, safe-decimal, scientific, template-haskell, text, time, unordered-containers

Files

+ CHANGELOG.md view
@@ -0,0 +1,25 @@+<a name="unreleased"></a>+## [Unreleased]+++<a name="0.0.0.0"></a>+## 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
+ LICENSE view
@@ -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.
+ README.md view
@@ -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).
+ haspara.cabal view
@@ -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 <https://github.com/telostat/haspara#readme>++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
+ src/Haspara.hs view
@@ -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
+ src/Haspara/Currency.hs view
@@ -0,0 +1,48 @@+-- | This module provides base data definitions and functions for 'Haspara'+-- library.+--+module Haspara.Currency+  ( -- * Currency+    -- &currency+    --+    -- ** Data Definition+    -- &currencyDataDefinition+    --+    Currency+  , currencyCode+    --+    -- ** Constructors+    -- &currencyConstructors+    --+  , currency+  , currencyFail+    --+    -- * Currency Pair+    -- &currencyPair+    --+    -- ** Data Definition+    -- &currencyPairDataDefinition+    --+  , CurrencyPair+  , toTuple+  , baseCurrency+  , quoteCurrency+    --+    -- ** Constructors+    -- &currencyPairConstructors+    --+  , currencyPair+  , currencyPairFail+  ) where++import Haspara.Internal.Currency+       ( Currency(currencyCode)+       , CurrencyPair+       , baseCurrency+       , currency+       , currencyFail+       , currencyPair+       , currencyPairFail+       , quoteCurrency+       , toTuple+       )
+ src/Haspara/Date.hs view
@@ -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+       )
+ src/Haspara/FXQuote.hs view
@@ -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)
+ src/Haspara/Id.hs view
@@ -0,0 +1,6 @@+module Haspara.Id+  ( Id(..)+  , IdLookup+  ) where++import Haspara.Internal.Id (Id(..), IdLookup)
+ src/Haspara/Internal/Currency.hs view
@@ -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
+ src/Haspara/Internal/Date.hs view
@@ -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)
+ src/Haspara/Internal/FXQuote.hs view
@@ -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
+ src/Haspara/Internal/FXQuoteDatabase.hs view
@@ -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
+ src/Haspara/Internal/Id.hs view
@@ -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
+ src/Haspara/Internal/Money.hs view
@@ -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)
+ src/Haspara/Internal/Quantity.hs view
@@ -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
+ src/Haspara/Money.hs view
@@ -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+       )
+ src/Haspara/Quantity.hs view
@@ -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)
+ src/Haspara/TH.hs view
@@ -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
+ test/doctest.hs view
@@ -0,0 +1,5 @@+import Test.DocTest ( doctest )+++main :: IO ()+main = doctest ["-XOverloadedStrings", "-XTemplateHaskell", "-isrc", "src"]