From edf932c55981ae523eed75400daaf08a5a4d212c Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Tue, 1 Mar 2022 15:36:36 +0800 Subject: [PATCH 01/14] chore: bump development version to 0.0.0.2 --- haspara.cabal | 2 +- package.yaml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/haspara.cabal b/haspara.cabal index b8ffc51..0b6e6ac 100644 --- a/haspara.cabal +++ b/haspara.cabal @@ -5,7 +5,7 @@ cabal-version: 1.12 -- see: https://github.com/sol/hpack name: haspara -version: 0.0.0.1 +version: 0.0.0.2 synopsis: A library providing definitions to work with monetary values. description: Please see the README on GitHub at category: Finance diff --git a/package.yaml b/package.yaml index d465008..8d233c1 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: haspara -version: 0.0.0.1 +version: 0.0.0.2 github: "telostat/haspara" license: MIT author: "Vehbi Sinan Tunalioglu" From 83e241e3b11cd645da4776781ccdd751736ea921 Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Tue, 1 Mar 2022 21:46:57 +0800 Subject: [PATCH 02/14] refactor: remove Id type and related definitions We are not using Id type in this codebase. Therefore, we are removing it in favour of the Id definition in `zamazingo` library. --- haspara.cabal | 2 -- src/Haspara.hs | 2 -- src/Haspara/Id.hs | 6 ---- src/Haspara/Internal/Id.hs | 67 -------------------------------------- 4 files changed, 77 deletions(-) delete mode 100644 src/Haspara/Id.hs delete mode 100644 src/Haspara/Internal/Id.hs diff --git a/haspara.cabal b/haspara.cabal index 0b6e6ac..cbc8f45 100644 --- a/haspara.cabal +++ b/haspara.cabal @@ -39,12 +39,10 @@ library 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 diff --git a/src/Haspara.hs b/src/Haspara.hs index 73e112b..456db06 100644 --- a/src/Haspara.hs +++ b/src/Haspara.hs @@ -2,7 +2,6 @@ module Haspara ( module Haspara.Currency , module Haspara.Date , module Haspara.FXQuote - , module Haspara.Id , module Haspara.Money , module Haspara.Quantity ) where @@ -10,6 +9,5 @@ module Haspara import Haspara.Currency import Haspara.Date import Haspara.FXQuote -import Haspara.Id import Haspara.Money import Haspara.Quantity diff --git a/src/Haspara/Id.hs b/src/Haspara/Id.hs deleted file mode 100644 index e086159..0000000 --- a/src/Haspara/Id.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Haspara.Id - ( Id(..) - , IdLookup - ) where - -import Haspara.Internal.Id (Id(..), IdLookup) diff --git a/src/Haspara/Internal/Id.hs b/src/Haspara/Internal/Id.hs deleted file mode 100644 index 0834101..0000000 --- a/src/Haspara/Internal/Id.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Haspara.Internal.Id where - -import qualified Data.Aeson as Aeson -import qualified Data.HashMap.Strict as HM -import Data.Hashable (Hashable) - - --- | Type encoding for entity identifiers. --- --- This encoding allows us to provide a phantom type for distinguishing between --- identifiers of varying types and an underlying identifier type. --- --- For example: --- --- >>> data A = A --- >>> data B = B --- >>> data C = C --- >>> type IdA = Id A Int --- >>> type IdB = Id B Int --- >>> type IdC = Id C String --- >>> let idA = Id 1 :: IdA --- >>> let idB = Id 1 :: IdB --- >>> let idC = Id "C1" :: IdC --- >>> idA --- 1 --- >>> idB --- 1 --- >>> idC --- "C1" --- >>> idA == idA --- True --- >>> -- idA == idB -- Compile error as: Couldn't match type ‘B’ with ‘A’ --- --- Hashes, on the otherhand, can be compared: --- --- >>> import Data.Hashable --- >>> hash idA == hash idB --- True -newtype Id a b = Id { unId :: b } - deriving(Eq, Ord, Hashable) - - -instance (Show b) => Show (Id a b) where - show (Id x) = show x - - -instance (Aeson.FromJSON b) => Aeson.FromJSON (Id a b) where - parseJSON = fmap Id . Aeson.parseJSON - - -instance (Aeson.ToJSON b) => Aeson.ToJSON (Id a b) where - toJSON (Id x) = Aeson.toJSON x - - --- | Type encoding for a lookup table from entity 'Id's to corresponding entities. --- --- >>> data A = A Int String deriving Show --- >>> type IdA = Id A Int --- >>> let a1 = A 1 "a1" --- >>> let a2 = A 2 "a2" --- >>> let a3 = A 3 "a3" --- >>> let table = HM.fromList [(Id 1, a1), (Id 2, a2), (Id 3, a3)] :: IdLookup A Int --- >>> HM.lookup (Id 1) table --- Just (A 1 "a1") -type IdLookup a b = HM.HashMap (Id a b) a From cc90e6e5b0c7770a2f9e76668ad6b7e04b27e7a6 Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Tue, 1 Mar 2022 22:52:26 +0800 Subject: [PATCH 03/14] refactor: remove Date type in favour of Day type --- haspara.cabal | 6 +- package.yaml | 2 +- src/Haspara.hs | 2 - src/Haspara/Accounting/Entry.hs | 9 +- src/Haspara/Accounting/Event.hs | 11 +- src/Haspara/Accounting/Posting.hs | 2 +- src/Haspara/Date.hs | 55 ------- src/Haspara/Internal/Date.hs | 195 ------------------------ src/Haspara/Internal/FXQuote.hs | 12 +- src/Haspara/Internal/FXQuoteDatabase.hs | 20 +-- src/Haspara/Internal/Money.hs | 12 +- 11 files changed, 37 insertions(+), 289 deletions(-) delete mode 100644 src/Haspara/Date.hs delete mode 100644 src/Haspara/Internal/Date.hs diff --git a/haspara.cabal b/haspara.cabal index cbc8f45..99885d6 100644 --- a/haspara.cabal +++ b/haspara.cabal @@ -37,10 +37,8 @@ library Haspara.Accounting.Posting Haspara.Accounting.Types Haspara.Currency - Haspara.Date Haspara.FXQuote Haspara.Internal.Currency - Haspara.Internal.Date Haspara.Internal.FXQuote Haspara.Internal.FXQuoteDatabase Haspara.Internal.Money @@ -58,6 +56,7 @@ library build-depends: aeson , base >=4.11 && <5 + , containers , deriving-aeson , hashable , megaparsec @@ -68,7 +67,6 @@ library , template-haskell , text , time - , unordered-containers default-language: Haskell2010 test-suite haspara-doctest @@ -82,6 +80,7 @@ test-suite haspara-doctest build-depends: aeson , base >=4.11 && <5 + , containers , deriving-aeson , doctest , hashable @@ -94,5 +93,4 @@ test-suite haspara-doctest , template-haskell , text , time - , unordered-containers default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 8d233c1..e10da64 100644 --- a/package.yaml +++ b/package.yaml @@ -17,6 +17,7 @@ extra-source-files: dependencies: - base >= 4.11 && < 5 - aeson +- containers - deriving-aeson - hashable - megaparsec @@ -27,7 +28,6 @@ dependencies: - template-haskell - text - time -- unordered-containers library: source-dirs: src diff --git a/src/Haspara.hs b/src/Haspara.hs index 456db06..cc73f18 100644 --- a/src/Haspara.hs +++ b/src/Haspara.hs @@ -1,13 +1,11 @@ module Haspara ( module Haspara.Currency - , module Haspara.Date , module Haspara.FXQuote , module Haspara.Money , module Haspara.Quantity ) where import Haspara.Currency -import Haspara.Date import Haspara.FXQuote import Haspara.Money import Haspara.Quantity diff --git a/src/Haspara/Accounting/Entry.hs b/src/Haspara/Accounting/Entry.hs index 3b51928..ebb6314 100644 --- a/src/Haspara/Accounting/Entry.hs +++ b/src/Haspara/Accounting/Entry.hs @@ -7,6 +7,7 @@ import Data.Aeson ((.:), (.=)) import qualified Data.Aeson as Aeson import qualified Data.Char as C import qualified Data.Text as T +import Data.Time (Day) import GHC.TypeLits (KnownNat, Nat) import qualified Haspara as H import Haspara.Accounting.AccountKind (AccountKind(..)) @@ -25,14 +26,14 @@ import Refined (unrefine) -- >>> let entry = EntryDebit date oid qty -- >>> let json = Aeson.encode entry -- >>> json --- "{\"qty\":42.0,\"obj\":1,\"date\":\"2021-01-01\",\"type\":\"DEBIT\"}" +-- "{\"qty\":42.0,\"type\":\"DEBIT\",\"obj\":1,\"date\":\"2021-01-01\"}" -- >>> Aeson.decode json :: Maybe (Entry Int 2) -- Just (EntryDebit 2021-01-01 1 (Refined 42.00)) -- >>> Aeson.decode json == Just entry -- True data Entry o (s :: Nat) = - EntryDebit H.Date o (UnsignedQuantity s) - | EntryCredit H.Date o (UnsignedQuantity s) + EntryDebit Day o (UnsignedQuantity s) + | EntryCredit Day o (UnsignedQuantity s) deriving (Eq, Ord, Show) @@ -55,7 +56,7 @@ instance (Aeson.ToJSON o, KnownNat s) => Aeson.ToJSON (Entry o s) where EntryCredit d o q -> Aeson.object ["type" .= ("CREDIT" :: T.Text), "date" .= d, "obj" .= o, "qty" .= q] -entryDate :: KnownNat s => Entry o s -> H.Date +entryDate :: KnownNat s => Entry o s -> Day entryDate (EntryDebit d _ _) = d entryDate (EntryCredit d _ _) = d diff --git a/src/Haspara/Accounting/Event.hs b/src/Haspara/Accounting/Event.hs index 61a29f1..e88cdbb 100644 --- a/src/Haspara/Accounting/Event.hs +++ b/src/Haspara/Accounting/Event.hs @@ -9,6 +9,7 @@ import Data.Aeson ((.:), (.=)) import qualified Data.Aeson as Aeson import qualified Data.Char as C import qualified Data.Text as T +import Data.Time (Day) import GHC.TypeLits (KnownNat, Nat) import qualified Haspara as H import Haspara.Accounting.Types (UnsignedQuantity) @@ -25,14 +26,14 @@ import Refined (refine) -- >>> let event = EventDecrement date oid qty -- >>> let json = Aeson.encode event -- >>> json --- "{\"qty\":42.0,\"obj\":1,\"date\":\"2021-01-01\",\"type\":\"DECREMENT\"}" +-- "{\"qty\":42.0,\"type\":\"DECREMENT\",\"obj\":1,\"date\":\"2021-01-01\"}" -- >>> Aeson.decode json :: Maybe (Event Int 2) -- Just (EventDecrement 2021-01-01 1 (Refined 42.00)) -- >>> Aeson.decode json == Just event -- True data Event o (s :: Nat) = - EventDecrement H.Date o (UnsignedQuantity s) - | EventIncrement H.Date o (UnsignedQuantity s) + EventDecrement Day o (UnsignedQuantity s) + | EventIncrement Day o (UnsignedQuantity s) deriving (Eq, Ord, Show) @@ -55,7 +56,7 @@ instance (Aeson.ToJSON o, KnownNat s) => Aeson.ToJSON (Event o s) where EventIncrement d o q -> Aeson.object ["type" .= ("INCREMENT" :: T.Text), "date" .= d, "obj" .= o, "qty" .= q] -eventDate :: (KnownNat s) => Event o s -> H.Date +eventDate :: (KnownNat s) => Event o s -> Day eventDate (EventDecrement d _ _) = d eventDate (EventIncrement d _ _) = d @@ -70,7 +71,7 @@ negateEvent (EventDecrement d o x) = EventIncrement d o x negateEvent (EventIncrement d o x) = EventDecrement d o x -mkEvent :: (MonadError String m, KnownNat s) => H.Date -> o -> H.Quantity s -> m (Event o s) +mkEvent :: (MonadError String m, KnownNat s) => Day -> o -> H.Quantity s -> m (Event o s) mkEvent d o x | x < 0 = either (throwError . show) pure $ EventDecrement d o <$> refine (abs x) | otherwise = either (throwError . show) pure $ EventIncrement d o <$> refine (abs x) diff --git a/src/Haspara/Accounting/Posting.hs b/src/Haspara/Accounting/Posting.hs index 4368dd8..513da44 100644 --- a/src/Haspara/Accounting/Posting.hs +++ b/src/Haspara/Accounting/Posting.hs @@ -30,7 +30,7 @@ import Haspara.Accounting.Event (Event, eventObject) -- >>> let posting = Posting . NE.fromList $ [(event, account)] -- >>> let json = Aeson.encode posting -- >>> json --- "[[{\"qty\":42.0,\"obj\":1,\"date\":\"2021-01-01\",\"type\":\"DECREMENT\"},{\"kind\":\"ASSET\",\"object\":[\"Cash\",1]}]]" +-- "[[{\"qty\":42.0,\"type\":\"DECREMENT\",\"obj\":1,\"date\":\"2021-01-01\"},{\"kind\":\"ASSET\",\"object\":[\"Cash\",1]}]]" -- >>> Aeson.decode json :: Maybe (Posting (String, Int) Int 2) -- Just (Posting ((EventDecrement 2021-01-01 1 (Refined 42.00),Account {accountKind = AccountKindAsset, accountObject = ("Cash",1)}) :| [])) -- >>> Aeson.decode json == Just posting diff --git a/src/Haspara/Date.hs b/src/Haspara/Date.hs deleted file mode 100644 index 3cf071b..0000000 --- a/src/Haspara/Date.hs +++ /dev/null @@ -1,55 +0,0 @@ --- | This module provides definitions and functions to encode and work on date --- values. --- -module Haspara.Date - ( -- * Date - -- &date - -- - -- ** Definition - -- &definition - -- - Date - -- - -- - -- ** Constructors - -- &constructors - -- - , fromDay - , fromYMD - , fromString - , fromFormattedString - , fromText - , fromFormattedText - -- - -- ** Conversions - -- &conversions - -- - , toDay - , toYMD - , toString - , toFormattedString - , toText - , toFormattedText - -- - -- ** Operations - -- &operations - -- - , addDays - ) where - -import Haspara.Internal.Date - ( Date - , addDays - , fromDay - , fromFormattedString - , fromFormattedText - , fromString - , fromText - , fromYMD - , toDay - , toFormattedString - , toFormattedText - , toString - , toText - , toYMD - ) diff --git a/src/Haspara/Internal/Date.hs b/src/Haspara/Internal/Date.hs deleted file mode 100644 index 794eb0d..0000000 --- a/src/Haspara/Internal/Date.hs +++ /dev/null @@ -1,195 +0,0 @@ --- | This module provides data definitions and functions for date values. --- -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Haspara.Internal.Date where - -import qualified Data.Aeson as Aeson -import Data.Bifunctor (first) -import Data.Hashable (Hashable(..)) -import qualified Data.Text as T -import qualified Data.Time as DT - - --- * Data Definition --- &dataDefinition - - --- | Type encoding for date values. --- --- This is a convenience wrapper around 'Day' type. It helps us to avoid --- defining orphan instances. -newtype Date = MkDate DT.Day deriving (Eq, Enum, Ord) - - --- | 'Hashable' instance for 'Date'. -instance Hashable Date where - hashWithSalt salt (MkDate (DT.ModifiedJulianDay i)) = hashWithSalt salt i - - --- | 'Read' instance for 'Date'. --- --- >>> read "2021-01-01" :: Date --- 2021-01-01 --- >>> read "Just 2021-01-01" :: Maybe Date --- Just 2021-01-01 -instance Read Date where - readsPrec _ = readParen False $ fmap (first MkDate) <$> DT.readSTime True DT.defaultTimeLocale "%Y-%m-%d" - - --- | 'Show' instance for 'Date'. --- --- >>> fromYMD 2020 12 31 --- 2020-12-31 -instance Show Date where - show = toString - - --- | 'Aeson.FromJSON' instance for 'Date'. --- --- >>> Aeson.decode "\"2020-12-31\"" :: Maybe Date --- Just 2020-12-31 -instance Aeson.FromJSON Date where - parseJSON = Aeson.withText "Date" fromText - - --- | 'Aeson.ToJSON' instance for 'Date'. --- --- >>> Aeson.encode (MkDate (read "2021-01-01")) --- "\"2021-01-01\"" -instance Aeson.ToJSON Date where - toJSON = Aeson.String . T.pack . show - - --- * Constructors --- &constructors - - --- | Builds a 'Date' from a given 'Day'. --- --- >>> fromDay (read "2021-01-01") --- 2021-01-01 -fromDay :: DT.Day -> Date -fromDay = MkDate - - --- | Builds a 'Date' from a given year, month and day as in Gregorian calendar. --- --- >>> fromYMD 2021 1 1 --- 2021-01-01 -fromYMD :: Integer -> Int -> Int -> Date -fromYMD y m d = fromDay (DT.fromGregorian y m d) - - --- | Attempts to parse and return 'Date' from a given 'String' with ISO format. --- --- >>> fromString "2021-01-01" :: Maybe Date --- Just 2021-01-01 --- >>> fromString "20210101" :: Maybe Date --- Nothing -fromString :: MonadFail m => String -> m Date -fromString = fromFormattedString "%Y-%m-%d" - - --- | Attempts to parse and return 'Date' from a given 'String' with given date format. --- --- >>> fromFormattedString "%Y-%m-%d" "2021-01-01" :: Maybe Date --- Just 2021-01-01 --- >>> fromFormattedString "%Y%m%d" "20210101" :: Maybe Date --- Just 2021-01-01 --- >>> fromFormattedString "%Y%m%d" "202101" :: Maybe Date --- Nothing -fromFormattedString :: MonadFail m => String -> String -> m Date -fromFormattedString fmt = fmap fromDay . DT.parseTimeM False DT.defaultTimeLocale fmt - - --- | Attempts to parse and return 'Date' from a given 'T.Text' with ISO format. --- --- >>> fromText "2021-01-01" :: Maybe Date --- Just 2021-01-01 --- >>> fromText "20210101" :: Maybe Date --- Nothing -fromText :: MonadFail m => T.Text -> m Date -fromText = fromString . T.unpack - - --- | Attempts to parse and return 'Date' from a given 'T.Text' with ISO format. --- --- >>> fromFormattedText "%Y-%m-%d" "2021-01-01" :: Maybe Date --- Just 2021-01-01 --- >>> fromFormattedText "%Y%m%d" "20210101" :: Maybe Date --- Just 2021-01-01 --- >>> fromFormattedText "%Y%m%d" "202101" :: Maybe Date --- Nothing -fromFormattedText :: MonadFail m => String -> T.Text -> m Date -fromFormattedText fmt = fromFormattedString fmt . T.unpack - - --- * Conversions --- &conversions - - --- | Converts 'Date' value to a 'DT.Day' value. --- --- >>> toDay (read "2021-01-01") --- 2021-01-01 -toDay :: Date -> DT.Day -toDay (MkDate d) = d - - --- | Converts 'Date' value to a 3-tuple of year, month and day. --- --- >>> toYMD (read "2020-12-31") --- (2020,12,31) -toYMD :: Date -> (Integer, Int, Int) -toYMD = DT.toGregorian . toDay - - --- | Converts 'Date' value into a 'String' value with ISO format. --- --- >>> toString (read "2021-01-01") --- "2021-01-01" -toString :: Date -> String -toString = toFormattedString "%Y-%m-%d" - - --- | Converts 'Date' value into a 'String' value with the given format. --- --- >>> toFormattedString "%Y-%m-%d" (read "2021-01-01") --- "2021-01-01" --- >>> toFormattedString "%d/%m/%Y" (read "2021-01-01") --- "01/01/2021" -toFormattedString :: String -> Date -> String -toFormattedString fmt = DT.formatTime DT.defaultTimeLocale fmt . toDay - - --- | Converts 'Date' value into a 'T.Text' value with ISO format. --- --- >>> toText (read "2021-01-01") --- "2021-01-01" -toText :: Date -> T.Text -toText = T.pack . toString - - --- | Converts 'Date' value into a 'T.Text' value with the given format. --- --- >>> toFormattedText "%Y-%m-%d" (read "2021-01-01") --- "2021-01-01" --- >>> toFormattedText "%d/%m/%Y" (read "2021-01-01") --- "01/01/2021" -toFormattedText :: String -> Date -> T.Text -toFormattedText fmt = T.pack . toFormattedString fmt - - --- * Helper Functions --- &helpers - - --- | Adds (or subtracts) some days. --- --- >>> addDays (-1) $ fromYMD 2021 1 1 --- 2020-12-31 --- >>> addDays 1 $ addDays (-1) $ fromYMD 2021 1 1 --- 2021-01-01 -addDays :: Integer -> Date -> Date -addDays x (MkDate d) = MkDate (DT.addDays x d) diff --git a/src/Haspara/Internal/FXQuote.hs b/src/Haspara/Internal/FXQuote.hs index 59464f3..ce8870a 100644 --- a/src/Haspara/Internal/FXQuote.hs +++ b/src/Haspara/Internal/FXQuote.hs @@ -11,9 +11,9 @@ import Control.Monad.Except (MonadError(throwError), join) import Data.Aeson ((.:), (.=)) import qualified Data.Aeson as Aeson import Data.Scientific (Scientific) +import Data.Time (Day) 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) @@ -25,7 +25,7 @@ import Refined (Positive, Refined, refineError, unre -- | Type encoding for FX rates. data FXQuote (s :: Nat) = MkFXQuote { -- | Actual date of the FX rate. - fxQuoteDate :: !Date + fxQuoteDate :: !Day -- | Currency pair of the FX rate. , fxQuotePair :: !CurrencyPair -- | Rate value of the FX rate. @@ -71,7 +71,7 @@ instance (KnownNat s) => Aeson.FromJSON (FXQuote s) where -- >>> :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\"}" +-- "{\"rate\":1.35,\"ccy2\":\"SGD\",\"date\":\"2021-01-01\",\"ccy1\":\"USD\"}" instance (KnownNat s) => Aeson.ToJSON (FXQuote s) where toJSON (MkFXQuote d cp v) = Aeson.object [ "date" .= d @@ -88,7 +88,7 @@ instance (KnownNat s) => Aeson.ToJSON (FXQuote s) where -- | Smart constructor for 'FXQuote' values within 'MonadError' context. fxquote :: (KnownNat s, MonadError String m) - => Date -- ^ Date of the FX rate. + => Day -- ^ 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. @@ -102,7 +102,7 @@ fxquote d c1 c2 v = either (throwError . (<>) "Can not create FX Rate. Error was -- | Smart constructor for 'FXQuote' values within 'MonadFail' context. fxquoteFail :: (KnownNat s, MonadFail m) - => Date -- ^ Date of the FX rate. + => Day -- ^ 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. @@ -113,7 +113,7 @@ 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. + => Day -- ^ 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. diff --git a/src/Haspara/Internal/FXQuoteDatabase.hs b/src/Haspara/Internal/FXQuoteDatabase.hs index 5248988..ef00065 100644 --- a/src/Haspara/Internal/FXQuoteDatabase.hs +++ b/src/Haspara/Internal/FXQuoteDatabase.hs @@ -3,33 +3,33 @@ module Haspara.Internal.FXQuoteDatabase where -import qualified Data.HashMap.Strict as HM +import qualified Data.Map.Strict as SM +import Data.Time (Day, addDays) 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) +type FXQuoteDatabase (n :: Nat) = SM.Map CurrencyPair (FXQuotePairDatabase n) data FXQuotePairDatabase (n :: Nat) = FXQuotePairDatabase { fxQuotePairDatabasePair :: !CurrencyPair - , fxQuotePairDatabaseTable :: !(HM.HashMap Date (FXQuote n)) - , fxQuotePairDatabaseSince :: !Date - , fxQuotePairDatabaseUntil :: !Date + , fxQuotePairDatabaseTable :: !(SM.Map Day (FXQuote n)) + , fxQuotePairDatabaseSince :: !Day + , fxQuotePairDatabaseUntil :: !Day } -findFXQuote :: KnownNat n => FXQuoteDatabase n -> CurrencyPair -> Date -> Maybe (FXQuote n) -findFXQuote db cp d = case HM.lookup cp db of +findFXQuote :: KnownNat n => FXQuoteDatabase n -> CurrencyPair -> Day -> Maybe (FXQuote n) +findFXQuote db cp d = case SM.lookup cp db of Nothing -> Nothing Just pdb -> findFXQuoteAux d pdb -findFXQuoteAux :: KnownNat n => Date -> FXQuotePairDatabase n -> Maybe (FXQuote n) +findFXQuoteAux :: KnownNat n => Day -> FXQuotePairDatabase n -> Maybe (FXQuote n) findFXQuoteAux d db | d < fxQuotePairDatabaseSince db = Nothing - | otherwise = case HM.lookup d (fxQuotePairDatabaseTable db) of + | otherwise = case SM.lookup d (fxQuotePairDatabaseTable db) of Nothing -> findFXQuoteAux (addDays (-1) d) db Just fx -> Just fx diff --git a/src/Haspara/Internal/Money.hs b/src/Haspara/Internal/Money.hs index e3cf5b2..c58fa9d 100644 --- a/src/Haspara/Internal/Money.hs +++ b/src/Haspara/Internal/Money.hs @@ -7,16 +7,16 @@ import Control.Applicative ((<|>)) import Data.Aeson ((.:), (.=)) import qualified Data.Aeson as Aeson import Data.Scientific (Scientific) +import Data.Time (Day) 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) + MoneySome Day Currency (Quantity s) | MoneyZero | MoneyFail String deriving (Eq, Ord, Show) @@ -57,15 +57,15 @@ instance (KnownNat s) => Aeson.ToJSON (Money s) where toJSON (MoneyFail s) = Aeson.object ["error" .= s] -mkMoney :: KnownNat s => Date -> Currency -> Quantity s -> Money s +mkMoney :: KnownNat s => Day -> Currency -> Quantity s -> Money s mkMoney = MoneySome -mkMoneyFromScientific :: KnownNat s => Date -> Currency -> Scientific -> Money s +mkMoneyFromScientific :: KnownNat s => Day -> Currency -> Scientific -> Money s mkMoneyFromScientific d c s = mkMoney d c (quantity s) -moneyDate :: KnownNat s => Money s -> Maybe Date +moneyDate :: KnownNat s => Money s -> Maybe Day moneyDate (MoneySome d _ _) = Just d moneyDate MoneyZero = Nothing moneyDate (MoneyFail _) = Nothing @@ -89,7 +89,7 @@ moneyQuantity (MoneyFail _) = Nothing -- >>> import Haspara -- >>> let eur = either error id $ currency "EUR" -- >>> let usd = either error id $ currency "USD" --- >>> let date = read "2021-01-01" :: Date +-- >>> let date = read "2021-01-01" :: Day -- >>> 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 From 0b7d693732f197f1333d1ba86142df966afdd8a3 Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Wed, 2 Mar 2022 09:06:29 +0800 Subject: [PATCH 04/14] refactor: move definitions from Haspara.Internal.* to Haspara.* --- haspara.cabal | 5 - src/Haspara/Currency.hs | 205 +++++++++--- src/Haspara/FXQuote.hs | 176 +++++++++-- src/Haspara/Internal/Currency.hs | 158 ---------- src/Haspara/Internal/FXQuote.hs | 121 -------- src/Haspara/Internal/FXQuoteDatabase.hs | 35 --- src/Haspara/Internal/Money.hs | 116 ------- src/Haspara/Internal/Quantity.hs | 365 ---------------------- src/Haspara/Money.hs | 155 +++++++--- src/Haspara/Quantity.hs | 393 ++++++++++++++++++++++-- 10 files changed, 788 insertions(+), 941 deletions(-) delete mode 100644 src/Haspara/Internal/Currency.hs delete mode 100644 src/Haspara/Internal/FXQuote.hs delete mode 100644 src/Haspara/Internal/FXQuoteDatabase.hs delete mode 100644 src/Haspara/Internal/Money.hs delete mode 100644 src/Haspara/Internal/Quantity.hs diff --git a/haspara.cabal b/haspara.cabal index 99885d6..799438f 100644 --- a/haspara.cabal +++ b/haspara.cabal @@ -38,11 +38,6 @@ library Haspara.Accounting.Types Haspara.Currency Haspara.FXQuote - Haspara.Internal.Currency - Haspara.Internal.FXQuote - Haspara.Internal.FXQuoteDatabase - Haspara.Internal.Money - Haspara.Internal.Quantity Haspara.Money Haspara.Quantity Haspara.TH diff --git a/src/Haspara/Currency.hs b/src/Haspara/Currency.hs index e57658b..f0c52ad 100644 --- a/src/Haspara/Currency.hs +++ b/src/Haspara/Currency.hs @@ -1,48 +1,157 @@ --- | 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 - ) +-- | This module provides definitions for modeling and working with currencies. + +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Haspara.Currency where + +import Control.Monad.Except (MonadError(throwError)) +import qualified Data.Aeson as Aeson +import Data.Hashable (Hashable) +import Data.String (IsString(..)) +import qualified Data.Text as T +import Data.Void (Void) +import qualified 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/FXQuote.hs b/src/Haspara/FXQuote.hs index 3b170e4..316fee2 100644 --- a/src/Haspara/FXQuote.hs +++ b/src/Haspara/FXQuote.hs @@ -1,32 +1,146 @@ --- | This module provides base data definitions and functions for 'Haspara' --- library. +-- | This module provides definitions for modeling and working with FX rates. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} + +module Haspara.FXQuote where + +import Control.Monad.Except (MonadError(throwError), join) +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Map.Strict as SM +import Data.Scientific (Scientific) +import Data.Time (Day, addDays) +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Currency (Currency, CurrencyPair, baseCurrency, currencyPair, quoteCurrency) +import Haspara.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 :: !Day + -- | 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' -- -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) +-- >>> :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 +-- "{\"rate\":1.35,\"ccy2\":\"SGD\",\"date\":\"2021-01-01\",\"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) + => Day -- ^ 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) + => Day -- ^ 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 + => Day -- ^ 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 + + +type FXQuoteDatabase (n :: Nat) = SM.Map CurrencyPair (FXQuotePairDatabase n) + + +data FXQuotePairDatabase (n :: Nat) = FXQuotePairDatabase + { fxQuotePairDatabasePair :: !CurrencyPair + , fxQuotePairDatabaseTable :: !(SM.Map Day (FXQuote n)) + , fxQuotePairDatabaseSince :: !Day + , fxQuotePairDatabaseUntil :: !Day + } + + +findFXQuote :: KnownNat n => FXQuoteDatabase n -> CurrencyPair -> Day -> Maybe (FXQuote n) +findFXQuote db cp d = case SM.lookup cp db of + Nothing -> Nothing + Just pdb -> findFXQuoteAux d pdb + + +findFXQuoteAux :: KnownNat n => Day -> FXQuotePairDatabase n -> Maybe (FXQuote n) +findFXQuoteAux d db + | d < fxQuotePairDatabaseSince db = Nothing + | otherwise = case SM.lookup d (fxQuotePairDatabaseTable db) of + Nothing -> findFXQuoteAux (addDays (-1) d) db + Just fx -> Just fx diff --git a/src/Haspara/Internal/Currency.hs b/src/Haspara/Internal/Currency.hs deleted file mode 100644 index 63a73c5..0000000 --- a/src/Haspara/Internal/Currency.hs +++ /dev/null @@ -1,158 +0,0 @@ --- | This module provides internal definitions for modeling and working with --- currencies. --- -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module Haspara.Internal.Currency where - -import Control.Monad.Except (MonadError(throwError)) -import qualified Data.Aeson as Aeson -import Data.Hashable (Hashable) -import Data.String (IsString(..)) -import qualified Data.Text as T -import Data.Void (Void) -import qualified Language.Haskell.TH.Syntax as TH -import qualified Text.Megaparsec as MP - - --- * Data Definition --- &definition - --- | Type encoding for currencies. -newtype Currency = MkCurrency { currencyCode :: T.Text } - deriving (Eq, Hashable, Ord, TH.Lift) - - --- | 'Show' instance for 'Currency'. --- --- >>> MkCurrency "USD" --- USD -instance Show Currency where - show (MkCurrency x) = T.unpack x - - --- | 'IsString' instance for 'Currency'. --- --- >>> "USD" :: Currency --- USD -instance IsString Currency where - fromString = either error id . currency . T.pack - - --- | 'Aeson.FromJSON' instance for 'Currency'. --- --- >>> Aeson.eitherDecode "\"\"" :: Either String Currency --- Left "Error in $: Currency code error! Expecting at least 3 uppercase characters, but received: \"\"" --- >>> Aeson.eitherDecode "\"ABC\"" :: Either String Currency --- Right ABC -instance Aeson.FromJSON Currency where - parseJSON = Aeson.withText "Currency" $ either fail pure . currency - - --- | 'Aeson.ToJSON' instance for 'Currency'. --- --- >>> Aeson.encode (MkCurrency "USD") --- "\"USD\"" -instance Aeson.ToJSON Currency where - toJSON (MkCurrency c) = Aeson.String c - - --- * Constructors --- &constructors - - --- | Smart constructor for 'Currency' values within 'MonadError' context. --- --- >>> currency "" :: Either String Currency --- Left "Currency code error! Expecting at least 3 uppercase characters, but received: \"\"" --- >>> currency " " :: Either String Currency --- Left "Currency code error! Expecting at least 3 uppercase characters, but received: \" \"" --- >>> currency "AB" :: Either String Currency --- Left "Currency code error! Expecting at least 3 uppercase characters, but received: \"AB\"" --- >>> currency " ABC " :: Either String Currency --- Left "Currency code error! Expecting at least 3 uppercase characters, but received: \" ABC \"" --- >>> currency "ABC" :: Either String Currency --- Right ABC -currency :: MonadError String m => T.Text -> m Currency -currency x = either - (const . throwError $ "Currency code error! Expecting at least 3 uppercase characters, but received: " <> show x) - (pure . MkCurrency) - (MP.runParser currencyCodeParser "Currency Code" x) - - --- | Smart constructor for 'Currency' values within 'MonadFail' context. --- --- >>> currencyFail "" :: Maybe Currency --- Nothing --- >>> currencyFail "US" :: Maybe Currency --- Nothing --- >>> currencyFail "usd" :: Maybe Currency --- Nothing --- >>> currencyFail "USD" :: Maybe Currency --- Just USD -currencyFail :: MonadFail m => T.Text -> m Currency -currencyFail = either fail pure . currency - - --- * Auxiliaries --- &auxiliaries - - --- | Parser that parses currency codes. --- --- >>> MP.runParser currencyCodeParser "Example" "" --- Left (ParseErrorBundle {bundleErrors = TrivialError 0 (Just EndOfInput) (fromList []) :| [], bundlePosState = PosState {pstateInput = "", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}}) --- >>> MP.runParser currencyCodeParser "Example" " " --- Left (ParseErrorBundle {bundleErrors = TrivialError 0 (Just (Tokens (' ' :| ""))) (fromList []) :| [], bundlePosState = PosState {pstateInput = " ", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}}) --- >>> MP.runParser currencyCodeParser "Example" "a" --- Left (ParseErrorBundle {bundleErrors = TrivialError 0 (Just (Tokens ('a' :| ""))) (fromList []) :| [], bundlePosState = PosState {pstateInput = "a", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}}) --- >>> MP.runParser currencyCodeParser "Example" "A" --- Left (ParseErrorBundle {bundleErrors = TrivialError 1 (Just EndOfInput) (fromList []) :| [], bundlePosState = PosState {pstateInput = "A", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}}) --- >>> MP.runParser currencyCodeParser "Example" "AB" --- Left (ParseErrorBundle {bundleErrors = TrivialError 2 (Just EndOfInput) (fromList []) :| [], bundlePosState = PosState {pstateInput = "AB", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}}) --- >>> MP.runParser currencyCodeParser "Example" "ABC" --- Right "ABC" -currencyCodeParser :: MP.Parsec Void T.Text T.Text -currencyCodeParser = do - mandatory <- MP.count 3 parserChar - optionals <- MP.many parserChar - pure . T.pack $ mandatory <> optionals - where - validChars = ['A'..'Z'] - parserChar = MP.oneOf validChars - - -newtype CurrencyPair = MkCurrencyPair { unCurrencyPair :: (Currency, Currency) } - deriving (Eq, Hashable, Ord, TH.Lift) - - --- | 'Show' instance for currency pairs. --- --- >>> MkCurrencyPair ("EUR", "USD") --- EUR/USD -instance Show CurrencyPair where - show (MkCurrencyPair (x, y)) = show x <> "/" <> show y - - -toTuple :: CurrencyPair -> (Currency, Currency) -toTuple = unCurrencyPair - - -baseCurrency :: CurrencyPair -> Currency -baseCurrency = fst . unCurrencyPair - - -quoteCurrency :: CurrencyPair -> Currency -quoteCurrency = snd . unCurrencyPair - - -currencyPair :: MonadError String m => Currency -> Currency -> m CurrencyPair -currencyPair c1 c2 - | c1 == c2 = throwError $ "Can not create currency pair from same currencies: " <> show c1 <> " and " <> show c2 - | otherwise = pure (MkCurrencyPair (c1, c2)) - - -currencyPairFail :: MonadFail m => Currency -> Currency -> m CurrencyPair -currencyPairFail = (either fail pure .) . currencyPair diff --git a/src/Haspara/Internal/FXQuote.hs b/src/Haspara/Internal/FXQuote.hs deleted file mode 100644 index ce8870a..0000000 --- a/src/Haspara/Internal/FXQuote.hs +++ /dev/null @@ -1,121 +0,0 @@ --- | This module provides internal definitions for modeling and working with FX --- rates. --- -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} - -module Haspara.Internal.FXQuote where - -import Control.Monad.Except (MonadError(throwError), join) -import Data.Aeson ((.:), (.=)) -import qualified Data.Aeson as Aeson -import Data.Scientific (Scientific) -import Data.Time (Day) -import GHC.TypeLits (KnownNat, Nat) -import Haspara.Internal.Currency (Currency, CurrencyPair, baseCurrency, currencyPair, quoteCurrency) -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 :: !Day - -- | 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 --- "{\"rate\":1.35,\"ccy2\":\"SGD\",\"date\":\"2021-01-01\",\"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) - => Day -- ^ 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) - => Day -- ^ 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 - => Day -- ^ Date of the FX rate. - -> Currency -- ^ First currency (from) of the FX rate. - -> Currency -- ^ Second currency (to) of the FX rate. - -> Scientific -- ^ FX rate value. - -> FXQuote s -fxquoteUnsafe d c1 c2 = either error id . fxquote d c1 c2 diff --git a/src/Haspara/Internal/FXQuoteDatabase.hs b/src/Haspara/Internal/FXQuoteDatabase.hs deleted file mode 100644 index ef00065..0000000 --- a/src/Haspara/Internal/FXQuoteDatabase.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} - -module Haspara.Internal.FXQuoteDatabase where - -import qualified Data.Map.Strict as SM -import Data.Time (Day, addDays) -import GHC.TypeLits (KnownNat, Nat) -import Haspara.Internal.Currency (CurrencyPair) -import Haspara.Internal.FXQuote (FXQuote) - - -type FXQuoteDatabase (n :: Nat) = SM.Map CurrencyPair (FXQuotePairDatabase n) - - -data FXQuotePairDatabase (n :: Nat) = FXQuotePairDatabase - { fxQuotePairDatabasePair :: !CurrencyPair - , fxQuotePairDatabaseTable :: !(SM.Map Day (FXQuote n)) - , fxQuotePairDatabaseSince :: !Day - , fxQuotePairDatabaseUntil :: !Day - } - - -findFXQuote :: KnownNat n => FXQuoteDatabase n -> CurrencyPair -> Day -> Maybe (FXQuote n) -findFXQuote db cp d = case SM.lookup cp db of - Nothing -> Nothing - Just pdb -> findFXQuoteAux d pdb - - -findFXQuoteAux :: KnownNat n => Day -> FXQuotePairDatabase n -> Maybe (FXQuote n) -findFXQuoteAux d db - | d < fxQuotePairDatabaseSince db = Nothing - | otherwise = case SM.lookup d (fxQuotePairDatabaseTable db) of - Nothing -> findFXQuoteAux (addDays (-1) d) db - Just fx -> Just fx diff --git a/src/Haspara/Internal/Money.hs b/src/Haspara/Internal/Money.hs deleted file mode 100644 index c58fa9d..0000000 --- a/src/Haspara/Internal/Money.hs +++ /dev/null @@ -1,116 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} - -module Haspara.Internal.Money where - -import Control.Applicative ((<|>)) -import Data.Aeson ((.:), (.=)) -import qualified Data.Aeson as Aeson -import Data.Scientific (Scientific) -import Data.Time (Day) -import GHC.TypeLits (KnownNat, Nat) -import Haspara.Internal.Currency (Currency, baseCurrency, quoteCurrency) -import Haspara.Internal.FXQuote (FXQuote(fxQuotePair, fxQuoteRate)) -import Haspara.Internal.Quantity (Quantity, quantity, times) -import Refined (unrefine) - - -data Money (s :: Nat) = - MoneySome Day 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 => Day -> Currency -> Quantity s -> Money s -mkMoney = MoneySome - - -mkMoneyFromScientific :: KnownNat s => Day -> Currency -> Scientific -> Money s -mkMoneyFromScientific d c s = mkMoney d c (quantity s) - - -moneyDate :: KnownNat s => Money s -> Maybe Day -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" :: Day --- >>> let eurmoney = mkMoney date eur (quantity 0.42 :: Quantity 2) :: Money 2 --- >>> convert eurmoney eur (quantity 1 :: Quantity 4) --- MoneySome 2021-01-01 EUR 0.42 --- >>> convert eurmoney usd (quantity 1 :: Quantity 4) --- MoneySome 2021-01-01 USD 0.42 --- >>> convert eurmoney usd (quantity 1.1516 :: Quantity 4) --- MoneySome 2021-01-01 USD 0.48 -convert :: (KnownNat s, KnownNat k) => Money s -> Currency -> Quantity k -> Money s -convert MoneyZero _ _ = MoneyZero -convert x@(MoneyFail _) _ _ = x -convert x@(MoneySome d cbase q) cquot rate - | cbase == cquot && rate == 1 = x - | cbase == cquot && rate /= 1 = MoneyFail $ "Attempting to convert from same currency with rate != 1: " <> show x <> " to " <> show cquot <> " with " <> show rate - | otherwise = MoneySome d cquot (times q rate) - - --- | Converts the given 'Money' value to another currency with the given --- 'FXQuote'. -convertWithQuote :: (KnownNat s, KnownNat k) => Money s -> FXQuote k -> Money s -convertWithQuote MoneyZero _ = MoneyZero -convertWithQuote x@(MoneyFail _) _ = x -convertWithQuote x@(MoneySome _ cbase _) quote - | cbase /= baseCurrency (fxQuotePair quote) = MoneyFail $ "Attempting to convert with incompatible base currency: " <> show x <> " with " <> show quote - | otherwise = convert x (quoteCurrency (fxQuotePair quote)) (unrefine $ fxQuoteRate quote) diff --git a/src/Haspara/Internal/Quantity.hs b/src/Haspara/Internal/Quantity.hs deleted file mode 100644 index 6cbe6ac..0000000 --- a/src/Haspara/Internal/Quantity.hs +++ /dev/null @@ -1,365 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} - -{-# OPTIONS_GHC -Wno-orphans #-} - -module Haspara.Internal.Quantity where - -import Control.Applicative (liftA2) -import Control.Monad.Except (MonadError(throwError)) -import qualified Data.Aeson as Aeson -import Data.Either (fromRight) -import Data.Proxy (Proxy(..)) -import qualified Data.Scientific as S -import GHC.Generics (Generic) -import GHC.TypeLits (KnownNat, Nat, natVal, type (+)) -import qualified Language.Haskell.TH.Syntax as TH -import qualified Numeric.Decimal as D - - --- $setup --- >>> :set -XDataKinds - - --- | Type encoding for common quantity values with given scaling (digits after --- the decimal point). --- --- >>> 42 :: Quantity 0 --- 42 --- >>> 42 :: Quantity 1 --- 42.0 --- >>> 42 :: Quantity 2 --- 42.00 --- >>> 41 + 1 :: Quantity 2 --- 42.00 --- >>> 43 - 1 :: Quantity 2 --- 42.00 --- >>> 2 * 3 * 7 :: Quantity 2 --- 42.00 --- >>> negate (-42) :: Quantity 2 --- 42.00 --- >>> abs (-42) :: Quantity 2 --- 42.00 --- >>> signum (-42) :: Quantity 2 --- -1.00 --- >>> fromInteger 42 :: Quantity 2 --- 42.00 --- >>> quantity 0.415 :: Quantity 2 --- 0.42 --- >>> quantity 0.425 :: Quantity 2 --- 0.42 --- >>> quantityLossless 0.42 :: Either String (Quantity 2) --- Right 0.42 --- >>> quantityLossless 0.415 :: Either String (Quantity 2) --- Left "Underflow while trying to create quantity: 0.415" -newtype Quantity (s :: Nat) = MkQuantity { unQuantity :: D.Decimal D.RoundHalfEven s Integer } - deriving (Eq, Ord, Generic, Num) - - --- | Orphan 'TH.Lift' instance for 'Quantity'. --- --- TODO: Avoid having an orphan instance for @Decimal r s p@? -deriving instance TH.Lift (D.Decimal D.RoundHalfEven s Integer) - - --- | 'TH.Lift' instance for 'Quantity'. -deriving instance TH.Lift (Quantity s) - - --- | 'Aeson.FromJSON' instance for 'Quantity'. --- --- >>> Aeson.decode "0.42" :: Maybe (Quantity 2) --- Just 0.42 --- >>> Aeson.decode "0.415" :: Maybe (Quantity 2) --- Just 0.42 --- >>> Aeson.decode "0.425" :: Maybe (Quantity 2) --- Just 0.42 -instance (KnownNat s) => Aeson.FromJSON (Quantity s) where - parseJSON = Aeson.withScientific "Quantity" (pure . quantity) - - --- | 'Aeson.ToJSON' instance for 'Quantity'. --- --- >>> Aeson.encode (quantity 0.42 :: Quantity 2) --- "0.42" -instance (KnownNat s) => Aeson.ToJSON (Quantity s) where - toJSON = Aeson.Number . D.toScientificDecimal . unQuantity - - --- | Numeric arithmetic over 'Quantity' values. --- --- >>> import Numeric.Decimal --- >>> let a = Arith (quantity 10) + Arith (quantity 32) :: Arith (Quantity 2) --- >>> arithMaybe a --- Just 42.00 --- >>> arithM (41 + 1) :: Either SomeException (Quantity 2) --- Right 42.00 --- >>> arithM (43 - 1) :: Either SomeException (Quantity 2) --- Right 42.00 --- >>> arithM (2 * 3 * 7) :: Either SomeException (Quantity 2) --- Right 42.00 --- >>> arithM (signum 42) :: Either SomeException (Quantity 2) --- Right 1.00 --- >>> arithM (signum (-42)) :: Either SomeException (Quantity 2) --- Right -1.00 --- >>> arithM (abs 42) :: Either SomeException (Quantity 2) --- Right 42.00 --- >>> arithM (abs (-42)) :: Either SomeException (Quantity 2) --- Right 42.00 --- >>> arithM (fromInteger 42) :: Either SomeException (Quantity 2) --- Right 42.00 -instance (KnownNat s) => Num (D.Arith (Quantity s)) where - (+) = liftA2 (+) - (-) = liftA2 (-) - (*) = liftA2 (*) - signum = fmap signum - abs = fmap abs - fromInteger = pure . MkQuantity . D.fromIntegerDecimal - - --- | Fractional arithmetic over 'Quantity' values. --- --- >>> import Numeric.Decimal --- >>> arithM (fromRational 0.42) :: Either SomeException (Quantity 2) --- Right 0.42 --- >>> arithM (fromRational 0.415) :: Either SomeException (Quantity 2) --- Left PrecisionLoss (83 % 200) to 2 decimal spaces --- >>> arithM $ (fromRational 0.84) / (fromRational 2) :: Either SomeException (Quantity 2) --- Right 0.42 --- >>> arithM $ (fromRational 0.42) / (fromRational 0) :: Either SomeException (Quantity 2) --- Left divide by zero --- >>> let a = 84 :: Quantity 2 --- >>> let b = 2 :: Quantity 2 --- >>> let c = 0 :: Quantity 2 --- >>> arithM (Arith a / Arith b) :: Either SomeException (Quantity 2) --- Right 42.00 --- >>> arithM (Arith a / Arith b / Arith c) :: Either SomeException (Quantity 2) --- Left divide by zero -instance (KnownNat s) => Fractional (D.Arith (Quantity s)) where - a / b = fmap MkQuantity $ fmap unQuantity a / fmap unQuantity b - fromRational = fmap MkQuantity . D.fromRationalDecimalWithoutLoss - - --- | 'Show' instance for 'Quantity'. --- --- >>> show (42 :: Quantity 2) --- "42.00" --- >>> 42 :: Quantity 2 --- 42.00 -instance KnownNat s => Show (Quantity s) where - show = show . unQuantity - - --- | Constructs 'Quantity' values from 'S.Scientific' values in a lossy way. --- --- This function uses 'quantityAux' in case that the lossless attempt fails. We --- could have used 'quantityAux' directly. However, 'quantityAux' is doing too --- much (see 'roundScientific'). Therefore, we are first attempting a lossless --- construction (see 'quantityLossless') and we fallback to 'quantityAux' in --- case the lossless construction fails. --- --- >>> quantity 0 :: Quantity 0 --- 0 --- >>> quantity 0 :: Quantity 1 --- 0.0 --- >>> quantity 0 :: Quantity 2 --- 0.00 --- >>> quantity 0.04 :: Quantity 1 --- 0.0 --- >>> quantity 0.05 :: Quantity 1 --- 0.0 --- >>> quantity 0.06 :: Quantity 1 --- 0.1 --- >>> quantity 0.14 :: Quantity 1 --- 0.1 --- >>> quantity 0.15 :: Quantity 1 --- 0.2 --- >>> quantity 0.16 :: Quantity 1 --- 0.2 --- >>> quantity 0.04 :: Quantity 2 --- 0.04 --- >>> quantity 0.05 :: Quantity 2 --- 0.05 --- >>> quantity 0.06 :: Quantity 2 --- 0.06 --- >>> quantity 0.14 :: Quantity 2 --- 0.14 --- >>> quantity 0.15 :: Quantity 2 --- 0.15 --- >>> quantity 0.16 :: Quantity 2 --- 0.16 --- >>> quantity 0.04 :: Quantity 3 --- 0.040 --- >>> quantity 0.05 :: Quantity 3 --- 0.050 --- >>> quantity 0.06 :: Quantity 3 --- 0.060 --- >>> quantity 0.14 :: Quantity 3 --- 0.140 --- >>> quantity 0.15 :: Quantity 3 --- 0.150 --- >>> quantity 0.16 :: Quantity 3 --- 0.160 -quantity :: KnownNat s => S.Scientific -> Quantity s -quantity s = case quantityLossless s of - Left _ -> quantityAux s - Right dv -> dv - - --- | Auxiliary function for 'quantity' implementation. --- --- See 'quantity' why we need this function and why we haven't used it as the --- direct implementation of 'quantity'. --- --- Call-sites should avoid using this function directly due to its performance --- characteristics. -quantityAux :: forall s. KnownNat s => S.Scientific -> Quantity s -quantityAux x = fromRight err $ quantityLossless (roundScientific nof x) - where - -- Get the term-level scaling for the target value: - nof = fromIntegral $ natVal (Proxy :: Proxy s) - - -- This function should NOT fail in practice ever, but theoretically it can - -- due to type signatures. We will let it error with a message to ourselves: - err = error $ "PROGRAMMING ERROR: Can not construct 'Quantity " <> show nof <> "' with '" <> show x <> "' in a lossy way." - - --- | Constructs 'Quantity' values from 'S.Scientific' values in a lossy way. --- --- >>> quantityLossless 0 :: Either String (Quantity 0) --- Right 0 --- >>> quantityLossless 0 :: Either String (Quantity 1) --- Right 0.0 --- >>> quantityLossless 0 :: Either String (Quantity 2) --- Right 0.00 --- >>> quantityLossless 0.04 :: Either String (Quantity 1) --- Left "Underflow while trying to create quantity: 4.0e-2" --- >>> quantityLossless 0.05 :: Either String (Quantity 1) --- Left "Underflow while trying to create quantity: 5.0e-2" --- >>> quantityLossless 0.06 :: Either String (Quantity 1) --- Left "Underflow while trying to create quantity: 6.0e-2" --- >>> quantityLossless 0.14 :: Either String (Quantity 1) --- Left "Underflow while trying to create quantity: 0.14" --- >>> quantityLossless 0.15 :: Either String (Quantity 1) --- Left "Underflow while trying to create quantity: 0.15" --- >>> quantityLossless 0.16 :: Either String (Quantity 1) --- Left "Underflow while trying to create quantity: 0.16" --- >>> quantityLossless 0.04 :: Either String (Quantity 2) --- Right 0.04 --- >>> quantityLossless 0.05 :: Either String (Quantity 2) --- Right 0.05 --- >>> quantityLossless 0.06 :: Either String (Quantity 2) --- Right 0.06 --- >>> quantityLossless 0.14 :: Either String (Quantity 2) --- Right 0.14 --- >>> quantityLossless 0.15 :: Either String (Quantity 2) --- Right 0.15 --- >>> quantityLossless 0.16 :: Either String (Quantity 2) --- Right 0.16 --- >>> quantityLossless 0.04 :: Either String (Quantity 3) --- Right 0.040 --- >>> quantityLossless 0.05 :: Either String (Quantity 3) --- Right 0.050 --- >>> quantityLossless 0.06 :: Either String (Quantity 3) --- Right 0.060 --- >>> quantityLossless 0.14 :: Either String (Quantity 3) --- Right 0.140 --- >>> quantityLossless 0.15 :: Either String (Quantity 3) --- Right 0.150 --- >>> quantityLossless 0.16 :: Either String (Quantity 3) --- Right 0.160 -quantityLossless :: (KnownNat s, MonadError String m) => S.Scientific -> m (Quantity s) -quantityLossless s = either (const $ throwError ("Underflow while trying to create quantity: " <> show s)) (pure . MkQuantity) $ D.fromScientificDecimal s - - --- | Rounds given quantity by @k@ digits. --- --- >>> roundQuantity (quantity 0.415 :: Quantity 3) :: Quantity 2 --- 0.42 --- >>> roundQuantity (quantity 0.425 :: Quantity 3) :: Quantity 2 --- 0.42 -roundQuantity :: KnownNat k => Quantity (n + k) -> Quantity n -roundQuantity (MkQuantity d) = MkQuantity (D.roundDecimal d) - - --- | Multiplies two quantities with different scales and rounds back to the scale of the frst operand. --- --- >>> times (quantity 0.42 :: Quantity 2) (quantity 0.42 :: Quantity 2) --- 0.18 -times :: (KnownNat s, KnownNat k) => Quantity s -> Quantity k -> Quantity s -times q1 q2 = roundQuantity (timesLossless q1 q2) - - --- | Multiplies two quantities with different scales. --- --- >>> timesLossless (quantity 0.42 :: Quantity 2) (quantity 0.42 :: Quantity 2) --- 0.1764 -timesLossless :: (KnownNat s, KnownNat k) => Quantity s -> Quantity k -> Quantity (s + k) -timesLossless (MkQuantity d1) (MkQuantity d2) = MkQuantity (D.timesDecimal d1 d2) - - --- | Rounds a given scientific into a new scientific with given max digits after --- decimal point. --- --- This uses half-even rounding method. --- --- >>> roundScientific 0 0.4 --- 0.0 --- >>> roundScientific 0 0.5 --- 0.0 --- >>> roundScientific 0 0.6 --- 1.0 --- >>> roundScientific 0 1.4 --- 1.0 --- >>> roundScientific 0 1.5 --- 2.0 --- >>> roundScientific 0 1.6 --- 2.0 --- >>> roundScientific 1 0.04 --- 0.0 --- >>> roundScientific 1 0.05 --- 0.0 --- >>> roundScientific 1 0.06 --- 0.1 --- >>> roundScientific 1 0.14 --- 0.1 --- >>> roundScientific 1 0.15 --- 0.2 --- >>> roundScientific 1 0.16 --- 0.2 --- >>> roundScientific 1 3.650 --- 3.6 --- >>> roundScientific 1 3.740 --- 3.7 --- >>> roundScientific 1 3.749 --- 3.7 --- >>> roundScientific 1 3.750 --- 3.8 --- >>> roundScientific 1 3.751 --- 3.8 --- >>> roundScientific 1 3.760 --- 3.8 --- >>> roundScientific 1 (-3.650) --- -3.6 --- >>> roundScientific 1 (-3.740) --- -3.7 --- >>> roundScientific 1 (-3.749) --- -3.7 --- >>> roundScientific 1 (-3.750) --- -3.8 --- >>> roundScientific 1 (-3.751) --- -3.8 --- >>> roundScientific 1 (-3.760) --- -3.8 --- --- TODO: Refactor to improve the performance of this function. -roundScientific :: Int -> S.Scientific -> S.Scientific -roundScientific = (read .) . S.formatScientific S.Fixed . Just diff --git a/src/Haspara/Money.hs b/src/Haspara/Money.hs index 1fbab20..7824af8 100644 --- a/src/Haspara/Money.hs +++ b/src/Haspara/Money.hs @@ -1,38 +1,119 @@ --- | This module provides base data definitions and functions for 'Haspara' --- library. +-- | This module provides definitions for modeling and working with monetary +-- values. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} + +module Haspara.Money where + +import Control.Applicative ((<|>)) +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson +import Data.Scientific (Scientific) +import Data.Time (Day) +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Currency (Currency, baseCurrency, quoteCurrency) +import Haspara.FXQuote (FXQuote(fxQuotePair, fxQuoteRate)) +import Haspara.Quantity (Quantity, quantity, times) +import Refined (unrefine) + + +data Money (s :: Nat) = + MoneySome Day 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 => Day -> Currency -> Quantity s -> Money s +mkMoney = MoneySome + + +mkMoneyFromScientific :: KnownNat s => Day -> Currency -> Scientific -> Money s +mkMoneyFromScientific d c s = mkMoney d c (quantity s) + + +moneyDate :: KnownNat s => Money s -> Maybe Day +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. -- -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 - ) +-- >>> import Haspara +-- >>> let eur = either error id $ currency "EUR" +-- >>> let usd = either error id $ currency "USD" +-- >>> let date = read "2021-01-01" :: Day +-- >>> 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/Quantity.hs b/src/Haspara/Quantity.hs index e0ce663..1e9460a 100644 --- a/src/Haspara/Quantity.hs +++ b/src/Haspara/Quantity.hs @@ -1,25 +1,368 @@ --- | 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) +-- | This module provides definitions for modeling and working with quantities +-- with fixed decimal points. + +{-# 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.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 From ee3a625ff74d28f8ad9957bfbc46aa54cdaa47a3 Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Wed, 2 Mar 2022 09:07:11 +0800 Subject: [PATCH 05/14] chore(dev): produce .hie files during compilation --- stack.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/stack.yaml b/stack.yaml index 943ae8b..908ea0c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,3 +1,5 @@ resolver: lts-18.27 packages: - . +ghc-options: + "$locals": -fwrite-ide-info -hiedir=.hie From ae8f705ed6fafd1f2666101f90eb53a0c30c6806 Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Wed, 2 Mar 2022 09:51:58 +0800 Subject: [PATCH 06/14] refactor: adopt Haskell 2021 extensions --- haspara.cabal | 36 ++++++++++++++++++++ package.yaml | 38 +++++++++++++++++++++ src/Haspara/Accounting/Account.hs | 5 ++- src/Haspara/Accounting/AccountKind.hs | 2 -- src/Haspara/Accounting/Entry.hs | 3 +- src/Haspara/Accounting/Event.hs | 4 +-- src/Haspara/Accounting/Ledger.hs | 7 ++-- src/Haspara/Accounting/Posting.hs | 7 ++-- src/Haspara/Currency.hs | 4 --- src/Haspara/FXQuote.hs | 4 +-- src/Haspara/Money.hs | 3 +- src/Haspara/Quantity.hs | 11 +----- src/Haspara/TH.hs | 2 -- test/doctest.hs | 48 +++++++++++++++++++++++++-- 14 files changed, 131 insertions(+), 43 deletions(-) diff --git a/haspara.cabal b/haspara.cabal index 799438f..ad43bc5 100644 --- a/haspara.cabal +++ b/haspara.cabal @@ -46,6 +46,42 @@ library hs-source-dirs: src default-extensions: + BangPatterns + BinaryLiterals + ConstrainedClassMethods + ConstraintKinds + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveLift + DeriveTraversable + EmptyCase + EmptyDataDeriving + ExistentialQuantification + ExplicitForAll + FlexibleContexts + FlexibleInstances + GADTSyntax + GeneralisedNewtypeDeriving + HexFloatLiterals + ImportQualifiedPost + InstanceSigs + KindSignatures + MultiParamTypeClasses + NamedFieldPuns + NamedWildCards + NumericUnderscores + PolyKinds + PostfixOperators + RankNTypes + ScopedTypeVariables + StandaloneDeriving + StandaloneKindSignatures + TupleSections + TypeApplications + TypeOperators + TypeSynonymInstances OverloadedStrings ghc-options: -Wall -Wunused-packages build-depends: diff --git a/package.yaml b/package.yaml index e10da64..d491f46 100644 --- a/package.yaml +++ b/package.yaml @@ -35,6 +35,44 @@ library: - -Wall - -Wunused-packages default-extensions: + ## Begin: Haskell 2021 Extensions List + - BangPatterns + - BinaryLiterals + - ConstrainedClassMethods + - ConstraintKinds + - DeriveDataTypeable + - DeriveFoldable + - DeriveFunctor + - DeriveGeneric + - DeriveLift + - DeriveTraversable + - EmptyCase + - EmptyDataDeriving + - ExistentialQuantification + - ExplicitForAll + - FlexibleContexts + - FlexibleInstances + - GADTSyntax + - GeneralisedNewtypeDeriving + - HexFloatLiterals + - ImportQualifiedPost + - InstanceSigs + - KindSignatures + - MultiParamTypeClasses + - NamedFieldPuns + - NamedWildCards + - NumericUnderscores + - PolyKinds + - PostfixOperators + - RankNTypes + - ScopedTypeVariables + - StandaloneDeriving + - StandaloneKindSignatures + - TupleSections + - TypeApplications + - TypeOperators + - TypeSynonymInstances + ## End: Haskell 2021 Extensions List - OverloadedStrings tests: diff --git a/src/Haspara/Accounting/Account.hs b/src/Haspara/Accounting/Account.hs index 5c9ed75..f848969 100644 --- a/src/Haspara/Accounting/Account.hs +++ b/src/Haspara/Accounting/Account.hs @@ -1,6 +1,5 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} module Haspara.Accounting.Account where diff --git a/src/Haspara/Accounting/AccountKind.hs b/src/Haspara/Accounting/AccountKind.hs index 65dc3a9..d5a1da2 100644 --- a/src/Haspara/Accounting/AccountKind.hs +++ b/src/Haspara/Accounting/AccountKind.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} - module Haspara.Accounting.AccountKind where import qualified Data.Aeson as Aeson diff --git a/src/Haspara/Accounting/Entry.hs b/src/Haspara/Accounting/Entry.hs index ebb6314..59328d6 100644 --- a/src/Haspara/Accounting/Entry.hs +++ b/src/Haspara/Accounting/Entry.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} module Haspara.Accounting.Entry where diff --git a/src/Haspara/Accounting/Event.hs b/src/Haspara/Accounting/Event.hs index e88cdbb..28e0e8e 100644 --- a/src/Haspara/Accounting/Event.hs +++ b/src/Haspara/Accounting/Event.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} module Haspara.Accounting.Event where diff --git a/src/Haspara/Accounting/Ledger.hs b/src/Haspara/Accounting/Ledger.hs index 3ae4ef5..452485b 100644 --- a/src/Haspara/Accounting/Ledger.hs +++ b/src/Haspara/Accounting/Ledger.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} module Haspara.Accounting.Ledger where diff --git a/src/Haspara/Accounting/Posting.hs b/src/Haspara/Accounting/Posting.hs index 513da44..d835e65 100644 --- a/src/Haspara/Accounting/Posting.hs +++ b/src/Haspara/Accounting/Posting.hs @@ -1,8 +1,5 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} module Haspara.Accounting.Posting where diff --git a/src/Haspara/Currency.hs b/src/Haspara/Currency.hs index f0c52ad..7f30911 100644 --- a/src/Haspara/Currency.hs +++ b/src/Haspara/Currency.hs @@ -1,9 +1,5 @@ -- | This module provides definitions for modeling and working with currencies. -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Haspara.Currency where import Control.Monad.Except (MonadError(throwError)) diff --git a/src/Haspara/FXQuote.hs b/src/Haspara/FXQuote.hs index 316fee2..2cca680 100644 --- a/src/Haspara/FXQuote.hs +++ b/src/Haspara/FXQuote.hs @@ -1,8 +1,6 @@ -- | This module provides definitions for modeling and working with FX rates. -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} module Haspara.FXQuote where diff --git a/src/Haspara/Money.hs b/src/Haspara/Money.hs index 7824af8..c98627f 100644 --- a/src/Haspara/Money.hs +++ b/src/Haspara/Money.hs @@ -1,8 +1,7 @@ -- | This module provides definitions for modeling and working with monetary -- values. -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} module Haspara.Money where diff --git a/src/Haspara/Quantity.hs b/src/Haspara/Quantity.hs index 1e9460a..67e4aab 100644 --- a/src/Haspara/Quantity.hs +++ b/src/Haspara/Quantity.hs @@ -1,16 +1,7 @@ -- | This module provides definitions for modeling and working with quantities -- with fixed decimal points. -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} {-# OPTIONS_GHC -Wno-orphans #-} diff --git a/src/Haspara/TH.hs b/src/Haspara/TH.hs index a5b998f..5c7265b 100644 --- a/src/Haspara/TH.hs +++ b/src/Haspara/TH.hs @@ -1,8 +1,6 @@ -- | This module provides template-haskell functions for various 'Haspara.Core.Base' -- definitions. -- -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} module Haspara.TH where diff --git a/test/doctest.hs b/test/doctest.hs index cbd48bf..9c37045 100644 --- a/test/doctest.hs +++ b/test/doctest.hs @@ -1,5 +1,49 @@ -import Test.DocTest ( doctest ) +import Test.DocTest (doctest) main :: IO () -main = doctest ["-XOverloadedStrings", "-XTemplateHaskell", "-isrc", "src"] +main = doctest + [ "-XDataKinds" + , "-XOverloadedStrings" + , "-XTemplateHaskell" + -- Begin: Haskell 2021 Extensions List + , "-XBangPatterns" + , "-XBinaryLiterals" + , "-XConstrainedClassMethods" + , "-XConstraintKinds" + , "-XDeriveDataTypeable" + , "-XDeriveFoldable" + , "-XDeriveFunctor" + , "-XDeriveGeneric" + , "-XDeriveLift" + , "-XDeriveTraversable" + , "-XEmptyCase" + , "-XEmptyDataDeriving" + , "-XExistentialQuantification" + , "-XExplicitForAll" + , "-XFlexibleContexts" + , "-XFlexibleInstances" + , "-XGADTSyntax" + , "-XGeneralisedNewtypeDeriving" + , "-XHexFloatLiterals" + , "-XImportQualifiedPost" + , "-XInstanceSigs" + , "-XKindSignatures" + , "-XMultiParamTypeClasses" + , "-XNamedFieldPuns" + , "-XNamedWildCards" + , "-XNumericUnderscores" + , "-XPolyKinds" + , "-XPostfixOperators" + , "-XRankNTypes" + , "-XScopedTypeVariables" + , "-XStandaloneDeriving" + , "-XStandaloneKindSignatures" + , "-XTupleSections" + , "-XTypeApplications" + , "-XTypeOperators" + , "-XTypeSynonymInstances" + -- End: Haskell 2021 Extensions List + , "-isrc" + , "src" + ] From 0f5d8c77d847f4f8b7ced73ce7e3b98ac7d72ca8 Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Wed, 2 Mar 2022 10:54:42 +0800 Subject: [PATCH 07/14] refactor: revisit Haspara.Currency module --- src/Haspara/Currency.hs | 169 ++++++++++++++++++++++++---------------- src/Haspara/FXQuote.hs | 12 +-- src/Haspara/Money.hs | 34 ++++---- src/Haspara/TH.hs | 38 ++------- 4 files changed, 133 insertions(+), 120 deletions(-) diff --git a/src/Haspara/Currency.hs b/src/Haspara/Currency.hs index 7f30911..db3e8fe 100644 --- a/src/Haspara/Currency.hs +++ b/src/Haspara/Currency.hs @@ -1,5 +1,8 @@ -- | This module provides definitions for modeling and working with currencies. +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} + module Haspara.Currency where import Control.Monad.Except (MonadError(throwError)) @@ -8,91 +11,107 @@ import Data.Hashable (Hashable) import Data.String (IsString(..)) import qualified Data.Text as T import Data.Void (Void) +import qualified Deriving.Aeson.Stock as DAS import qualified Language.Haskell.TH.Syntax as TH import qualified Text.Megaparsec as MP --- * Data Definition --- &definition +-- * Currency +-- $currency + --- | Type encoding for currencies. +-- | Type encoding for currency symbol values with a syntax of @[A-Z]{3}[A-Z]*@. +-- +-- 'Currency' values can be constructed via 'mkCurrencyError' that works in +-- @'MonadError' 'T.Text'@ context: +-- +-- >>> mkCurrencyError "EUR" :: Either T.Text Currency +-- Right EUR +-- +-- ... or via 'mkCurrencyFail' that works in 'MonadFail' context: +-- +-- >>> mkCurrencyFail "EUR" :: Maybe Currency +-- Just EUR +-- +-- An 'IsString' instance is provided as well which is unsafe but convenient: +-- +-- >>> "EUR" :: Currency +-- EUR newtype Currency = MkCurrency { currencyCode :: T.Text } deriving (Eq, Hashable, Ord, TH.Lift) --- | 'Show' instance for 'Currency'. +-- | 'IsString' instance for 'Currency'. -- --- >>> MkCurrency "USD" +-- >>> "USD" :: Currency -- USD -instance Show Currency where - show (MkCurrency x) = T.unpack x +instance IsString Currency where + fromString = either (error . T.unpack) id . mkCurrencyError . T.pack --- | 'IsString' instance for 'Currency'. +-- | 'Show' instance for 'Currency'. -- -- >>> "USD" :: Currency -- USD -instance IsString Currency where - fromString = either error id . currency . T.pack +instance Show Currency where + show (MkCurrency x) = T.unpack x -- | 'Aeson.FromJSON' instance for 'Currency'. -- -- >>> Aeson.eitherDecode "\"\"" :: Either String Currency --- Left "Error in $: Currency code error! Expecting at least 3 uppercase characters, but received: \"\"" +-- Left "Error in $: Currency code error! Expecting at least 3 uppercase ASCII letters, but received: " +-- >>> Aeson.eitherDecode "\"A\"" :: Either String Currency +-- Left "Error in $: Currency code error! Expecting at least 3 uppercase ASCII letters, but received: A" +-- >>> Aeson.eitherDecode "\"AB\"" :: Either String Currency +-- Left "Error in $: Currency code error! Expecting at least 3 uppercase ASCII letters, but received: AB" -- >>> Aeson.eitherDecode "\"ABC\"" :: Either String Currency -- Right ABC +-- >>> Aeson.eitherDecode "\"ABCD\"" :: Either String Currency +-- Right ABCD instance Aeson.FromJSON Currency where - parseJSON = Aeson.withText "Currency" $ either fail pure . currency + parseJSON = Aeson.withText "Currency" $ either (fail . T.unpack) pure . mkCurrencyError -- | 'Aeson.ToJSON' instance for 'Currency'. -- --- >>> Aeson.encode (MkCurrency "USD") +-- >>> Aeson.encode ("USD" :: Currency) -- "\"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 +-- >>> mkCurrencyError "" :: Either T.Text Currency +-- Left "Currency code error! Expecting at least 3 uppercase ASCII letters, but received: " +-- >>> mkCurrencyError " " :: Either T.Text Currency +-- Left "Currency code error! Expecting at least 3 uppercase ASCII letters, but received: " +-- >>> mkCurrencyError "AB" :: Either T.Text Currency +-- Left "Currency code error! Expecting at least 3 uppercase ASCII letters, but received: AB" +-- >>> mkCurrencyError " ABC " :: Either T.Text Currency +-- Left "Currency code error! Expecting at least 3 uppercase ASCII letters, but received: ABC " +-- >>> mkCurrencyError "ABC" :: Either T.Text Currency -- Right ABC -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) +mkCurrencyError :: MonadError T.Text m => T.Text -> m Currency +mkCurrencyError x = either + (const . throwError $ "Currency code error! Expecting at least 3 uppercase ASCII letters, but received: " <> x) (pure . MkCurrency) (MP.runParser currencyCodeParser "Currency Code" x) -- | Smart constructor for 'Currency' values within 'MonadFail' context. -- --- >>> currencyFail "" :: Maybe Currency +-- >>> mkCurrencyFail "" :: Maybe Currency -- Nothing --- >>> currencyFail "US" :: Maybe Currency +-- >>> mkCurrencyFail "US" :: Maybe Currency -- Nothing --- >>> currencyFail "usd" :: Maybe Currency +-- >>> mkCurrencyFail "usd" :: Maybe Currency -- Nothing --- >>> currencyFail "USD" :: Maybe Currency +-- >>> mkCurrencyFail "USD" :: Maybe Currency -- Just USD -currencyFail :: MonadFail m => T.Text -> m Currency -currencyFail = either fail pure . currency - - --- * Auxiliaries --- &auxiliaries +mkCurrencyFail :: MonadFail m => T.Text -> m Currency +mkCurrencyFail = either (fail . T.unpack) pure . mkCurrencyError -- | Parser that parses currency codes. @@ -109,45 +128,63 @@ currencyFail = either fail pure . currency -- Left (ParseErrorBundle {bundleErrors = TrivialError 2 (Just EndOfInput) (fromList []) :| [], bundlePosState = PosState {pstateInput = "AB", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}}) -- >>> MP.runParser currencyCodeParser "Example" "ABC" -- Right "ABC" +-- >>> MP.runParser currencyCodeParser "Example" "ABCD" +-- Right "ABCD" +-- >>> MP.runParser currencyCodeParser "Example" " ABCD " +-- Left (ParseErrorBundle {bundleErrors = TrivialError 0 (Just (Tokens (' ' :| ""))) (fromList []) :| [], bundlePosState = PosState {pstateInput = " ABCD ", pstateOffset = 0, pstateSourcePos = SourcePos {sourceName = "Example", sourceLine = Pos 1, sourceColumn = Pos 1}, pstateTabWidth = Pos 8, pstateLinePrefix = ""}}) currencyCodeParser :: MP.Parsec Void T.Text T.Text currencyCodeParser = do - mandatory <- MP.count 3 parserChar - optionals <- MP.many parserChar + mandatory <- MP.count 3 validChar + optionals <- MP.many validChar pure . T.pack $ mandatory <> optionals where - validChars = ['A'..'Z'] - parserChar = MP.oneOf validChars + validChar = MP.oneOf ['A'..'Z'] -newtype CurrencyPair = MkCurrencyPair { unCurrencyPair :: (Currency, Currency) } - deriving (Eq, Hashable, Ord, TH.Lift) +-- * Currency Pair +-- $currencyPair --- | 'Show' instance for currency pairs. +-- | Type encoding of a currency pair. +-- +-- 'CurrencyPair' values are constructed via the data constructor: +-- +-- >>> CurrencyPair "EUR" "USD" +-- EUR/USD +-- +-- 'Aeson.FromJSON' and 'Aeson.ToJSON' instances are provided as well: +-- +-- >>> Aeson.decode "{\"base\": \"EUR\", \"quote\": \"EUR\"}" :: Maybe CurrencyPair +-- Just EUR/EUR +-- >>> Aeson.encode (CurrencyPair "EUR" "USD") +-- "{\"base\":\"EUR\",\"quote\":\"USD\"}" +data CurrencyPair = CurrencyPair + { currencyPairBase :: !Currency -- ^ /Base currency/ of the currency pair. Also referred to as /counter currency/. + , currencyPairQuote :: !Currency -- ^ /Quote currency/ of the currency pair. Also referred to as /transaction currency/. + } + deriving (Eq, DAS.Generic, Ord, TH.Lift) + deriving (DAS.FromJSON, DAS.ToJSON) via DAS.PrefixedSnake "currencyPair" CurrencyPair + + +-- | 'Show' instance for 'CurrencyPair'. -- --- >>> MkCurrencyPair ("EUR", "USD") +-- >>> CurrencyPair "EUR" "USD" -- EUR/USD instance Show CurrencyPair where - show (MkCurrencyPair (x, y)) = show x <> "/" <> show y + show (CurrencyPair 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)) +-- | Converts a 'CurrencyPair' to a 2-tuple of 'Currency' values. +-- +-- >>> toCurrencyTuple (CurrencyPair "EUR" "USD") +-- (EUR,USD) +toCurrencyTuple :: CurrencyPair -> (Currency, Currency) +toCurrencyTuple (CurrencyPair x y) = (x, y) -currencyPairFail :: MonadFail m => Currency -> Currency -> m CurrencyPair -currencyPairFail = (either fail pure .) . currencyPair +-- | Converts a 2-tuple of 'Currency' values to a 'CurrencyPair'. +-- +-- >>> fromCurrencyTuple ("EUR", "USD") +-- EUR/USD +fromCurrencyTuple :: (Currency, Currency) -> CurrencyPair +fromCurrencyTuple = uncurry CurrencyPair diff --git a/src/Haspara/FXQuote.hs b/src/Haspara/FXQuote.hs index 2cca680..c5882f6 100644 --- a/src/Haspara/FXQuote.hs +++ b/src/Haspara/FXQuote.hs @@ -11,7 +11,7 @@ import qualified Data.Map.Strict as SM import Data.Scientific (Scientific) import Data.Time (Day, addDays) import GHC.TypeLits (KnownNat, Nat) -import Haspara.Currency (Currency, CurrencyPair, baseCurrency, currencyPair, quoteCurrency) +import Haspara.Currency (Currency, CurrencyPair(CurrencyPair, currencyPairBase, currencyPairQuote)) import Haspara.Quantity (Quantity(..), quantity) import Numeric.Decimal (toScientificDecimal) import Refined (Positive, Refined, refineError, unrefine) @@ -52,8 +52,8 @@ instance (KnownNat s) => Show (FXQuote s) where -- 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\": \"USD\", \"rate\": 1}" :: Either String (FXQuote 2) +-- Right ("USD/USD","2021-01-01","1.00") -- >>> 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 @@ -73,8 +73,8 @@ instance (KnownNat s) => Aeson.FromJSON (FXQuote s) where instance (KnownNat s) => Aeson.ToJSON (FXQuote s) where toJSON (MkFXQuote d cp v) = Aeson.object [ "date" .= d - , "ccy1" .= baseCurrency cp - , "ccy2" .= quoteCurrency cp + , "ccy1" .= currencyPairBase cp + , "ccy2" .= currencyPairQuote cp , "rate" .= (toScientificDecimal . unQuantity . unrefine) v ] @@ -92,7 +92,7 @@ fxquote -> 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 + let pair = CurrencyPair c1 c2 pval <- either (Left . show) pure $ refineError (quantity v) pure $ MkFXQuote d pair pval diff --git a/src/Haspara/Money.hs b/src/Haspara/Money.hs index c98627f..6507dfa 100644 --- a/src/Haspara/Money.hs +++ b/src/Haspara/Money.hs @@ -5,16 +5,16 @@ module Haspara.Money where -import Control.Applicative ((<|>)) -import Data.Aeson ((.:), (.=)) -import qualified Data.Aeson as Aeson -import Data.Scientific (Scientific) -import Data.Time (Day) -import GHC.TypeLits (KnownNat, Nat) -import Haspara.Currency (Currency, baseCurrency, quoteCurrency) -import Haspara.FXQuote (FXQuote(fxQuotePair, fxQuoteRate)) -import Haspara.Quantity (Quantity, quantity, times) -import Refined (unrefine) +import Control.Applicative ((<|>)) +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson +import Data.Scientific (Scientific) +import Data.Time (Day) +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Currency (Currency, CurrencyPair(currencyPairBase, currencyPairQuote)) +import Haspara.FXQuote (FXQuote(fxQuotePair, fxQuoteRate)) +import Haspara.Quantity (Quantity, quantity, times) +import Refined (unrefine) data Money (s :: Nat) = @@ -89,15 +89,13 @@ moneyQuantity (MoneyFail _) = Nothing -- rate. -- -- >>> import Haspara --- >>> let eur = either error id $ currency "EUR" --- >>> let usd = either error id $ currency "USD" -- >>> let date = read "2021-01-01" :: Day --- >>> let eurmoney = mkMoney date eur (quantity 0.42 :: Quantity 2) :: Money 2 --- >>> convert eurmoney eur (quantity 1 :: Quantity 4) +-- >>> 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) +-- >>> convert eurmoney "USD" (quantity 1 :: Quantity 4) -- MoneySome 2021-01-01 USD 0.42 --- >>> convert eurmoney usd (quantity 1.1516 :: Quantity 4) +-- >>> 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 @@ -114,5 +112,5 @@ 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) + | cbase /= currencyPairBase (fxQuotePair quote) = MoneyFail $ "Attempting to convert with incompatible base currency: " <> show x <> " with " <> show quote + | otherwise = convert x (currencyPairQuote (fxQuotePair quote)) (unrefine $ fxQuoteRate quote) diff --git a/src/Haspara/TH.hs b/src/Haspara/TH.hs index 5c7265b..918731b 100644 --- a/src/Haspara/TH.hs +++ b/src/Haspara/TH.hs @@ -1,22 +1,19 @@ -- | This module provides template-haskell functions for various 'Haspara.Core.Base' -- definitions. --- 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.Currency (Currency, CurrencyPair(CurrencyPair), mkCurrencyError) 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 @@ -42,10 +39,10 @@ quantityTH = fix $ \loop -> fmap TH.TExp . either (fail . show) TH.lift . quanti -- USD -- >>> $$(currencyTH "usd") -- ... --- ...Currency code error! Expecting at least 3 uppercase characters, but received: "usd" +-- ...Currency code error! Expecting at least 3 uppercase ASCII letters, but received: usd -- ... currencyTH :: T.Text -> TH.Q (TH.TExp Currency) -currencyTH = either fail (fmap TH.TExp . TH.lift) . currency +currencyTH = either (fail . T.unpack) (fmap TH.TExp . TH.lift) . mkCurrencyError -- | Constructs a 'CurrencyPair' value at compile-time using @-XTemplateHaskell@. @@ -53,32 +50,13 @@ currencyTH = either fail (fmap TH.TExp . TH.lift) . currency -- >>> $$(currencyPairTH "EUR" "USD") -- EUR/USD -- >>> $$(currencyPairTH "USD" "USD") --- ... --- ...Can not create currency pair from same currencies: USD and USD --- ... +-- USD/USD -- >>> $$(currencyPairTH "USD" "eur") -- ... --- ...Currency code error! Expecting at least 3 uppercase characters, but received: "eur" +-- ...Currency code error! Expecting at least 3 uppercase ASCII letters, but received: eur -- ... currencyPairTH :: T.Text -> T.Text -> TH.Q (TH.TExp CurrencyPair) -currencyPairTH = (either fail (fmap TH.TExp . TH.lift) .) . mkPair +currencyPairTH = (either (fail . T.unpack) (fmap TH.TExp . TH.lift) .) . mkPair where - mkPair :: T.Text -> T.Text -> Either String CurrencyPair - mkPair x y = join $ currencyPair <$> currency x <*> currency y - - --- -- | Constructs an 'FXQuote' value at compile-time using @-XTemplateHaskell@. --- -- --- -- >>> :set -XDataKinds --- -- >>> $$(fxquoteTH (read "2021-01-01") "EUR" "USD" 10) :: FXQuote 2 --- -- ("EUR/USD","2021-01-01","10.00") --- fxquoteTH :: KnownNat s => Date -> T.Text -> T.Text -> Scientific -> TH.Q (TH.TExp (FXQuote s)) --- fxquoteTH d c1 c2 = fix $ \loop -> fmap TH.TExp . either (fail . show) TH.lift . fxquoteWE (loop undefined) --- where --- -- This provides a work-around for the type-inference due the `s` type parameter. --- -- Trick is borrowed from the Haskell `refined` library. --- fxquoteWE :: KnownNat s => TH.Q (TH.TExp (FXQuote s)) -> Scientific -> Either String (FXQuote s) --- fxquoteWE _ v = do --- xc1 <- currency c1 --- xc2 <- currency c2 --- either (Left . show) Right $ fxquote d xc1 xc2 v + mkPair :: T.Text -> T.Text -> Either T.Text CurrencyPair + mkPair x y = CurrencyPair <$> mkCurrencyError x <*> mkCurrencyError y From ff00f5c629b57057709faabd84063556d056eb9c Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Wed, 2 Mar 2022 11:23:05 +0800 Subject: [PATCH 08/14] refactor: revisit Haspara.Quantity module --- src/Haspara/FXQuote.hs | 4 +- src/Haspara/Money.hs | 12 +-- src/Haspara/Quantity.hs | 193 +++++++++++++++++++++------------------- src/Haspara/TH.hs | 4 +- 4 files changed, 113 insertions(+), 100 deletions(-) diff --git a/src/Haspara/FXQuote.hs b/src/Haspara/FXQuote.hs index c5882f6..c878d1c 100644 --- a/src/Haspara/FXQuote.hs +++ b/src/Haspara/FXQuote.hs @@ -12,7 +12,7 @@ import Data.Scientific (Scientific) import Data.Time (Day, addDays) import GHC.TypeLits (KnownNat, Nat) import Haspara.Currency (Currency, CurrencyPair(CurrencyPair, currencyPairBase, currencyPairQuote)) -import Haspara.Quantity (Quantity(..), quantity) +import Haspara.Quantity (Quantity(..), mkQuantity) import Numeric.Decimal (toScientificDecimal) import Refined (Positive, Refined, refineError, unrefine) @@ -93,7 +93,7 @@ fxquote -> m (FXQuote s) fxquote d c1 c2 v = either (throwError . (<>) "Can not create FX Rate. Error was: ") pure $ do let pair = CurrencyPair c1 c2 - pval <- either (Left . show) pure $ refineError (quantity v) + pval <- either (Left . show) pure $ refineError (mkQuantity v) pure $ MkFXQuote d pair pval diff --git a/src/Haspara/Money.hs b/src/Haspara/Money.hs index 6507dfa..675f172 100644 --- a/src/Haspara/Money.hs +++ b/src/Haspara/Money.hs @@ -13,7 +13,7 @@ import Data.Time (Day) import GHC.TypeLits (KnownNat, Nat) import Haspara.Currency (Currency, CurrencyPair(currencyPairBase, currencyPairQuote)) import Haspara.FXQuote (FXQuote(fxQuotePair, fxQuoteRate)) -import Haspara.Quantity (Quantity, quantity, times) +import Haspara.Quantity (Quantity, mkQuantity, times) import Refined (unrefine) @@ -64,7 +64,7 @@ mkMoney = MoneySome mkMoneyFromScientific :: KnownNat s => Day -> Currency -> Scientific -> Money s -mkMoneyFromScientific d c s = mkMoney d c (quantity s) +mkMoneyFromScientific d c s = mkMoney d c (mkQuantity s) moneyDate :: KnownNat s => Money s -> Maybe Day @@ -90,12 +90,12 @@ moneyQuantity (MoneyFail _) = Nothing -- -- >>> import Haspara -- >>> let date = read "2021-01-01" :: Day --- >>> let eurmoney = mkMoney date "EUR" (quantity 0.42 :: Quantity 2) :: Money 2 --- >>> convert eurmoney "EUR" (quantity 1 :: Quantity 4) +-- >>> let eurmoney = mkMoney date "EUR" (mkQuantity 0.42 :: Quantity 2) :: Money 2 +-- >>> convert eurmoney "EUR" (mkQuantity 1 :: Quantity 4) -- MoneySome 2021-01-01 EUR 0.42 --- >>> convert eurmoney "USD" (quantity 1 :: Quantity 4) +-- >>> convert eurmoney "USD" (mkQuantity 1 :: Quantity 4) -- MoneySome 2021-01-01 USD 0.42 --- >>> convert eurmoney "USD" (quantity 1.1516 :: Quantity 4) +-- >>> convert eurmoney "USD" (mkQuantity 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 diff --git a/src/Haspara/Quantity.hs b/src/Haspara/Quantity.hs index 67e4aab..65ade72 100644 --- a/src/Haspara/Quantity.hs +++ b/src/Haspara/Quantity.hs @@ -12,19 +12,19 @@ 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 Data.Scientific (FPFormat(Fixed), Scientific, formatScientific) import GHC.Generics (Generic) import GHC.TypeLits (KnownNat, Nat, natVal, type (+)) import qualified Language.Haskell.TH.Syntax as TH import qualified Numeric.Decimal as D --- $setup --- >>> :set -XDataKinds +-- * Data Definition +-- $dataDefinition --- | Type encoding for common quantity values with given scaling (digits after --- the decimal point). +-- | Type encoding for quantity values with a given scaling (digits after the +-- decimal point). -- -- >>> 42 :: Quantity 0 -- 42 @@ -46,13 +46,13 @@ import qualified Numeric.Decimal as D -- -1.00 -- >>> fromInteger 42 :: Quantity 2 -- 42.00 --- >>> quantity 0.415 :: Quantity 2 +-- >>> mkQuantity 0.415 :: Quantity 2 -- 0.42 --- >>> quantity 0.425 :: Quantity 2 +-- >>> mkQuantity 0.425 :: Quantity 2 -- 0.42 --- >>> quantityLossless 0.42 :: Either String (Quantity 2) +-- >>> mkQuantityLossless 0.42 :: Either String (Quantity 2) -- Right 0.42 --- >>> quantityLossless 0.415 :: Either String (Quantity 2) +-- >>> mkQuantityLossless 0.415 :: Either String (Quantity 2) -- Left "Underflow while trying to create quantity: 0.415" newtype Quantity (s :: Nat) = MkQuantity { unQuantity :: D.Decimal D.RoundHalfEven s Integer } deriving (Eq, Ord, Generic, Num) @@ -77,12 +77,12 @@ deriving instance TH.Lift (Quantity s) -- >>> Aeson.decode "0.425" :: Maybe (Quantity 2) -- Just 0.42 instance (KnownNat s) => Aeson.FromJSON (Quantity s) where - parseJSON = Aeson.withScientific "Quantity" (pure . quantity) + parseJSON = Aeson.withScientific "Quantity" (pure . mkQuantity) -- | 'Aeson.ToJSON' instance for 'Quantity'. -- --- >>> Aeson.encode (quantity 0.42 :: Quantity 2) +-- >>> Aeson.encode (mkQuantity 0.42 :: Quantity 2) -- "0.42" instance (KnownNat s) => Aeson.ToJSON (Quantity s) where toJSON = Aeson.Number . D.toScientificDecimal . unQuantity @@ -91,7 +91,7 @@ instance (KnownNat s) => Aeson.ToJSON (Quantity s) where -- | Numeric arithmetic over 'Quantity' values. -- -- >>> import Numeric.Decimal --- >>> let a = Arith (quantity 10) + Arith (quantity 32) :: Arith (Quantity 2) +-- >>> let a = Arith (mkQuantity 10) + Arith (mkQuantity 32) :: Arith (Quantity 2) -- >>> arithMaybe a -- Just 42.00 -- >>> arithM (41 + 1) :: Either SomeException (Quantity 2) @@ -152,133 +152,123 @@ instance KnownNat s => Show (Quantity s) where show = show . unQuantity --- | Constructs 'Quantity' values from 'S.Scientific' values in a lossy way. +-- * Smart Constructors +-- $smartConstructors + + +-- | Constructs 'Quantity' values from '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. +-- This function uses 'mkQuantityAux' in case that the lossless attempt fails. +-- We could have used 'mkQuantityAux' directly. However, 'mkQuantityAux' is +-- doing too much (see 'roundScientific'). Therefore, we are first attempting a +-- lossless construction (see 'mkQuantityLossless') and we fallback to +-- 'mkQuantityAux' in case the lossless construction fails. -- --- >>> quantity 0 :: Quantity 0 +-- >>> mkQuantity 0 :: Quantity 0 -- 0 --- >>> quantity 0 :: Quantity 1 +-- >>> mkQuantity 0 :: Quantity 1 -- 0.0 --- >>> quantity 0 :: Quantity 2 +-- >>> mkQuantity 0 :: Quantity 2 -- 0.00 --- >>> quantity 0.04 :: Quantity 1 +-- >>> mkQuantity 0.04 :: Quantity 1 -- 0.0 --- >>> quantity 0.05 :: Quantity 1 +-- >>> mkQuantity 0.05 :: Quantity 1 -- 0.0 --- >>> quantity 0.06 :: Quantity 1 +-- >>> mkQuantity 0.06 :: Quantity 1 -- 0.1 --- >>> quantity 0.14 :: Quantity 1 +-- >>> mkQuantity 0.14 :: Quantity 1 -- 0.1 --- >>> quantity 0.15 :: Quantity 1 +-- >>> mkQuantity 0.15 :: Quantity 1 -- 0.2 --- >>> quantity 0.16 :: Quantity 1 +-- >>> mkQuantity 0.16 :: Quantity 1 -- 0.2 --- >>> quantity 0.04 :: Quantity 2 +-- >>> mkQuantity 0.04 :: Quantity 2 -- 0.04 --- >>> quantity 0.05 :: Quantity 2 +-- >>> mkQuantity 0.05 :: Quantity 2 -- 0.05 --- >>> quantity 0.06 :: Quantity 2 +-- >>> mkQuantity 0.06 :: Quantity 2 -- 0.06 --- >>> quantity 0.14 :: Quantity 2 +-- >>> mkQuantity 0.14 :: Quantity 2 -- 0.14 --- >>> quantity 0.15 :: Quantity 2 +-- >>> mkQuantity 0.15 :: Quantity 2 -- 0.15 --- >>> quantity 0.16 :: Quantity 2 +-- >>> mkQuantity 0.16 :: Quantity 2 -- 0.16 --- >>> quantity 0.04 :: Quantity 3 +-- >>> mkQuantity 0.04 :: Quantity 3 -- 0.040 --- >>> quantity 0.05 :: Quantity 3 +-- >>> mkQuantity 0.05 :: Quantity 3 -- 0.050 --- >>> quantity 0.06 :: Quantity 3 +-- >>> mkQuantity 0.06 :: Quantity 3 -- 0.060 --- >>> quantity 0.14 :: Quantity 3 +-- >>> mkQuantity 0.14 :: Quantity 3 -- 0.140 --- >>> quantity 0.15 :: Quantity 3 +-- >>> mkQuantity 0.15 :: Quantity 3 -- 0.150 --- >>> quantity 0.16 :: Quantity 3 +-- >>> mkQuantity 0.16 :: Quantity 3 -- 0.160 -quantity :: KnownNat s => S.Scientific -> Quantity s -quantity s = case quantityLossless s of - Left _ -> quantityAux s +mkQuantity :: KnownNat s => Scientific -> Quantity s +mkQuantity s = case mkQuantityLossless s of + Left _ -> mkQuantityAux 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. +-- | Constructs 'Quantity' values from 'Scientific' values in a lossy way. -- --- >>> quantityLossless 0 :: Either String (Quantity 0) +-- >>> mkQuantityLossless 0 :: Either String (Quantity 0) -- Right 0 --- >>> quantityLossless 0 :: Either String (Quantity 1) +-- >>> mkQuantityLossless 0 :: Either String (Quantity 1) -- Right 0.0 --- >>> quantityLossless 0 :: Either String (Quantity 2) +-- >>> mkQuantityLossless 0 :: Either String (Quantity 2) -- Right 0.00 --- >>> quantityLossless 0.04 :: Either String (Quantity 1) +-- >>> mkQuantityLossless 0.04 :: Either String (Quantity 1) -- Left "Underflow while trying to create quantity: 4.0e-2" --- >>> quantityLossless 0.05 :: Either String (Quantity 1) +-- >>> mkQuantityLossless 0.05 :: Either String (Quantity 1) -- Left "Underflow while trying to create quantity: 5.0e-2" --- >>> quantityLossless 0.06 :: Either String (Quantity 1) +-- >>> mkQuantityLossless 0.06 :: Either String (Quantity 1) -- Left "Underflow while trying to create quantity: 6.0e-2" --- >>> quantityLossless 0.14 :: Either String (Quantity 1) +-- >>> mkQuantityLossless 0.14 :: Either String (Quantity 1) -- Left "Underflow while trying to create quantity: 0.14" --- >>> quantityLossless 0.15 :: Either String (Quantity 1) +-- >>> mkQuantityLossless 0.15 :: Either String (Quantity 1) -- Left "Underflow while trying to create quantity: 0.15" --- >>> quantityLossless 0.16 :: Either String (Quantity 1) +-- >>> mkQuantityLossless 0.16 :: Either String (Quantity 1) -- Left "Underflow while trying to create quantity: 0.16" --- >>> quantityLossless 0.04 :: Either String (Quantity 2) +-- >>> mkQuantityLossless 0.04 :: Either String (Quantity 2) -- Right 0.04 --- >>> quantityLossless 0.05 :: Either String (Quantity 2) +-- >>> mkQuantityLossless 0.05 :: Either String (Quantity 2) -- Right 0.05 --- >>> quantityLossless 0.06 :: Either String (Quantity 2) +-- >>> mkQuantityLossless 0.06 :: Either String (Quantity 2) -- Right 0.06 --- >>> quantityLossless 0.14 :: Either String (Quantity 2) +-- >>> mkQuantityLossless 0.14 :: Either String (Quantity 2) -- Right 0.14 --- >>> quantityLossless 0.15 :: Either String (Quantity 2) +-- >>> mkQuantityLossless 0.15 :: Either String (Quantity 2) -- Right 0.15 --- >>> quantityLossless 0.16 :: Either String (Quantity 2) +-- >>> mkQuantityLossless 0.16 :: Either String (Quantity 2) -- Right 0.16 --- >>> quantityLossless 0.04 :: Either String (Quantity 3) +-- >>> mkQuantityLossless 0.04 :: Either String (Quantity 3) -- Right 0.040 --- >>> quantityLossless 0.05 :: Either String (Quantity 3) +-- >>> mkQuantityLossless 0.05 :: Either String (Quantity 3) -- Right 0.050 --- >>> quantityLossless 0.06 :: Either String (Quantity 3) +-- >>> mkQuantityLossless 0.06 :: Either String (Quantity 3) -- Right 0.060 --- >>> quantityLossless 0.14 :: Either String (Quantity 3) +-- >>> mkQuantityLossless 0.14 :: Either String (Quantity 3) -- Right 0.140 --- >>> quantityLossless 0.15 :: Either String (Quantity 3) +-- >>> mkQuantityLossless 0.15 :: Either String (Quantity 3) -- Right 0.150 --- >>> quantityLossless 0.16 :: Either String (Quantity 3) +-- >>> mkQuantityLossless 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 +mkQuantityLossless :: (KnownNat s, MonadError String m) => Scientific -> m (Quantity s) +mkQuantityLossless s = either (const $ throwError ("Underflow while trying to create quantity: " <> show s)) (pure . MkQuantity) $ D.fromScientificDecimal s + + +-- * Utilities +-- $utilities -- | Rounds given quantity by @k@ digits. -- --- >>> roundQuantity (quantity 0.415 :: Quantity 3) :: Quantity 2 +-- >>> roundQuantity (mkQuantity 0.415 :: Quantity 3) :: Quantity 2 -- 0.42 --- >>> roundQuantity (quantity 0.425 :: Quantity 3) :: Quantity 2 +-- >>> roundQuantity (mkQuantity 0.425 :: Quantity 3) :: Quantity 2 -- 0.42 roundQuantity :: KnownNat k => Quantity (n + k) -> Quantity n roundQuantity (MkQuantity d) = MkQuantity (D.roundDecimal d) @@ -286,7 +276,7 @@ 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) +-- >>> times (mkQuantity 0.42 :: Quantity 2) (mkQuantity 0.42 :: Quantity 2) -- 0.18 times :: (KnownNat s, KnownNat k) => Quantity s -> Quantity k -> Quantity s times q1 q2 = roundQuantity (timesLossless q1 q2) @@ -294,12 +284,35 @@ times q1 q2 = roundQuantity (timesLossless q1 q2) -- | Multiplies two quantities with different scales. -- --- >>> timesLossless (quantity 0.42 :: Quantity 2) (quantity 0.42 :: Quantity 2) +-- >>> timesLossless (mkQuantity 0.42 :: Quantity 2) (mkQuantity 0.42 :: Quantity 2) -- 0.1764 timesLossless :: (KnownNat s, KnownNat k) => Quantity s -> Quantity k -> Quantity (s + k) timesLossless (MkQuantity d1) (MkQuantity d2) = MkQuantity (D.timesDecimal d1 d2) +-- * Internal +-- $internal + + +-- | Auxiliary function for constructing 'Quantity' values. +-- +-- See 'mkQuantity' why we need this function and why we haven't used it as the +-- direct implementation of 'mkQuantity'. +-- +-- Call-sites should avoid using this function directly due to its performance +-- characteristics. +mkQuantityAux :: forall s. KnownNat s => Scientific -> Quantity s +mkQuantityAux x = fromRight err $ mkQuantityLossless (roundScientific nof x) + where + -- Get the term-level scaling for the target value: + nof = fromIntegral $ natVal (Proxy :: Proxy s) + + -- This function should NOT fail in practice ever, but it can fail due to + -- type signatures by right. We will let it error with a message for + -- ourselves: + err = error $ "PROGRAMMING ERROR: Can not construct 'Quantity " <> show nof <> "' with '" <> show x <> "' in a lossy way." + + -- | Rounds a given scientific into a new scientific with given max digits after -- decimal point. -- @@ -355,5 +368,5 @@ timesLossless (MkQuantity d1) (MkQuantity d2) = MkQuantity (D.timesDecimal d1 d2 -- -3.8 -- -- TODO: Refactor to improve the performance of this function. -roundScientific :: Int -> S.Scientific -> S.Scientific -roundScientific = (read .) . S.formatScientific S.Fixed . Just +roundScientific :: Int -> Scientific -> Scientific +roundScientific = (read .) . formatScientific Fixed . Just diff --git a/src/Haspara/TH.hs b/src/Haspara/TH.hs index 918731b..67bac94 100644 --- a/src/Haspara/TH.hs +++ b/src/Haspara/TH.hs @@ -8,7 +8,7 @@ import Data.Scientific (Scientific) import qualified Data.Text as T import GHC.TypeLits (KnownNat) import Haspara.Currency (Currency, CurrencyPair(CurrencyPair), mkCurrencyError) -import Haspara.Quantity (Quantity, quantityLossless) +import Haspara.Quantity (Quantity, mkQuantityLossless) import qualified Language.Haskell.TH.Syntax as TH @@ -30,7 +30,7 @@ quantityTH = fix $ \loop -> fmap TH.TExp . either (fail . show) TH.lift . quanti -- This provides a work-around for the type-inference due the `s` type parameter. -- Trick is borrowed from the Haskell `refined` library. quantityWE :: KnownNat s => TH.Q (TH.TExp (Quantity s)) -> Scientific -> Either String (Quantity s) - quantityWE = const quantityLossless + quantityWE = const mkQuantityLossless -- | Constructs a 'Currency' value at compile-time using @-XTemplateHaskell@. From 64c1d917206e59861c7d4434511d7aa8ba26eebf Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Wed, 2 Mar 2022 11:59:51 +0800 Subject: [PATCH 09/14] refactor: revisit Haspara.FxQuote module --- haspara.cabal | 2 +- src/Haspara.hs | 4 +- src/Haspara/FXQuote.hs | 144 ----------------------------------------- src/Haspara/FxQuote.hs | 142 ++++++++++++++++++++++++++++++++++++++++ src/Haspara/Money.hs | 6 +- 5 files changed, 148 insertions(+), 150 deletions(-) delete mode 100644 src/Haspara/FXQuote.hs create mode 100644 src/Haspara/FxQuote.hs diff --git a/haspara.cabal b/haspara.cabal index ad43bc5..b86fd90 100644 --- a/haspara.cabal +++ b/haspara.cabal @@ -37,7 +37,7 @@ library Haspara.Accounting.Posting Haspara.Accounting.Types Haspara.Currency - Haspara.FXQuote + Haspara.FxQuote Haspara.Money Haspara.Quantity Haspara.TH diff --git a/src/Haspara.hs b/src/Haspara.hs index cc73f18..cb3cd17 100644 --- a/src/Haspara.hs +++ b/src/Haspara.hs @@ -1,11 +1,11 @@ module Haspara ( module Haspara.Currency - , module Haspara.FXQuote + , module Haspara.FxQuote , module Haspara.Money , module Haspara.Quantity ) where import Haspara.Currency -import Haspara.FXQuote +import Haspara.FxQuote import Haspara.Money import Haspara.Quantity diff --git a/src/Haspara/FXQuote.hs b/src/Haspara/FXQuote.hs deleted file mode 100644 index c878d1c..0000000 --- a/src/Haspara/FXQuote.hs +++ /dev/null @@ -1,144 +0,0 @@ --- | This module provides definitions for modeling and working with FX rates. - -{-# LANGUAGE DataKinds #-} - -module Haspara.FXQuote where - -import Control.Monad.Except (MonadError(throwError), join) -import Data.Aeson ((.:), (.=)) -import qualified Data.Aeson as Aeson -import qualified Data.Map.Strict as SM -import Data.Scientific (Scientific) -import Data.Time (Day, addDays) -import GHC.TypeLits (KnownNat, Nat) -import Haspara.Currency (Currency, CurrencyPair(CurrencyPair, currencyPairBase, currencyPairQuote)) -import Haspara.Quantity (Quantity(..), mkQuantity) -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 :: !Day - -- | 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}" :: Either String (FXQuote 2) --- Right ("USD/USD","2021-01-01","1.00") --- >>> 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 --- "{\"rate\":1.35,\"ccy2\":\"SGD\",\"date\":\"2021-01-01\",\"ccy1\":\"USD\"}" -instance (KnownNat s) => Aeson.ToJSON (FXQuote s) where - toJSON (MkFXQuote d cp v) = Aeson.object - [ "date" .= d - , "ccy1" .= currencyPairBase cp - , "ccy2" .= currencyPairQuote cp - , "rate" .= (toScientificDecimal . unQuantity . unrefine) v - ] - - --- * Constructors --- &constructors - - --- | Smart constructor for 'FXQuote' values within 'MonadError' context. -fxquote - :: (KnownNat s, MonadError String m) - => Day -- ^ 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 - let pair = CurrencyPair c1 c2 - pval <- either (Left . show) pure $ refineError (mkQuantity v) - pure $ MkFXQuote d pair pval - - --- | Smart constructor for 'FXQuote' values within 'MonadFail' context. -fxquoteFail - :: (KnownNat s, MonadFail m) - => Day -- ^ 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 - => Day -- ^ 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 - - -type FXQuoteDatabase (n :: Nat) = SM.Map CurrencyPair (FXQuotePairDatabase n) - - -data FXQuotePairDatabase (n :: Nat) = FXQuotePairDatabase - { fxQuotePairDatabasePair :: !CurrencyPair - , fxQuotePairDatabaseTable :: !(SM.Map Day (FXQuote n)) - , fxQuotePairDatabaseSince :: !Day - , fxQuotePairDatabaseUntil :: !Day - } - - -findFXQuote :: KnownNat n => FXQuoteDatabase n -> CurrencyPair -> Day -> Maybe (FXQuote n) -findFXQuote db cp d = case SM.lookup cp db of - Nothing -> Nothing - Just pdb -> findFXQuoteAux d pdb - - -findFXQuoteAux :: KnownNat n => Day -> FXQuotePairDatabase n -> Maybe (FXQuote n) -findFXQuoteAux d db - | d < fxQuotePairDatabaseSince db = Nothing - | otherwise = case SM.lookup d (fxQuotePairDatabaseTable db) of - Nothing -> findFXQuoteAux (addDays (-1) d) db - Just fx -> Just fx diff --git a/src/Haspara/FxQuote.hs b/src/Haspara/FxQuote.hs new file mode 100644 index 0000000..453dc6c --- /dev/null +++ b/src/Haspara/FxQuote.hs @@ -0,0 +1,142 @@ +-- | This module provides definitions for modeling and working with foreign +-- exchange (FX) rate quotations. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} + +module Haspara.FxQuote where + +import Control.Monad.Except (MonadError(throwError)) +import qualified Data.Map.Strict as SM +import Data.Scientific (Scientific) +import qualified Data.Text as T +import Data.Time (Day, addDays) +import qualified Deriving.Aeson.Stock as DAS +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Currency (Currency, CurrencyPair(CurrencyPair)) +import Haspara.Quantity (Quantity(..), mkQuantity) +import Refined (Positive, Refined, refineError) + + +-- * FX Rate Quotation +-- $fxRateQuotation + + +-- | Type encoding for FX rate quotations with fixed precision. +-- +-- An FX rate quotation is a 3-tuple of: +-- +-- 1. a currency pair the rate is quoted for, and +-- 2. a date that the quotation is effective as of, +-- 3. a (positive) rate as the value of the quotation. +-- +-- >>> +data FxQuote (s :: Nat) = MkFXQuote + { fxQuotePair :: !CurrencyPair -- ^ Currency pair of the FX rate. + , fxQuoteDate :: !Day -- ^ Actual date of the FX rate. + , fxQuoteRate :: !(Refined Positive (Quantity s)) -- ^ (Positive) rate value of the FX rate. + } + deriving (Eq, DAS.Generic, Ord, Show) + deriving (DAS.FromJSON, DAS.ToJSON) via DAS.PrefixedSnake "fxQuote" (FxQuote s) + + +-- | Smart constructor for 'FxQuote' values within @'MonadError' 'T.Text'@ +-- context. +-- +-- The rate is expected to be a positive value. If it is not, the function will +-- throw an error. +-- +-- >>> mkFxQuoteError @(Either _) @2 (read "2021-12-31") "EUR" "USD" 1.16 +-- Right (MkFXQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16}) +-- >>> mkFxQuoteError @(Either _) @2 (read "2021-12-31") "EUR" "USD" (-1.16) +-- Left "Can not create FX Rate. Error was: The predicate (GreaterThan 0) failed with the message: Value is not greater than 0\n" +mkFxQuoteError + :: MonadError T.Text m + => KnownNat s + => Day -- ^ Date of the FX quotation. + -> Currency -- ^ Base currency (from) of the FX quotation. + -> Currency -- ^ Quote currency (to) of the FX quotation. + -> Scientific -- ^ FX quotation rate, expected to be positive. + -> m (FxQuote s) +mkFxQuoteError date ccy1 ccy2 rate = + either (throwError . (<>) "Can not create FX Rate. Error was: ") pure $ do + pval <- either (Left . T.pack . show) pure $ refineError (mkQuantity rate) + pure $ MkFXQuote (CurrencyPair ccy1 ccy2) date pval + + +-- | Smart constructor for 'FxQuote' values within 'MonadFail' context. +-- +-- The rate is expected to be a positive value. If it is not, the function will +-- fail. +-- >>> mkFxQuoteFail @Maybe @2 (read "2021-12-31") "EUR" "USD" 1.16 +-- Just (MkFXQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16}) +-- >>> mkFxQuoteFail @Maybe @2 (read "2021-12-31") "EUR" "USD" (-1.16) +-- Nothing +mkFxQuoteFail + :: MonadFail m + => KnownNat s + => Day -- ^ Date of the FX quotation. + -> Currency -- ^ Base currency (from) of the FX quotation. + -> Currency -- ^ Quote currency (to) of the FX quotation. + -> Scientific -- ^ FX quotation rate, expected to be positive. + -> m (FxQuote s) +mkFxQuoteFail date ccy1 ccy2 = + either (fail . T.unpack) pure . mkFxQuoteError date ccy1 ccy2 + + +-- | Unsafe 'FxQuote' constructor that 'error's if it fails. +-- +-- >>> mkFxQuoteUnsafe @2 (read "2021-12-31") "EUR" "USD" 1.16 +-- MkFXQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16} +-- >>> mkFxQuoteUnsafe @2 (read "2021-12-31") "EUR" "USD" (-1.16) +-- ... +-- ...Can not create FX Rate. Error was: The predicate (GreaterThan 0) failed with the message: Value is not greater than 0 +-- ... +mkFxQuoteUnsafe + :: KnownNat s + => Day -- ^ Date of the FX quotation. + -> Currency -- ^ Base currency (from) of the FX quotation. + -> Currency -- ^ Quote currency (to) of the FX quotation. + -> Scientific -- ^ FX quotation rate, expected to be positive. + -> FxQuote s +mkFxQuoteUnsafe date ccy1 ccy2 = + either (error . T.unpack) id . mkFxQuoteError date ccy1 ccy2 + + +-- * FX Rate Quotation Database +-- $fxRateQuotationDatabase + + +-- | Type encoding for a dictionary-based FX rate quotation database for various +-- 'CurrencyPair' values. +type FxQuoteDatabase (n :: Nat) = SM.Map CurrencyPair (FxQuotePairDatabase n) + + +-- | Type encoding for FX rate quotation database for a 'CurrencyPair'. +data FxQuotePairDatabase (n :: Nat) = FxQuotePairDatabase + { fxQuotePairDatabasePair :: !CurrencyPair + , fxQuotePairDatabaseTable :: !(SM.Map Day (FxQuote n)) + , fxQuotePairDatabaseSince :: !Day + , fxQuotePairDatabaseUntil :: !Day + } + + +-- | Attempts to find and return the FX quotation for a given 'CurrencyPair' as +-- of a give 'Day' in a given 'FxQuoteDatabase'. +findFxQuote + :: KnownNat n + => FxQuoteDatabase n -- ^ FX quotation database to perform the lookup on. + -> CurrencyPair -- ^ Currency pair we are looking for the quotation for. + -> Day -- ^ Date the quotation we look for is valid as of. + -> Maybe (FxQuote n) +findFxQuote db pair date = SM.lookup pair db >>= findFxQuoteAux date + + +-- | Attempts to find and return the FX quotation as of a give 'Day' in a given +-- 'FxQuotePairDatabase'. +findFxQuoteAux :: KnownNat n => Day -> FxQuotePairDatabase n -> Maybe (FxQuote n) +findFxQuoteAux date db + | date < fxQuotePairDatabaseSince db = Nothing + | otherwise = case SM.lookup date (fxQuotePairDatabaseTable db) of + Nothing -> findFxQuoteAux (addDays (-1) date) db + Just fx -> Just fx diff --git a/src/Haspara/Money.hs b/src/Haspara/Money.hs index 675f172..beb675d 100644 --- a/src/Haspara/Money.hs +++ b/src/Haspara/Money.hs @@ -12,7 +12,7 @@ import Data.Scientific (Scientific) import Data.Time (Day) import GHC.TypeLits (KnownNat, Nat) import Haspara.Currency (Currency, CurrencyPair(currencyPairBase, currencyPairQuote)) -import Haspara.FXQuote (FXQuote(fxQuotePair, fxQuoteRate)) +import Haspara.FxQuote (FxQuote(fxQuotePair, fxQuoteRate)) import Haspara.Quantity (Quantity, mkQuantity, times) import Refined (unrefine) @@ -107,8 +107,8 @@ convert x@(MoneySome d cbase q) cquot rate -- | Converts the given 'Money' value to another currency with the given --- 'FXQuote'. -convertWithQuote :: (KnownNat s, KnownNat k) => Money s -> FXQuote k -> Money s +-- 'FxQuote'. +convertWithQuote :: (KnownNat s, KnownNat k) => Money s -> FxQuote k -> Money s convertWithQuote MoneyZero _ = MoneyZero convertWithQuote x@(MoneyFail _) _ = x convertWithQuote x@(MoneySome _ cbase _) quote From 11084d3278c7a2bbd1094a19c91c78dbf3418ec2 Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Wed, 2 Mar 2022 14:24:28 +0800 Subject: [PATCH 10/14] refactor: refactor and move definitions from Haspara.Money to Haspara.Monetary This module is highly experimental anyway. Expect more changes. --- haspara.cabal | 4 +- package.yaml | 1 + src/Haspara.hs | 4 +- src/Haspara/FxQuote.hs | 10 ++-- src/Haspara/Monetary.hs | 121 ++++++++++++++++++++++++++++++++++++++++ src/Haspara/Money.hs | 116 -------------------------------------- 6 files changed, 132 insertions(+), 124 deletions(-) create mode 100644 src/Haspara/Monetary.hs delete mode 100644 src/Haspara/Money.hs diff --git a/haspara.cabal b/haspara.cabal index b86fd90..1f2475e 100644 --- a/haspara.cabal +++ b/haspara.cabal @@ -38,7 +38,7 @@ library Haspara.Accounting.Types Haspara.Currency Haspara.FxQuote - Haspara.Money + Haspara.Monetary Haspara.Quantity Haspara.TH other-modules: @@ -89,6 +89,7 @@ library , base >=4.11 && <5 , containers , deriving-aeson + , exceptions , hashable , megaparsec , mtl @@ -114,6 +115,7 @@ test-suite haspara-doctest , containers , deriving-aeson , doctest + , exceptions , hashable , haspara , megaparsec diff --git a/package.yaml b/package.yaml index d491f46..28c40c1 100644 --- a/package.yaml +++ b/package.yaml @@ -19,6 +19,7 @@ dependencies: - aeson - containers - deriving-aeson +- exceptions - hashable - megaparsec - mtl diff --git a/src/Haspara.hs b/src/Haspara.hs index cb3cd17..825d898 100644 --- a/src/Haspara.hs +++ b/src/Haspara.hs @@ -1,11 +1,11 @@ module Haspara ( module Haspara.Currency , module Haspara.FxQuote - , module Haspara.Money + , module Haspara.Monetary , module Haspara.Quantity ) where import Haspara.Currency import Haspara.FxQuote -import Haspara.Money +import Haspara.Monetary import Haspara.Quantity diff --git a/src/Haspara/FxQuote.hs b/src/Haspara/FxQuote.hs index 453dc6c..8050ebb 100644 --- a/src/Haspara/FxQuote.hs +++ b/src/Haspara/FxQuote.hs @@ -31,7 +31,7 @@ import Refined (Positive, Refined, refineError) -- 3. a (positive) rate as the value of the quotation. -- -- >>> -data FxQuote (s :: Nat) = MkFXQuote +data FxQuote (s :: Nat) = MkFxQuote { fxQuotePair :: !CurrencyPair -- ^ Currency pair of the FX rate. , fxQuoteDate :: !Day -- ^ Actual date of the FX rate. , fxQuoteRate :: !(Refined Positive (Quantity s)) -- ^ (Positive) rate value of the FX rate. @@ -47,7 +47,7 @@ data FxQuote (s :: Nat) = MkFXQuote -- throw an error. -- -- >>> mkFxQuoteError @(Either _) @2 (read "2021-12-31") "EUR" "USD" 1.16 --- Right (MkFXQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16}) +-- Right (MkFxQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16}) -- >>> mkFxQuoteError @(Either _) @2 (read "2021-12-31") "EUR" "USD" (-1.16) -- Left "Can not create FX Rate. Error was: The predicate (GreaterThan 0) failed with the message: Value is not greater than 0\n" mkFxQuoteError @@ -61,7 +61,7 @@ mkFxQuoteError mkFxQuoteError date ccy1 ccy2 rate = either (throwError . (<>) "Can not create FX Rate. Error was: ") pure $ do pval <- either (Left . T.pack . show) pure $ refineError (mkQuantity rate) - pure $ MkFXQuote (CurrencyPair ccy1 ccy2) date pval + pure $ MkFxQuote (CurrencyPair ccy1 ccy2) date pval -- | Smart constructor for 'FxQuote' values within 'MonadFail' context. @@ -69,7 +69,7 @@ mkFxQuoteError date ccy1 ccy2 rate = -- The rate is expected to be a positive value. If it is not, the function will -- fail. -- >>> mkFxQuoteFail @Maybe @2 (read "2021-12-31") "EUR" "USD" 1.16 --- Just (MkFXQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16}) +-- Just (MkFxQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16}) -- >>> mkFxQuoteFail @Maybe @2 (read "2021-12-31") "EUR" "USD" (-1.16) -- Nothing mkFxQuoteFail @@ -87,7 +87,7 @@ mkFxQuoteFail date ccy1 ccy2 = -- | Unsafe 'FxQuote' constructor that 'error's if it fails. -- -- >>> mkFxQuoteUnsafe @2 (read "2021-12-31") "EUR" "USD" 1.16 --- MkFXQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16} +-- MkFxQuote {fxQuotePair = EUR/USD, fxQuoteDate = 2021-12-31, fxQuoteRate = Refined 1.16} -- >>> mkFxQuoteUnsafe @2 (read "2021-12-31") "EUR" "USD" (-1.16) -- ... -- ...Can not create FX Rate. Error was: The predicate (GreaterThan 0) failed with the message: Value is not greater than 0 diff --git a/src/Haspara/Monetary.hs b/src/Haspara/Monetary.hs new file mode 100644 index 0000000..e9b96fa --- /dev/null +++ b/src/Haspara/Monetary.hs @@ -0,0 +1,121 @@ +-- | This module provides definitions for modeling and working with monetary +-- values. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} + +module Haspara.Monetary where + +import Control.Exception (Exception) +import Control.Monad (when) +import Control.Monad.Catch (MonadThrow(throwM)) +import Data.Time (Day) +import qualified Deriving.Aeson.Stock as DAS +import GHC.Stack (HasCallStack) +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Currency (Currency, CurrencyPair(..)) +import Haspara.FxQuote (FxQuote(..)) +import Haspara.Quantity (Quantity, times) +import Refined (unrefine) + + +-- | Type encoding for dated monetary values. +-- +-- A dated monetary value is a 3-tuple of: +-- +-- 1. a date when the monetary value is effective as of, +-- 2. the currency of the monetary value, and +-- 3. the quantity of the monetary value. +data Money (s :: Nat) = Money + { moneyDate :: !Day + , moneyCurrency :: !Currency + , moneyQuantity :: !(Quantity s) + } + deriving (Eq, DAS.Generic, Ord, Show) + deriving (DAS.FromJSON, DAS.ToJSON) via DAS.PrefixedSnake "money" (Money s) + + +-- | Type encoding of a monetary context. +class MonadThrow m => Monetary m where + -- | Converts the given monetary value in one currency to another currency. + -- + -- Note that the conversion is performed with an FX rate quotation as of the + -- date of the given monetary value. + convertM + :: HasCallStack + => KnownNat s + => Currency + -> Money s + -> m (Money s) + + -- | Converts the given monetary value in one currency to another currency as + -- of the given date. + -- + -- The rule is: + -- + -- @ + -- convertAsofM (Money ) === convertM (Money ) + -- @ + convertAsofM + :: HasCallStack + => KnownNat s + => Day + -> Currency + -> Money s + -> m (Money s) + convertAsofM date ccyN (Money _ ccy qty) = convertM ccyN (Money date ccy qty) + + +-- | Attempts to convert the given 'Money' to another using the given 'FxQuote' +-- value. +-- +-- This function runs some guards before attempting to do the conversion: +-- +-- 1. Base currency of the FX rate quotation should be the same as the currency +-- of the monetary value, throws 'IncompatibleCurrenciesException' otherwise. +-- 2. Date of the FX rate quotation should be equal to or greater than the date +-- of the monetary value, throws 'IncompatibleDatesException' otherwise. +-- 3. Rate of the FX rate quotation should be @1@ if the base and quote +-- quotation are same, throws 'InconsistentFxQuoteException' otherwise. +convert + :: HasCallStack + => MonadThrow m + => KnownNat s + => KnownNat k + => Money s + -> FxQuote k + -> m (Money s) +convert (Money date ccy qty) quote@(MkFxQuote (CurrencyPair ccy1 ccy2) asof rate) = do + when (ccy /= ccy1) (throwM (IncompatibleCurrenciesException ccy ccy1)) + when (asof < date) (throwM (IncompatibleDatesException date asof)) + when (ccy1 == ccy2 && unrefine rate /= 1) (throwM (InconsistentFxQuoteException quote)) + pure (Money asof ccy2 (times qty (unrefine rate))) + + +-- | Type encoding of exceptions thrown by the `Haspara.Monetary` module. +data MonetaryException where + -- | Indicates that we received a currency other than the expected currency. + IncompatibleCurrenciesException + :: HasCallStack + => Currency -- ^ Expected currency + -> Currency -- ^ Received currency + -> MonetaryException + + -- | Indicates that we received a currency other than the expected currency. + IncompatibleDatesException + :: HasCallStack + => Day -- ^ Date on and onwards of interest + -> Day -- ^ Date received + -> MonetaryException + + -- | Indicates that we received a currency other than the expected currency. + InconsistentFxQuoteException + :: forall (s :: Nat). (HasCallStack, KnownNat s) + => FxQuote s -- ^ FX rate quotation that is interpreted as inconsistent. + -> MonetaryException + + +deriving instance Show MonetaryException + + +instance Exception MonetaryException diff --git a/src/Haspara/Money.hs b/src/Haspara/Money.hs deleted file mode 100644 index beb675d..0000000 --- a/src/Haspara/Money.hs +++ /dev/null @@ -1,116 +0,0 @@ --- | This module provides definitions for modeling and working with monetary --- values. - -{-# LANGUAGE DataKinds #-} - -module Haspara.Money where - -import Control.Applicative ((<|>)) -import Data.Aeson ((.:), (.=)) -import qualified Data.Aeson as Aeson -import Data.Scientific (Scientific) -import Data.Time (Day) -import GHC.TypeLits (KnownNat, Nat) -import Haspara.Currency (Currency, CurrencyPair(currencyPairBase, currencyPairQuote)) -import Haspara.FxQuote (FxQuote(fxQuotePair, fxQuoteRate)) -import Haspara.Quantity (Quantity, mkQuantity, times) -import Refined (unrefine) - - -data Money (s :: Nat) = - MoneySome Day 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 => Day -> Currency -> Quantity s -> Money s -mkMoney = MoneySome - - -mkMoneyFromScientific :: KnownNat s => Day -> Currency -> Scientific -> Money s -mkMoneyFromScientific d c s = mkMoney d c (mkQuantity s) - - -moneyDate :: KnownNat s => Money s -> Maybe Day -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 date = read "2021-01-01" :: Day --- >>> let eurmoney = mkMoney date "EUR" (mkQuantity 0.42 :: Quantity 2) :: Money 2 --- >>> convert eurmoney "EUR" (mkQuantity 1 :: Quantity 4) --- MoneySome 2021-01-01 EUR 0.42 --- >>> convert eurmoney "USD" (mkQuantity 1 :: Quantity 4) --- MoneySome 2021-01-01 USD 0.42 --- >>> convert eurmoney "USD" (mkQuantity 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 /= currencyPairBase (fxQuotePair quote) = MoneyFail $ "Attempting to convert with incompatible base currency: " <> show x <> " with " <> show quote - | otherwise = convert x (currencyPairQuote (fxQuotePair quote)) (unrefine $ fxQuoteRate quote) From c13fca8a3b2fa65eb6f69a8ba6943c96a2497116 Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Thu, 3 Mar 2022 08:59:46 +0800 Subject: [PATCH 11/14] refactor: revisit Haspara.Accounting module and its submodules --- haspara.cabal | 5 +- src/Haspara/Accounting.hs | 21 ++-- src/Haspara/Accounting/Account.hs | 108 +++++++++++++++-- src/Haspara/Accounting/AccountKind.hs | 73 ----------- src/Haspara/Accounting/Entry.hs | 109 ----------------- src/Haspara/Accounting/Event.hs | 50 +++++--- src/Haspara/Accounting/Ledger.hs | 168 ++++++++++++++++++++++++-- src/Haspara/Accounting/Posting.hs | 49 -------- src/Haspara/Accounting/Types.hs | 7 -- src/Haspara/Internal/Aeson.hs | 14 +++ src/Haspara/Quantity.hs | 5 + 11 files changed, 321 insertions(+), 288 deletions(-) delete mode 100644 src/Haspara/Accounting/AccountKind.hs delete mode 100644 src/Haspara/Accounting/Entry.hs delete mode 100644 src/Haspara/Accounting/Posting.hs delete mode 100644 src/Haspara/Accounting/Types.hs create mode 100644 src/Haspara/Internal/Aeson.hs diff --git a/haspara.cabal b/haspara.cabal index 1f2475e..3437d85 100644 --- a/haspara.cabal +++ b/haspara.cabal @@ -30,14 +30,11 @@ library Haspara Haspara.Accounting Haspara.Accounting.Account - Haspara.Accounting.AccountKind - Haspara.Accounting.Entry Haspara.Accounting.Event Haspara.Accounting.Ledger - Haspara.Accounting.Posting - Haspara.Accounting.Types Haspara.Currency Haspara.FxQuote + Haspara.Internal.Aeson Haspara.Monetary Haspara.Quantity Haspara.TH diff --git a/src/Haspara/Accounting.hs b/src/Haspara/Accounting.hs index 53e6c59..3960808 100644 --- a/src/Haspara/Accounting.hs +++ b/src/Haspara/Accounting.hs @@ -1,3 +1,6 @@ +-- | This module provides a collection of definitions for a rudimentary +-- accounting functionality. + module Haspara.Accounting ( Account(..) , AccountKind(..) @@ -12,7 +15,6 @@ module Haspara.Accounting , Posting(..) , postingEvents , post - , UnsignedQuantity , Ledger(..) , LedgerItem(..) , mkLedger @@ -25,18 +27,21 @@ module Haspara.Accounting ) where -import Haspara.Accounting.Account (Account(..)) -import Haspara.Accounting.AccountKind (AccountKind(..), accountKindText) -import Haspara.Accounting.Entry +import Haspara.Accounting.Account (Account(..), AccountKind(..), accountKindText) +import Haspara.Accounting.Event (Event(..), eventDate, eventObject, mkEvent, negateEvent) +import Haspara.Accounting.Ledger ( Entry(..) + , Ledger(..) + , LedgerItem(..) + , Posting(..) + , addEntry , buildEntry , entryCredit , entryDate , entryDebit , entryObject , entryQuantity + , mkLedger + , post + , postingEvents ) -import Haspara.Accounting.Event (Event(..), eventDate, eventObject, mkEvent, negateEvent) -import Haspara.Accounting.Ledger (Ledger(..), LedgerItem(..), addEntry, mkLedger) -import Haspara.Accounting.Posting (Posting(..), post, postingEvents) -import Haspara.Accounting.Types (UnsignedQuantity) diff --git a/src/Haspara/Accounting/Account.hs b/src/Haspara/Accounting/Account.hs index f848969..c773425 100644 --- a/src/Haspara/Accounting/Account.hs +++ b/src/Haspara/Accounting/Account.hs @@ -1,31 +1,113 @@ +-- | This module provides definitions for acccounts and types of accounts as +-- they are used in accounting reporting. + {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} module Haspara.Accounting.Account where -import Data.Hashable (Hashable) -import Deriving.Aeson (CustomJSON(CustomJSON), FromJSON, Generic, ToJSON) -import Deriving.Aeson.Stock (PrefixedSnake) -import Haspara.Accounting.AccountKind (AccountKind) +import Data.Hashable (Hashable) +import qualified Data.Text as T +import qualified Deriving.Aeson as DA +import qualified Deriving.Aeson.Stock as DAS +import Haspara.Internal.Aeson (UpperCase) + + +-- * Account Kind +-- $accountKind + + +-- | Type encoding for ledger account type. +-- +-- This type covers both balance sheet and income statement account types: +-- +-- 1. For balance sheet accounts: +-- 1. Asset ('AccountKindAsset') +-- 2. Liability ('AccountKindLiability') +-- 3. Equity ('AccountKindEquity') +-- 2. For income statement accounts: +-- 1. Revenue ('AccountKindRevenue') +-- 2. Expense ('AccountKindExpense') +-- +-- 'Data.Aeson.FromJSON' and 'Data.Aeson.ToJSON' instances, too: +-- +-- >>> Data.Aeson.decode @AccountKind "\"ASSET\"" +-- Just AccountKindAsset +-- >>> Data.Aeson.decode @AccountKind "\"LIABILITY\"" +-- Just AccountKindLiability +-- >>> Data.Aeson.decode @AccountKind "\"EQUITY\"" +-- Just AccountKindEquity +-- >>> Data.Aeson.decode @AccountKind "\"REVENUE\"" +-- Just AccountKindRevenue +-- >>> Data.Aeson.decode @AccountKind "\"EXPENSE\"" +-- Just AccountKindExpense +-- >>> Data.Aeson.encode AccountKindAsset +-- "\"ASSET\"" +-- >>> Data.Aeson.encode AccountKindLiability +-- "\"LIABILITY\"" +-- >>> Data.Aeson.encode AccountKindEquity +-- "\"EQUITY\"" +-- >>> Data.Aeson.encode AccountKindRevenue +-- "\"REVENUE\"" +-- >>> Data.Aeson.encode AccountKindExpense +-- "\"EXPENSE\"" +data AccountKind = + AccountKindAsset + | AccountKindLiability + | AccountKindEquity + | AccountKindRevenue + | AccountKindExpense + deriving (Enum, Eq, DA.Generic, Ord, Show) + deriving (DA.FromJSON, DA.ToJSON) via DA.CustomJSON '[DA.ConstructorTagModifier (DA.StripPrefix "AccountKind", UpperCase)] AccountKind --- | Account model. +instance Hashable AccountKind + + +-- | Provides textual representation of a given 'AccountKind'. +-- +-- >>> accountKindText AccountKindAsset +-- "Asset" +-- >>> accountKindText AccountKindLiability +-- "Liability" +-- >>> accountKindText AccountKindEquity +-- "Equity" +-- >>> accountKindText AccountKindRevenue +-- "Revenue" +-- >>> accountKindText AccountKindExpense +-- "Expense" +accountKindText :: AccountKind -> T.Text +accountKindText AccountKindAsset = "Asset" +accountKindText AccountKindLiability = "Liability" +accountKindText AccountKindEquity = "Equity" +accountKindText AccountKindRevenue = "Revenue" +accountKindText AccountKindExpense = "Expense" + + +-- * Account +-- $account + + +-- | Type encoding for account values. +-- +-- This definition provides both the 'AccountKind' and an arbitrary object +-- identifying the account. This arbitrary nature provides flexibility to +-- use-site to use its own account identity and accompanying information when +-- required. -- --- >>> import Haspara.Accounting.AccountKind (AccountKind(..)) --- >>> import qualified Data.Aeson as Aeson -- >>> let acc = Account AccountKindAsset (1 ::Int) --- >>> Aeson.encode acc +-- >>> Data.Aeson.encode acc -- "{\"kind\":\"ASSET\",\"object\":1}" --- >>> Aeson.decode (Aeson.encode acc) :: Maybe (Account Int) +-- >>> Data.Aeson.decode @(Account Int) (Data.Aeson.encode acc) -- Just (Account {accountKind = AccountKindAsset, accountObject = 1}) --- >>> Aeson.decode (Aeson.encode acc) == Just acc +-- >>> Data.Aeson.decode (Data.Aeson.encode acc) == Just acc -- True data Account o = Account { accountKind :: !AccountKind , accountObject :: !o - } deriving (Eq, Generic, Ord, Show) - deriving (FromJSON, ToJSON) - via PrefixedSnake "account" (Account o) + } + deriving (Eq, DAS.Generic, Ord, Show) + deriving (DAS.FromJSON, DAS.ToJSON) via DAS.PrefixedSnake "account" (Account o) instance Hashable o => Hashable (Account o) diff --git a/src/Haspara/Accounting/AccountKind.hs b/src/Haspara/Accounting/AccountKind.hs deleted file mode 100644 index d5a1da2..0000000 --- a/src/Haspara/Accounting/AccountKind.hs +++ /dev/null @@ -1,73 +0,0 @@ -module Haspara.Accounting.AccountKind where - -import qualified Data.Aeson as Aeson -import qualified Data.Char as C -import Data.Hashable (Hashable) -import qualified Data.Text as T -import GHC.Generics (Generic) - - -data AccountKind = - AccountKindAsset - | AccountKindLiability - | AccountKindEquity - | AccountKindRevenue - | AccountKindExpense - deriving (Enum, Eq, Generic, Ord, Show) - - -instance Hashable AccountKind - - --- | 'Aeson.FromJSON' instance for 'AccountKind'. --- --- >>> Aeson.decode "\"Asset\"" :: Maybe AccountKind --- Just AccountKindAsset --- >>> Aeson.decode "\"aSSET\"" :: Maybe AccountKind --- Just AccountKindAsset --- >>> Aeson.decode "\"ASSET\"" :: Maybe AccountKind --- Just AccountKindAsset --- >>> Aeson.decode "\"LIABILITY\"" :: Maybe AccountKind --- Just AccountKindLiability --- >>> Aeson.decode "\"EQUITY\"" :: Maybe AccountKind --- Just AccountKindEquity --- >>> Aeson.decode "\"REVENUE\"" :: Maybe AccountKind --- Just AccountKindRevenue --- >>> Aeson.decode "\"EXPENSE\"" :: Maybe AccountKind --- Just AccountKindExpense -instance Aeson.FromJSON AccountKind where - parseJSON = Aeson.withText "AccountKind" $ \t -> case T.map C.toUpper t of - "ASSET" -> pure AccountKindAsset - "LIABILITY" -> pure AccountKindLiability - "EQUITY" -> pure AccountKindEquity - "REVENUE" -> pure AccountKindRevenue - "EXPENSE" -> pure AccountKindExpense - _ -> fail $ "Unknown account kind: " <> show t - - --- | 'Aeson.ToJSON' instance for 'AccountKind'. --- --- >>> Aeson.encode AccountKindAsset --- "\"ASSET\"" --- >>> Aeson.encode AccountKindLiability --- "\"LIABILITY\"" --- >>> Aeson.encode AccountKindEquity --- "\"EQUITY\"" --- >>> Aeson.encode AccountKindRevenue --- "\"REVENUE\"" --- >>> Aeson.encode AccountKindExpense --- "\"EXPENSE\"" -instance Aeson.ToJSON AccountKind where - toJSON AccountKindAsset = Aeson.String "ASSET" - toJSON AccountKindLiability = Aeson.String "LIABILITY" - toJSON AccountKindEquity = Aeson.String "EQUITY" - toJSON AccountKindRevenue = Aeson.String "REVENUE" - toJSON AccountKindExpense = Aeson.String "EXPENSE" - - -accountKindText :: AccountKind -> T.Text -accountKindText AccountKindAsset = "Asset" -accountKindText AccountKindLiability = "Liability" -accountKindText AccountKindEquity = "Equity" -accountKindText AccountKindRevenue = "Revenue" -accountKindText AccountKindExpense = "Expense" diff --git a/src/Haspara/Accounting/Entry.hs b/src/Haspara/Accounting/Entry.hs deleted file mode 100644 index 59328d6..0000000 --- a/src/Haspara/Accounting/Entry.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE DataKinds #-} - -module Haspara.Accounting.Entry where - -import Data.Aeson ((.:), (.=)) -import qualified Data.Aeson as Aeson -import qualified Data.Char as C -import qualified Data.Text as T -import Data.Time (Day) -import GHC.TypeLits (KnownNat, Nat) -import qualified Haspara as H -import Haspara.Accounting.AccountKind (AccountKind(..)) -import Haspara.Accounting.Event (Event(..)) -import Haspara.Accounting.Types (UnsignedQuantity) -import Refined (unrefine) - - --- | Encoding of a posting entry. --- --- >>> :set -XDataKinds --- >>> import Refined --- >>> let date = read "2021-01-01" --- >>> let oid = 1 :: Int --- >>> let qty = $$(refineTH 42) :: UnsignedQuantity 2 --- >>> let entry = EntryDebit date oid qty --- >>> let json = Aeson.encode entry --- >>> json --- "{\"qty\":42.0,\"type\":\"DEBIT\",\"obj\":1,\"date\":\"2021-01-01\"}" --- >>> Aeson.decode json :: Maybe (Entry Int 2) --- Just (EntryDebit 2021-01-01 1 (Refined 42.00)) --- >>> Aeson.decode json == Just entry --- True -data Entry o (s :: Nat) = - EntryDebit Day o (UnsignedQuantity s) - | EntryCredit Day o (UnsignedQuantity s) - deriving (Eq, Ord, Show) - - -instance (Aeson.FromJSON o, KnownNat s) => Aeson.FromJSON (Entry o s) where - parseJSON = Aeson.withObject "Entry" $ \o -> do - dorc <- o .: "type" - cons <- case T.map C.toUpper dorc of - "DEBIT" -> pure EntryDebit - "CREDIT" -> pure EntryCredit - x -> fail ("Unknown entry type: " <> T.unpack x) - date <- o .: "date" - obj <- o .: "obj" - qty <- o .: "qty" - pure (cons date obj qty) - - -instance (Aeson.ToJSON o, KnownNat s) => Aeson.ToJSON (Entry o s) where - toJSON x = case x of - EntryDebit d o q -> Aeson.object ["type" .= ("DEBIT" :: T.Text), "date" .= d, "obj" .= o, "qty" .= q] - EntryCredit d o q -> Aeson.object ["type" .= ("CREDIT" :: T.Text), "date" .= d, "obj" .= o, "qty" .= q] - - -entryDate :: KnownNat s => Entry o s -> Day -entryDate (EntryDebit d _ _) = d -entryDate (EntryCredit d _ _) = d - - -entryQuantity :: KnownNat s => Entry o s -> H.Quantity s -entryQuantity (EntryDebit _ _ q) = unrefine q -entryQuantity (EntryCredit _ _ q) = -(unrefine q) - - -entryObject :: KnownNat s => Entry o s -> o -entryObject (EntryDebit _ o _) = o -entryObject (EntryCredit _ o _) = o - - -entryDebit :: KnownNat s => Entry o s -> Maybe (UnsignedQuantity s) -entryDebit (EntryDebit _ _ x) = Just x -entryDebit EntryCredit {} = Nothing - - -entryCredit :: KnownNat s => Entry o s -> Maybe (UnsignedQuantity s) -entryCredit EntryDebit {} = Nothing -entryCredit (EntryCredit _ _ x) = Just x - - --- | --- --- +-----------------------+----------+----------+ --- | Kind of account | Debit | Credit | --- +-----------------------+----------+----------+ --- | Asset | Increase | Decrease | --- +-----------------------+----------+----------+ --- | Liability | Decrease | Increase | --- +-----------------------+----------+----------+ --- | Equity/Capital | Decrease | Increase | --- +-----------------------+----------+----------+ --- | Income/Revenue | Decrease | Increase | --- +-----------------------+----------+----------+ --- | Expense/Cost/Dividend | Increase | Decrease | --- +-----------------------+----------+----------+ --- -buildEntry :: (KnownNat s) => Event o s -> AccountKind -> Entry o s -buildEntry (EventDecrement d o x) AccountKindAsset = EntryCredit d o x -buildEntry (EventIncrement d o x) AccountKindAsset = EntryDebit d o x -buildEntry (EventDecrement d o x) AccountKindLiability = EntryDebit d o x -buildEntry (EventIncrement d o x) AccountKindLiability = EntryCredit d o x -buildEntry (EventDecrement d o x) AccountKindEquity = EntryDebit d o x -buildEntry (EventIncrement d o x) AccountKindEquity = EntryCredit d o x -buildEntry (EventDecrement d o x) AccountKindRevenue = EntryDebit d o x -buildEntry (EventIncrement d o x) AccountKindRevenue = EntryCredit d o x -buildEntry (EventDecrement d o x) AccountKindExpense = EntryCredit d o x -buildEntry (EventIncrement d o x) AccountKindExpense = EntryDebit d o x diff --git a/src/Haspara/Accounting/Event.hs b/src/Haspara/Accounting/Event.hs index 28e0e8e..36fd7f2 100644 --- a/src/Haspara/Accounting/Event.hs +++ b/src/Haspara/Accounting/Event.hs @@ -1,33 +1,39 @@ +-- | This module provides definitions for economic events. +-- +-- /Note: The concept is not YET REA-compatible although we want to achieve it +-- at some point/. + {-# LANGUAGE DataKinds #-} module Haspara.Accounting.Event where -import Control.Monad.Except (MonadError(throwError)) -import Data.Aeson ((.:), (.=)) -import qualified Data.Aeson as Aeson -import qualified Data.Char as C -import qualified Data.Text as T -import Data.Time (Day) -import GHC.TypeLits (KnownNat, Nat) -import qualified Haspara as H -import Haspara.Accounting.Types (UnsignedQuantity) -import Refined (refine) +import Control.Monad.Except (MonadError(throwError)) +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Char as C +import qualified Data.Text as T +import Data.Time (Day) +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Quantity (Quantity, UnsignedQuantity) +import Refined (refine) --- | Encoding of an increment/decrement event. +-- | Type encoding of an economic increment/decrement event. +-- +-- The event explicitly carries the date and quantity information along with a +-- parameterized, arbitrary object providing the source of the event. -- -- >>> :set -XDataKinds --- >>> import Refined -- >>> let date = read "2021-01-01" -- >>> let oid = 1 :: Int --- >>> let qty = $$(refineTH 42) :: UnsignedQuantity 2 +-- >>> let qty = $$(Refined.refineTH 42) :: UnsignedQuantity 2 -- >>> let event = EventDecrement date oid qty --- >>> let json = Aeson.encode event +-- >>> let json = Data.Aeson.encode event -- >>> json -- "{\"qty\":42.0,\"type\":\"DECREMENT\",\"obj\":1,\"date\":\"2021-01-01\"}" --- >>> Aeson.decode json :: Maybe (Event Int 2) +-- >>> Data.Aeson.decode @(Event Int 2) json -- Just (EventDecrement 2021-01-01 1 (Refined 42.00)) --- >>> Aeson.decode json == Just event +-- >>> Data.Aeson.decode json == Just event -- True data Event o (s :: Nat) = EventDecrement Day o (UnsignedQuantity s) @@ -54,22 +60,32 @@ instance (Aeson.ToJSON o, KnownNat s) => Aeson.ToJSON (Event o s) where EventIncrement d o q -> Aeson.object ["type" .= ("INCREMENT" :: T.Text), "date" .= d, "obj" .= o, "qty" .= q] +-- | Returns the date of the event. eventDate :: (KnownNat s) => Event o s -> Day eventDate (EventDecrement d _ _) = d eventDate (EventIncrement d _ _) = d +-- | Returns the source object of the event. eventObject :: (KnownNat s) => Event o s -> o eventObject (EventDecrement _ o _) = o eventObject (EventIncrement _ o _) = o +-- | Negates the event. negateEvent :: (KnownNat s) => Event o s -> Event o s negateEvent (EventDecrement d o x) = EventIncrement d o x negateEvent (EventIncrement d o x) = EventDecrement d o x -mkEvent :: (MonadError String m, KnownNat s) => Day -> o -> H.Quantity s -> m (Event o s) +-- | Smart constuctor for 'Event' values. +mkEvent + :: MonadError String m + => KnownNat s + => Day -- ^ Date of the event. + -> o -- ^ Source object of the event. + -> Quantity s -- ^ Quantity of the event. + -> m (Event o s) mkEvent d o x | x < 0 = either (throwError . show) pure $ EventDecrement d o <$> refine (abs x) | otherwise = either (throwError . show) pure $ EventIncrement d o <$> refine (abs x) diff --git a/src/Haspara/Accounting/Ledger.hs b/src/Haspara/Accounting/Ledger.hs index 452485b..316fbae 100644 --- a/src/Haspara/Accounting/Ledger.hs +++ b/src/Haspara/Accounting/Ledger.hs @@ -1,26 +1,36 @@ +-- | This module provides definitions for postings, ledgers and ledger entries. + {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} module Haspara.Accounting.Ledger where -import Deriving.Aeson (CustomJSON(CustomJSON), FromJSON, Generic, ToJSON) -import Deriving.Aeson.Stock (PrefixedSnake) -import GHC.TypeLits (KnownNat, Nat) -import Haspara (Quantity) -import Haspara.Accounting.Account (Account) -import Haspara.Accounting.Entry (Entry(..), entryQuantity) +import Data.Aeson ((.:), (.=)) +import qualified Data.Aeson as Aeson +import qualified Data.Char as C +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T +import Data.Time (Day) +import Deriving.Aeson (CustomJSON(CustomJSON), FromJSON, Generic, ToJSON) +import Deriving.Aeson.Stock (PrefixedSnake, Vanilla) +import GHC.TypeLits (KnownNat, Nat) +import Haspara.Accounting.Account (Account(accountKind), AccountKind(..)) +import Haspara.Accounting.Event (Event(..), eventObject) +import Haspara.Quantity (Quantity, UnsignedQuantity) +import Refined (unrefine) +-- | Type encoding of a ledger. data Ledger a o (s :: Nat) = Ledger { ledgerAccount :: !(Account a) , ledgerOpening :: !(Quantity s) , ledgerClosing :: !(Quantity s) , ledgerRunning :: ![LedgerItem o s] } deriving (Eq, Generic, Ord, Show) - deriving (FromJSON, ToJSON) - via PrefixedSnake "ledger" (Ledger a o s) + deriving (FromJSON, ToJSON) via PrefixedSnake "ledger" (Ledger a o s) +-- | Type encoding of a ledger item. data LedgerItem o (s :: Nat) = LedgerItem { ledgerItemEntry :: !(Entry o s) , ledgerItemBalance :: !(Quantity s) @@ -29,12 +39,154 @@ data LedgerItem o (s :: Nat) = LedgerItem via PrefixedSnake "ledgerItem" (LedgerItem o s) +-- | Creates a ledger from a given list of 'Entry' values. mkLedger :: KnownNat s => Account a -> Quantity s -> [Entry o s] -> Ledger a o s mkLedger a o = foldl addEntry (Ledger a o o []) +-- | Adds a new entry to a ledger. addEntry :: KnownNat s => Ledger a o s -> Entry o s -> Ledger a o s addEntry l@(Ledger _ _ c r) e = l { ledgerClosing = balance, ledgerRunning = r <> [item]} where balance = c + entryQuantity e item = LedgerItem e balance + + +-- | Type encoding for a posting. +-- +-- >>> :set -XDataKinds +-- >>> import Haspara.Accounting +-- >>> import Refined +-- >>> import qualified Data.Aeson as Aeson +-- >>> import qualified Data.List.NonEmpty as NE +-- >>> let date = read "2021-01-01" +-- >>> let oid = 1 :: Int +-- >>> let qty = $$(refineTH 42) :: UnsignedQuantity 2 +-- >>> let event = EventDecrement date oid qty +-- >>> let account = Account AccountKindAsset ("Cash" :: String, 1 ::Int) +-- >>> let posting = Posting . NE.fromList $ [(event, account)] +-- >>> let json = Aeson.encode posting +-- >>> json +-- "[[{\"qty\":42.0,\"type\":\"DECREMENT\",\"obj\":1,\"date\":\"2021-01-01\"},{\"kind\":\"ASSET\",\"object\":[\"Cash\",1]}]]" +-- >>> Aeson.decode json :: Maybe (Posting (String, Int) Int 2) +-- Just (Posting ((EventDecrement 2021-01-01 1 (Refined 42.00),Account {accountKind = AccountKindAsset, accountObject = ("Cash",1)}) :| [])) +-- >>> Aeson.decode json == Just posting +-- True +newtype Posting a o (s :: Nat) = Posting (NE.NonEmpty (Event o s, Account a)) + deriving (Eq, Generic, Ord, Show) + deriving (FromJSON, ToJSON) + via Vanilla (Posting a o s) + + +-- | Returns the list of posting event sources. +postingEvents :: (KnownNat s) => Posting a o s -> [o] +postingEvents (Posting es) = eventObject . fst <$> NE.toList es + + +-- | Posts an event. +post :: (KnownNat s) => Posting a o s -> [(Account a, Entry o s)] +post (Posting xs) = go (NE.toList xs) + where + go [] = [] + go ((ev, ac) : ys) = (ac, buildEntry ev (accountKind ac)) : go ys + + +-- | Encoding of a posting entry. +-- +-- >>> :set -XDataKinds +-- >>> import Refined +-- >>> let date = read "2021-01-01" +-- >>> let oid = 1 :: Int +-- >>> let qty = $$(refineTH 42) :: UnsignedQuantity 2 +-- >>> let entry = EntryDebit date oid qty +-- >>> let json = Aeson.encode entry +-- >>> json +-- "{\"qty\":42.0,\"type\":\"DEBIT\",\"obj\":1,\"date\":\"2021-01-01\"}" +-- >>> Aeson.decode json :: Maybe (Entry Int 2) +-- Just (EntryDebit 2021-01-01 1 (Refined 42.00)) +-- >>> Aeson.decode json == Just entry +-- True +data Entry o (s :: Nat) = + EntryDebit Day o (UnsignedQuantity s) + | EntryCredit Day o (UnsignedQuantity s) + deriving (Eq, Ord, Show) + + +instance (Aeson.FromJSON o, KnownNat s) => Aeson.FromJSON (Entry o s) where + parseJSON = Aeson.withObject "Entry" $ \o -> do + dorc <- o .: "type" + cons <- case T.map C.toUpper dorc of + "DEBIT" -> pure EntryDebit + "CREDIT" -> pure EntryCredit + x -> fail ("Unknown entry type: " <> T.unpack x) + date <- o .: "date" + obj <- o .: "obj" + qty <- o .: "qty" + pure (cons date obj qty) + + +instance (Aeson.ToJSON o, KnownNat s) => Aeson.ToJSON (Entry o s) where + toJSON x = case x of + EntryDebit d o q -> Aeson.object ["type" .= ("DEBIT" :: T.Text), "date" .= d, "obj" .= o, "qty" .= q] + EntryCredit d o q -> Aeson.object ["type" .= ("CREDIT" :: T.Text), "date" .= d, "obj" .= o, "qty" .= q] + + +-- | Returns the date of the posting entry. +entryDate :: KnownNat s => Entry o s -> Day +entryDate (EntryDebit d _ _) = d +entryDate (EntryCredit d _ _) = d + + +-- | Returns the quantity of the posting entry. +entryQuantity :: KnownNat s => Entry o s -> Quantity s +entryQuantity (EntryDebit _ _ q) = unrefine q +entryQuantity (EntryCredit _ _ q) = -(unrefine q) + + +-- | Returns the source object of the posting entry. +entryObject :: KnownNat s => Entry o s -> o +entryObject (EntryDebit _ o _) = o +entryObject (EntryCredit _ o _) = o + + +-- | Returns the debit quantity of the posting entry. +entryDebit :: KnownNat s => Entry o s -> Maybe (UnsignedQuantity s) +entryDebit (EntryDebit _ _ x) = Just x +entryDebit EntryCredit {} = Nothing + + +-- | Returns the credit quantity of the posting entry. +entryCredit :: KnownNat s => Entry o s -> Maybe (UnsignedQuantity s) +entryCredit EntryDebit {} = Nothing +entryCredit (EntryCredit _ _ x) = Just x + + +-- | Consumes an event and a type of account, and produces a posting entry. +-- +-- Note the following map as a guide: +-- +-- +-----------------------+----------+----------+ +-- | Kind of account | Debit | Credit | +-- +-----------------------+----------+----------+ +-- | Asset | Increase | Decrease | +-- +-----------------------+----------+----------+ +-- | Liability | Decrease | Increase | +-- +-----------------------+----------+----------+ +-- | Equity/Capital | Decrease | Increase | +-- +-----------------------+----------+----------+ +-- | Income/Revenue | Decrease | Increase | +-- +-----------------------+----------+----------+ +-- | Expense/Cost/Dividend | Increase | Decrease | +-- +-----------------------+----------+----------+ +-- +buildEntry :: (KnownNat s) => Event o s -> AccountKind -> Entry o s +buildEntry (EventDecrement d o x) AccountKindAsset = EntryCredit d o x +buildEntry (EventIncrement d o x) AccountKindAsset = EntryDebit d o x +buildEntry (EventDecrement d o x) AccountKindLiability = EntryDebit d o x +buildEntry (EventIncrement d o x) AccountKindLiability = EntryCredit d o x +buildEntry (EventDecrement d o x) AccountKindEquity = EntryDebit d o x +buildEntry (EventIncrement d o x) AccountKindEquity = EntryCredit d o x +buildEntry (EventDecrement d o x) AccountKindRevenue = EntryDebit d o x +buildEntry (EventIncrement d o x) AccountKindRevenue = EntryCredit d o x +buildEntry (EventDecrement d o x) AccountKindExpense = EntryCredit d o x +buildEntry (EventIncrement d o x) AccountKindExpense = EntryDebit d o x diff --git a/src/Haspara/Accounting/Posting.hs b/src/Haspara/Accounting/Posting.hs deleted file mode 100644 index d835e65..0000000 --- a/src/Haspara/Accounting/Posting.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} - -module Haspara.Accounting.Posting where - -import qualified Data.List.NonEmpty as NE -import Deriving.Aeson (CustomJSON(CustomJSON), FromJSON, Generic, ToJSON) -import Deriving.Aeson.Stock (Vanilla) -import GHC.TypeLits (KnownNat, Nat) -import Haspara.Accounting.Account (Account(accountKind)) -import Haspara.Accounting.Entry (Entry, buildEntry) -import Haspara.Accounting.Event (Event, eventObject) - - --- | Type encoding for a posting. --- --- >>> :set -XDataKinds --- >>> import Haspara.Accounting --- >>> import Refined --- >>> import qualified Data.Aeson as Aeson --- >>> import qualified Data.List.NonEmpty as NE --- >>> let date = read "2021-01-01" --- >>> let oid = 1 :: Int --- >>> let qty = $$(refineTH 42) :: UnsignedQuantity 2 --- >>> let event = EventDecrement date oid qty --- >>> let account = Account AccountKindAsset ("Cash" :: String, 1 ::Int) --- >>> let posting = Posting . NE.fromList $ [(event, account)] --- >>> let json = Aeson.encode posting --- >>> json --- "[[{\"qty\":42.0,\"type\":\"DECREMENT\",\"obj\":1,\"date\":\"2021-01-01\"},{\"kind\":\"ASSET\",\"object\":[\"Cash\",1]}]]" --- >>> Aeson.decode json :: Maybe (Posting (String, Int) Int 2) --- Just (Posting ((EventDecrement 2021-01-01 1 (Refined 42.00),Account {accountKind = AccountKindAsset, accountObject = ("Cash",1)}) :| [])) --- >>> Aeson.decode json == Just posting --- True -newtype Posting a o (s :: Nat) = Posting (NE.NonEmpty (Event o s, Account a)) - deriving (Eq, Generic, Ord, Show) - deriving (FromJSON, ToJSON) - via Vanilla (Posting a o s) - - -postingEvents :: (KnownNat s) => Posting a o s -> [o] -postingEvents (Posting es) = eventObject . fst <$> NE.toList es - - -post :: (KnownNat s) => Posting a o s -> [(Account a, Entry o s)] -post (Posting xs) = go (NE.toList xs) - where - go [] = [] - go ((ev, ac) : ys) = (ac, buildEntry ev (accountKind ac)) : go ys diff --git a/src/Haspara/Accounting/Types.hs b/src/Haspara/Accounting/Types.hs deleted file mode 100644 index 7ba2982..0000000 --- a/src/Haspara/Accounting/Types.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Haspara.Accounting.Types where - -import Haspara.Quantity (Quantity) -import Refined (NonNegative, Refined) - - -type UnsignedQuantity s = Refined NonNegative (Quantity s) diff --git a/src/Haspara/Internal/Aeson.hs b/src/Haspara/Internal/Aeson.hs new file mode 100644 index 0000000..46ddc54 --- /dev/null +++ b/src/Haspara/Internal/Aeson.hs @@ -0,0 +1,14 @@ +-- | This module provides helper definitions for "Data.Aeson". + +module Haspara.Internal.Aeson where + +import qualified Data.Char as C +import qualified Deriving.Aeson as DA + + +-- | Type definition for string modifiers that uppercase a given symbol. +data UpperCase + + +instance DA.StringModifier UpperCase where + getStringModifier = fmap C.toUpper diff --git a/src/Haspara/Quantity.hs b/src/Haspara/Quantity.hs index 65ade72..2d0c5ac 100644 --- a/src/Haspara/Quantity.hs +++ b/src/Haspara/Quantity.hs @@ -17,6 +17,7 @@ import GHC.Generics (Generic) import GHC.TypeLits (KnownNat, Nat, natVal, type (+)) import qualified Language.Haskell.TH.Syntax as TH import qualified Numeric.Decimal as D +import Refined (NonNegative, Refined) -- * Data Definition @@ -58,6 +59,10 @@ newtype Quantity (s :: Nat) = MkQuantity { unQuantity :: D.Decimal D.RoundHalfEv deriving (Eq, Ord, Generic, Num) +-- | Type definition for unsigned 'Quantity' values. +type UnsignedQuantity s = Refined NonNegative (Quantity s) + + -- | Orphan 'TH.Lift' instance for 'Quantity'. -- -- TODO: Avoid having an orphan instance for @Decimal r s p@? From 8f91714e371a84ccdc1044593091134949be2597 Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Thu, 3 Mar 2022 09:50:27 +0800 Subject: [PATCH 12/14] chore(dev): add HLint configuration --- .hlint.yaml | 38 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 38 insertions(+) create mode 100644 .hlint.yaml diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000..d45e371 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,38 @@ +############################ +# HLint Configuration File # +############################ + +# See https://github.com/ndmitchell/hlint + +####################### +# MODULE RESTRICTIONS # +####################### + +- modules: + - {name: Control.Monad.Error, within: []} + - {name: [Data.Aeson], as: Aeson} + - {name: Data.ByteString, as: B } + - {name: Data.ByteString.Char8, as: BC } + - {name: Data.ByteString.Lazy, as: BL } + - {name: Data.ByteString.Lazy.Char8, as: BLC } + - {name: Data.Text, as: T } + - {name: Data.Text.Lazy, as: TL } + - {name: Data.Text.Encoding, as: TE } + +########################## +# EXTENSION RESTRICTIONS # +########################## + +- extensions: + - default: false # All extension are banned by default + - name: [DataKinds, DerivingVia] # Only these listed extensions can be used + +################ +# CUSTOM RULES # +################ + +# Replace a $ b $ c with a . b $ c +- group: {name: dollar, enabled: true} + +# Generalise map to fmap, ++ to <> +- group: {name: generalise, enabled: true} From 5644a6ac04d125904108cb8f529ba704cbc96bd2 Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Thu, 3 Mar 2022 09:50:57 +0800 Subject: [PATCH 13/14] chore(dev): add Weeder configuration --- stack.yaml | 2 +- weeder.dhall | 4 ++++ 2 files changed, 5 insertions(+), 1 deletion(-) create mode 100644 weeder.dhall diff --git a/stack.yaml b/stack.yaml index 908ea0c..184432e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -2,4 +2,4 @@ resolver: lts-18.27 packages: - . ghc-options: - "$locals": -fwrite-ide-info -hiedir=.hie + "$locals": -fwrite-ide-info diff --git a/weeder.dhall b/weeder.dhall new file mode 100644 index 0000000..5c0f38f --- /dev/null +++ b/weeder.dhall @@ -0,0 +1,4 @@ +{ roots = + [ "^Haspara.Accounting\$", "^Haspara.TH\$", "^Main.main\$", "^Paths_.*" ] +, type-class-roots = True +} From 7a6832c6f72c415b15a10865c7a8ffbd2d46239b Mon Sep 17 00:00:00 2001 From: Vehbi Sinan Tunalioglu Date: Thu, 3 Mar 2022 10:04:46 +0800 Subject: [PATCH 14/14] chore(docs): update README.md, fix haddock warnings --- README.md | 114 +++++++++++++++++++++++++++++++++++++++++++++- src/Haspara.hs | 5 ++ src/Haspara/TH.hs | 2 +- 3 files changed, 118 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index 9cf8ef9..b83d463 100644 --- a/README.md +++ b/README.md @@ -10,8 +10,118 @@ > reach the first minor version. Until then, we will keep bumping the patch > version. -*haspara* is a Haskell library providing data definitions and functions to work -with monetary values. +*haspara* is a Haskell library that provides monetary definitions and a +rudimentary (and experimental) accounting functionality. + +## Development + +Before committing code to repository, reformat the code: + +```sh +stylish-haskell -i -r src/ +``` + +Compile the codebase, check warnings and errors: + +```sh +stack test +stack build +stack haddock +``` + +Run [hlint](https://github.com/ndmitchell/hlint): + +```sh +hlint src/ +``` + +Run [weeder](https://hackage.haskell.org/package/weeder): + +```sh +weeder --require-hs-files +``` + +## Making Releases + +1. Switch to `develop` branch: + + ```sh + git checkout develop + ``` + +1. Ensure that your development branch is up to date: + + ```sh + git pull + ``` + +1. Checkout `main` branch: + + ```sh + git checkout main + ``` + +1. Merge `develop` branch to `main`: + + ```sh + git merge --no-ff develop + ``` + +1. Update the `version` information in [package.yaml](./package.yaml) if + required and recompile the project to reflect the change on the `.cabal` + file: + + ```sh + stack build + ``` + +1. Update [CHANGELOG.md](./CHANGELOG.md) file: + + ```sh + git-chglog --next-tag -o CHANGELOG.md + ``` + +1. Commit, tag and push: + + ```sh + git commit -am "chore(release): " + git tag -a -m "Release " + git push --follow-tags origin main + ``` + +1. Release to Hackage as a candidate first and check the result: + + ```sh + stack upload --pvp-bounds both --candidate . + ``` + +1. If the candidate package release works fine, release to Hackage: + + ```sh + stack upload --pvp-bounds both . + ``` + +1. Checkout to `develop` and rebase onto `main`: + + ```sh + git checkout develop + git rebase main + ``` + +1. Update the `version` information in [package.yaml](./package.yaml) with the + upcoming version and recompile the project to reflect the change on the + `.cabal` file: + + ```sh + stack build + ``` + +1. Commit and push: + + ```sh + git commit -am "chore: bump development version to " + git push + ``` ## License diff --git a/src/Haspara.hs b/src/Haspara.hs index 825d898..882f7a2 100644 --- a/src/Haspara.hs +++ b/src/Haspara.hs @@ -1,3 +1,8 @@ +-- | This module provides high-level definitions of @haspara@ library. +-- +-- @haspara@ provides rudimentary (and experimental) accounting functionality, +-- too. These definitions can be found under "Haspara.Accounting" module. + module Haspara ( module Haspara.Currency , module Haspara.FxQuote diff --git a/src/Haspara/TH.hs b/src/Haspara/TH.hs index 67bac94..cf2e4ed 100644 --- a/src/Haspara/TH.hs +++ b/src/Haspara/TH.hs @@ -1,4 +1,4 @@ --- | This module provides template-haskell functions for various 'Haspara.Core.Base' +-- | This module provides template-haskell functions for various "Haspara" -- definitions. module Haspara.TH where