diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2016-2017, Renzo Carbonara +Copyright (c) 2016-2018, Renzo Carbonara All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,5 +2,5 @@ operations for monetary values in all world currencies, including fiat currencies, precious metals and crypto-currencies. -You can enter a development shell with `nix-shell`, or build with `nix-build -./release.nix -A ghc822.safe-money` (or similar, check `release.nix`). +You can enter a development shell with `nix-shell`, or build with `nix build +-f release.nix ghc822.safe-money` (or similar, check `release.nix`). diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,47 @@ +# Version 0.5 + +* _COMPILER ASSISTED BREAKING CHANGE_. The `round`, `floor`, `ceiling` and + `truncate` functions were replaced by a single `discreteFromDense` function + taking an argument of type `Approximation` (`Round`, `Floor`, `Ceiling` or + `Truncate`) as an argument. + +* _COMPILER ASSISTED BREAKING CHANGE_. The `fromDiscrete` function was + renamed to `denseFromDiscrete`. + +* _COMPILER ASSISTED BREAKING CHANGE_. The `fromExchangeRate` function was + renamed to `exchangeRateToRational`. + +* _COMPILER ASSISTED BREAKING CHANGE_. The `flipExchangeRate` function was + renamed to `exchangeRateRecip`. + +* _COMPILER ASSISTED BREAKING CHANGE_. The `Dense` is not an instance of + `Fractional` anymore because `recip` and `/` could potentially crash. + +* Introduced new functions for rendering and parsing decimal reperesentations + of monetary amounts: `denseCurrency`, `discreteCurrency`, `denseFromDecimal`, + `denseToDecimal`, `discreteFromDecimal`, `exchangeRateFromDecimal`, + `exchangeRateToDecimal`. + +* Introduced optional `AdditiveGroup` and `VectorSpace` group instances for + `Dense` and `Discrete`. These type-classes come from the `vector-space` + library and they can be enabled or disabled via the `vector-space` Cabal flag, + which is enabled by default. + +* Introduced `discrete` constructor which behaves just like `fromInteger`. + +* Introduced the `dense'` constructor as an unsafe but convenient version of + `dense`. + +* The `ErrScaleNonCanonical` type is now exported. + +* The `Money.Internal` module is now exposed, but hidden from the Haddock + documentation. + +* New scale: `"BTC" "millibitcoin"`. + +* Added many tests. + + # Version 0.4.1 * `ExchangeRate` is now a `Category`. @@ -5,26 +49,25 @@ # Version 0.4 -* BREAKING CHANGE. COMPILER WON'T COMPLAIN. HUMAN INTERVENTION POTENTIALLY - REQUIRED. The JSON serializations for all of `Dense`, `SomeDense`, `Discrete`, - `SomeDiscrete`, `ExchangeRate` and `SomeExchangeRate` changed. The `FromJSON` - instances are backwards compatible with the old serializations, but the - `ToJSON` instances will only generate the new format, which is the same as the - old format except the leading strings `"Dense"`, `"Discrete"` and - `"ExchangeRate"`, respectively, are not present in the rendered JSON array - anymore. So, if you were manually relying on the `ToJSON` instance, please - update your code. +* **BREAKING CHANGE REQUIRING HUMAN INTERVENTION**. The JSON serializations for + all of `Dense`, `SomeDense`, `Discrete`, `SomeDiscrete`, `ExchangeRate` and + `SomeExchangeRate` changed. The `FromJSON` instances are backwards compatible + with the old serializations, but the `ToJSON` instances will only generate the + new format, which is the same as the old format except the leading strings + `"Dense"`, `"Discrete"` and `"ExchangeRate"`, respectively, are not present in + the rendered JSON array anymore. So, if you were manually relying on the + `ToJSON` instance, please update your code. -* BREAKING CHANGE. COMPILER WILL COMPLAIN: Changed the `Rep` suffix for a `Some` +* _COMPILER ASSISTED BREAKING CHANGE_. Changed the `Rep` suffix for a `Some` prefix Everywhere. For example, `DenseRep` was renamed to `SomeDense`. -* BREAKING CHANGE. COMPILER WILL COMPLAIN: Replaced the +* _COMPILER ASSISTED BREAKING CHANGE_. Replaced the `someDenseAmountNumerator` and `someDenseAmountDenominator` `Integers` with a single `someDenseAmount` `Rational` number. Similarly for `someDiscreteScale` and `someExchangeRateRate`. The `mkSomeDense`, `someDiscreteScale` and `mkSomeDense` also take a `Rational` now. -* BREAKING CHANGE. COMPILER WILL COMPLAIN: The `truncate`, `floor`, `celing` and +* _COMPILER ASSISTED BREAKING CHANGE_. The `truncate`, `floor`, `celing` and `round` functions now return just `0` as a reminder if there's no significant reminder, instead of `Nothing`. @@ -40,18 +83,22 @@ # Version 0.3 -* BREAKING CHANGE: The `Data.Money` module was renamed to `Money`. +* _COMPILER ASSISTED BREAKING CHANGE_. The `Data.Money` module was renamed to + `Money`. -* BREAKING CHANGE: The `Data.Money.Internal` module is not exposed anymore. All - of its contents are now exported from the `Money` module. +* _COMPILER ASSISTED BREAKING CHANGE_. The `Data.Money.Internal` module is not + exposed anymore. All of its contents are now exported from the `Money` module. -* BREAKING CHANGE: Renamed `discreteRep` to `toDiscreteRep`. +* _COMPILER ASSISTED BREAKING CHANGE_. Renamed `discreteRep` to + `toDiscreteRep`. -* BREAKING CHANGE: Renamed `denseRep` to `toDenseRep`. +* _COMPILER ASSISTED BREAKING CHANGE_. Renamed `denseRep` to `toDenseRep`. -* BREAKING CHANGE: Renamed `exchangeRateRep` to `toExchangeRateRep`. +* _COMPILER ASSISTED BREAKING CHANGE_. Renamed `exchangeRateRep` to + `toExchangeRateRep`. -* BREAKING CHANGE: Renamed Iceleandic currency `"eyir"` to `"eyrir"` +* _COMPILER ASSISTED BREAKING CHANGE_. Renamed Iceleandic currency `"eyir"` to + `"eyrir"` * Remove upper bound constraints from all dependencies except `base`. diff --git a/safe-money.cabal b/safe-money.cabal --- a/safe-money.cabal +++ b/safe-money.cabal @@ -1,8 +1,8 @@ name: safe-money -version: 0.4.1 +version: 0.5 license: BSD3 license-file: LICENSE -copyright: Copyright (c) Renzo Carbonara 2016-2017 +copyright: Copyright (c) Renzo Carbonara 2016-2018 author: Renzo Carbonara maintainer: renλren!zone stability: Experimental @@ -33,9 +33,10 @@ default-language: Haskell2010 hs-source-dirs: src ghc-options: -Wall -O2 - exposed-modules: Money - other-modules: Money.Internal build-depends: base (>=4.8 && <5.0), constraints + exposed-modules: + Money + Money.Internal if flag(aeson) build-depends: aeson (>=0.9) @@ -58,6 +59,9 @@ if (flag(store) && !impl(ghcjs)) build-depends: store (>=0.2) cpp-options: -DHAS_store + if flag(vector-space) + build-depends: vector-space (>=0.12) + cpp-options: -DHAS_vector_space if flag(xmlbf) build-depends: xmlbf (>=0.2), text cpp-options: -DHAS_xmlbf @@ -97,6 +101,9 @@ if (flag(store) && !impl(ghcjs)) build-depends: store cpp-options: -DHAS_store + if flag(vector-space) + build-depends: vector-space + cpp-options: -DHAS_vector_space if flag(xmlbf) build-depends: xmlbf, text cpp-options: -DHAS_xmlbf @@ -127,6 +134,10 @@ manual: True flag serialise description: Provide instances for @serialise@ + default: True + manual: True +flag vector-space + description: Provide instances for @vector-space@ default: True manual: True flag xmlbf diff --git a/src/Money.hs b/src/Money.hs --- a/src/Money.hs +++ b/src/Money.hs @@ -17,29 +17,39 @@ -- -- This module offers plenty of documentation, but for a deep explanation of -- how all of the pieces fit together, please read --- https://ren.zone/articles/safe-money +-- . Notice, however, that this library +-- has changed a bit since that article was written. You can always see the +-- [change log](https://github.com/k0001/safe-money/blob/master/changelog.md) to +-- understand what has changed. module Money ( -- * Dense monetary values I.Dense + , I.denseCurrency , I.dense + , I.dense' + , I.denseFromDiscrete + , I.denseFromDecimal + , I.denseToDecimal -- * Discrete monetary values , I.Discrete , I.Discrete' - , I.fromDiscrete - , I.round - , I.ceiling - , I.floor - , I.truncate + , I.discrete + , I.discreteCurrency + , I.discreteFromDense + , I.discreteFromDecimal -- * Currency scales , I.Scale , I.GoodScale + , I.ErrScaleNonCanonical , I.scale -- * Currency exchange , I.ExchangeRate , I.exchangeRate - , I.fromExchangeRate - , I.flipExchangeRate , I.exchange + , I.exchangeRateRecip + , I.exchangeRateFromDecimal + , I.exchangeRateToDecimal + , I.exchangeRateToRational -- * Serializable representations , I.SomeDense , I.toSomeDense @@ -64,6 +74,8 @@ , I.someExchangeRateSrcCurrency , I.someExchangeRateDstCurrency , I.someExchangeRateRate + -- * Misc + , I.Approximation(Round, Floor, Ceiling, Truncate) ) where import qualified Money.Internal as I @@ -768,6 +780,7 @@ -- | Bitcoin type instance I.Scale "BTC" "BTC" = '(100000000, 1) type instance I.Scale "BTC" "bitcoin" = '(1, 1) +type instance I.Scale "BTC" "millibitcoin" = '(1000, 1) type instance I.Scale "BTC" "satoshi" = '(100000000, 1) -- | Bitcoin diff --git a/src/Money/Internal.hs b/src/Money/Internal.hs --- a/src/Money/Internal.hs +++ b/src/Money/Internal.hs @@ -4,1536 +4,1906 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -#if MIN_VERSION_base(4,9,0) -{-# OPTIONS_GHC -Wno-redundant-constraints #-} -#endif - --- | This is an internal module. Import "Money" instead. -module Money.Internal - ( -- * Dense monetary values - Dense - , dense - -- * Discrete monetary values - , Discrete - , Discrete' - , fromDiscrete - , round - , ceiling - , floor - , truncate - -- * Currency scales - , Scale - , GoodScale - , ErrScaleNonCanonical - , scale - -- * Currency exchange - , ExchangeRate - , exchangeRate - , fromExchangeRate - , flipExchangeRate - , exchange - -- * Serializable representations - , SomeDense - , toSomeDense - , mkSomeDense - , fromSomeDense - , withSomeDense - , someDenseCurrency - , someDenseAmount - , SomeDiscrete - , toSomeDiscrete - , mkSomeDiscrete - , fromSomeDiscrete - , withSomeDiscrete - , someDiscreteCurrency - , someDiscreteScale - , someDiscreteAmount - , SomeExchangeRate - , toSomeExchangeRate - , mkSomeExchangeRate - , fromSomeExchangeRate - , withSomeExchangeRate - , someExchangeRateSrcCurrency - , someExchangeRateDstCurrency - , someExchangeRateRate - ) where - -import Control.Applicative ((<|>), empty) -import Control.Category (Category((.), id)) -import Control.Monad ((<=<), guard, when) -import Data.Constraint (Dict(Dict)) -import Data.Monoid ((<>)) -import Data.Proxy (Proxy(..)) -import Data.Ratio ((%), numerator, denominator) -import GHC.Exts (fromList) -import qualified GHC.Generics as GHC -import GHC.Real (infinity, notANumber) -import GHC.TypeLits - (Symbol, SomeSymbol(..), Nat, SomeNat(..), CmpNat, KnownSymbol, KnownNat, - natVal, someNatVal, symbolVal, someSymbolVal) -import Prelude hiding ((.), round, ceiling, floor, truncate) -import qualified Prelude -import qualified Text.ParserCombinators.ReadPrec as ReadPrec -import qualified Text.ParserCombinators.ReadP as ReadP -import qualified Text.Read as Read -import Unsafe.Coerce (unsafeCoerce) - -#ifdef HAS_aeson -import qualified Data.Aeson as Ae -#endif - -#ifdef HAS_binary -import qualified Data.Binary as Binary -#endif - -#ifdef HAS_cereal -import qualified Data.Serialize as Cereal -#endif - -#ifdef HAS_deepseq -import Control.DeepSeq (NFData) -#endif - -#ifdef HAS_hashable -import Data.Hashable (Hashable) -#endif - -#ifdef HAS_serialise -import qualified Codec.Serialise as Ser -#endif - -#ifdef HAS_store -import qualified Data.Store as Store -#endif - -#ifdef HAS_xmlbf -import qualified Xmlbf -import qualified Data.Text as Text -#endif - -#if MIN_VERSION_base(4,9,0) -import qualified GHC.TypeLits as GHC -#endif - --------------------------------------------------------------------------------- --- | 'Dense' represents a dense monetary value for @currency@ (usually a --- ISO-4217 currency code, but not necessarily) as a rational number. --- --- While monetary values associated with a particular currency are discrete, you --- can still treat monetary values as dense while operating on them. For --- example, the half of @USD 3.41@ is @USD 1.705@, which is not an amount that --- can't be represented as a number of USD cents (the smallest unit that can --- represent USD amounts). Nevertheless, if you eventually multiply @USD 1.705@ --- by @4@, for example, you end up with @USD 6.82@, which is again a value --- representable as USD cents. In other words, 'Dense' monetary values --- allow us to perform precise calculations deferring the conversion to a --- 'Discrete' monetary values as much as posible. Once you are ready to --- aproximate a 'Dense' value to a 'Discrete' value you can use one of --- 'round', 'floor', 'ceiling' or 'truncate'. Otherwise, using 'toRational' you --- can obtain a precise 'Rational' representation. --- --- Construct 'Dense' monetary values using 'dense', 'fromRational', --- 'fromInteger' or 'fromIntegral'. --- --- /WARNING/ if you want to treat a dense monetary value as a /Real/ number (for --- example, to take the square root of that monetary value), then you are on --- your own. We can only guarantee lossless manipulation of rational values, so --- you will need to convert back and forth betwen the 'Rational' representation --- for 'Dense' and your (likely lossy) representation for /Real/ numbers. -newtype Dense (currency :: Symbol) = Dense Rational - deriving (Eq, Ord, Num, Real, GHC.Generic) - --- | /WARNING/ if there exists the possibility that the given 'Rational' has a --- zero as a denominator, which although unlikely, is possible if the 'Rational' --- is constructed unsafely using 'GHC.Real.infinity' or 'GHC.Real.notANumber' --- for example, then use 'dense' instead of 'fromRational'. -deriving instance Fractional (Dense (currency :: Symbol)) - -instance forall currency. KnownSymbol currency => Show (Dense currency) where - showsPrec n = \(Dense r0) -> - let c = symbolVal (Proxy :: Proxy currency) - in showParen (n > 10) $ - showString "Dense " . showsPrec 0 c . showChar ' ' . - showsPrec 0 (numerator r0) . showChar '%' . - showsPrec 0 (denominator r0) - -instance forall currency. KnownSymbol currency => Read (Dense currency) where - readPrec = Read.parens $ do - let c = symbolVal (Proxy :: Proxy currency) - _ <- ReadPrec.lift (ReadP.string ("Dense " ++ show c ++ " ")) - maybe empty pure =<< fmap dense Read.readPrec - --- | Build a 'Dense' monetary value from a 'Rational' value. --- --- For example, if you want to represent @USD 12.52316@, then you can use: --- --- @ --- 'dense' (125316 % 10000) --- @ --- --- Returns 'Nothing' in case the denominator of the given 'Rational' is zero, --- which although unlikely, is possible if the 'Rational' is constructed --- unsafely using 'GHC.Real.infinity' or 'GHC.Real.notANumber', for example. --- If you don't care about that scenario, you can use `fromRational` to build --- the `Dense` value. -dense :: Rational -> Maybe (Dense currency) -dense = \r0 -> if (denominator r0 == 0) then Nothing else Just (Dense r0) -{-# INLINABLE dense #-} - --- | 'Discrete' represents a discrete monetary value for a @currency@ expresed --- as an integer amount of a particular @unit@. For example, with @currency ~ --- \"USD\"@ and @unit ~ \"cent\"@ you can represent United States Dollars to --- their full extent. --- --- @currency@ is usually a ISO-4217 currency code, but not necessarily. --- --- Construct 'Discrete' values using 'fromInteger'. --- --- For example, if you want to represent @GBP 21.05@, where the smallest --- represetable unit for a GBP (United Kingdom Pound) is the /penny/, and 100 --- /pennies/ equal 1 GBP (i.e., @'Scale' \"GBP\" ~ '(100, 1)@), then you can --- use: --- --- @ --- 'fromInteger' 2105 :: Discrete \"GBP\" \"penny\" --- @ --- --- Because @2015 / 100 == 20.15@. -type Discrete (currency :: Symbol) (unit :: Symbol) - = Discrete' currency (Scale currency unit) - --- | 'Discrete'' represents a discrete monetary value for a @currency@ expresed --- as an amount of @scale@, which is a rational number expressed as @(numerator, --- denominator)@. --- --- You'll be using 'Discrete' instead of 'Discrete'' most of the time, which --- mentions the unit name (such as /cent/ or /centavo/) instead of explicitely --- mentioning the unit scale. -newtype Discrete' (currency :: Symbol) (scale :: (Nat, Nat)) - = Discrete Integer - -deriving instance GoodScale scale => Eq (Discrete' currency scale) -deriving instance GoodScale scale => Ord (Discrete' currency scale) -deriving instance GoodScale scale => Enum (Discrete' currency scale) -deriving instance GoodScale scale => Num (Discrete' currency scale) -deriving instance GoodScale scale => Real (Discrete' currency scale) -deriving instance GoodScale scale => Integral (Discrete' currency scale) -deriving instance GoodScale scale => GHC.Generic (Discrete' currency scale) - -instance forall currency scale. - ( KnownSymbol currency, GoodScale scale - ) => Show (Discrete' currency scale) where - showsPrec n = \d0@(Discrete i0) -> - let c = symbolVal (Proxy :: Proxy currency) - s = scale d0 - in showParen (n > 10) $ - showString "Discrete " . showsPrec 0 c . showChar ' ' . - showsPrec 0 (numerator s) . showChar '%' . - showsPrec 0 (denominator s) . showChar ' ' . - showsPrec 0 i0 - -instance forall currency scale. - ( KnownSymbol currency, GoodScale scale - ) => Read (Discrete' currency scale) where - readPrec = Read.parens $ do - let c = symbolVal (Proxy :: Proxy currency) - s = scale (Proxy :: Proxy scale) - _ <- ReadPrec.lift (ReadP.string (concat - [ "Discrete ", show c, " " - , show (numerator s), "%" - , show (denominator s), " " - ])) - Discrete <$> Read.readPrec - -#if MIN_VERSION_base(4,9,0) -instance - ( GHC.TypeError - (('GHC.Text "The ") 'GHC.:<>: - ('GHC.ShowType Discrete') 'GHC.:<>: - ('GHC.Text " type is deliberately not a ") 'GHC.:<>: - ('GHC.ShowType Fractional) 'GHC.:$$: - ('GHC.Text "instance. Convert the ") 'GHC.:<>: - ('GHC.ShowType Discrete') 'GHC.:<>: - ('GHC.Text " value to a ") 'GHC.:<>: - ('GHC.ShowType Dense) 'GHC.:$$: - ('GHC.Text "value and use the ") 'GHC.:<>: - ('GHC.ShowType Fractional) 'GHC.:<>: - ('GHC.Text " features on it instead.")) - , GoodScale scale - ) => Fractional (Discrete' currency scale) where - fromRational = undefined - recip = undefined -#endif - --- | Convert currency 'Discrete' monetary value into a 'Dense' monetary --- value. -fromDiscrete - :: GoodScale scale - => Discrete' currency scale - -> Dense currency -- ^ -fromDiscrete = \c@(Discrete i) -> Dense (fromInteger i / scale c) -{-# INLINABLE fromDiscrete #-} - --- | Internal. Used to implement 'round', 'ceiling', 'floor' and 'truncate'. -roundf - :: forall currency scale - . GoodScale scale - => (Rational -> Integer) -- ^ 'Prelude.round', 'Prelude.ceiling' or similar. - -> Dense currency - -> (Discrete' currency scale, Dense currency) -roundf f = \c0 -> - let !r0 = toRational c0 :: Rational - !r1 = scale (Proxy :: Proxy scale) - !i2 = f (r0 * r1) :: Integer - !r2 = fromInteger i2 / r1 :: Rational - !d2 = Discrete i2 - !rest = Dense (r0 - r2) - in (d2, rest) -{-# INLINABLE roundf #-} - --- | Round a 'Dense' value @x@ to the nearest value fully representable in --- its @currency@'s @unit@ 'Scale', which might be @x@ itself. --- --- If @x@ is already fully representable in its @currency@'s @unit@ 'Scale', --- then the following holds: --- --- @ --- 'round' x == ('fromDiscrete' x, 0) --- @ --- --- Otherwise, if the nearest value to @x@ that is fully representable in its --- @currency@'s @unit@ 'Scale' is greater than @x@, then the following holds: --- --- @ --- 'round' == 'ceiling' --- @ --- --- Otherwise, the nearest value to @x@ that is fully representable in its --- @currency@'s @unit@ 'Scale' is smaller than @x@, and the following holds: --- --- @ --- 'round' == 'floor' --- @ --- --- Proof that 'round' doesn't lose money: --- --- @ --- x == case 'round' x of (y, z) -> 'fromDiscrete' y + z --- @ -round - :: GoodScale scale - => Dense currency - -> (Discrete' currency scale, Dense currency) -- ^ -round = roundf Prelude.round -{-# INLINABLE round #-} - --- | Round a 'Dense' value @x@ to the nearest value fully representable in --- its @currency@'s @unit@ 'Scale' which is greater than @x@ or equal to @x@. --- --- --- If @x@ is already fully representable in its @currency@'s @unit@ 'Scale', --- then the following holds: --- --- @ --- 'ceiling' x == ('fromDiscrete' x, 0) --- @ --- --- Otherwise, if @x@ is not representable in its @currency@'s @unit@ 'Scale', --- then the following holds: --- --- @ --- 'ceiling' x == (y, z) --- @ --- --- @ --- x /= y --- @ --- --- @ --- z < 0 --- @ --- --- Proof that 'ceiling' doesn't lose money: --- --- @ --- x == case 'ceiling' x of (y, z) -> 'fromDiscrete' y + z --- @ -ceiling - :: GoodScale scale - => Dense currency - -> (Discrete' currency scale, Dense currency) -- ^ -ceiling = roundf Prelude.ceiling -{-# INLINABLE ceiling #-} - --- | Round a 'Dense' value @x@ to the nearest value fully representable in --- its @currency@'s @unit@ 'Scale' which is smaller than @x@ or equal to @x@. --- --- --- If @x@ is already fully representable in its @currency@'s @unit@ 'Scale', --- then the following holds: --- --- @ --- 'floor' x == ('fromDiscrete' x, 0) --- @ --- --- Otherwise, if @x@ is not representable in its @currency@'s @unit@ 'Scale', --- then the following holds: --- --- @ --- 'floor' x == (y, z) --- @ --- --- @ --- x /= y --- @ --- --- @ --- z > 0 --- @ --- --- Proof that 'floor' doesn't lose money: --- --- @ --- x == case 'floor' x of (y, z) -> 'fromDiscrete' y + z --- @ -floor - :: GoodScale scale - => Dense currency - -> (Discrete' currency scale, Dense currency) -- ^ -floor = roundf Prelude.floor -{-# INLINABLE floor #-} - --- | Round a 'Dense' value @x@ to the nearest value between zero and --- @x@ (inclusive) which is fully representable in its @currency@'s @unit@ --- 'Scale'. --- --- If @x@ is already fully representable in its @currency@'s @unit@ 'Scale', --- then the following holds: --- --- @ --- 'truncate' x == ('fromDiscrete' x, 0) --- @ --- --- Otherwise, if @x@ is positive, then the following holds: --- --- @ --- 'truncate' == 'floor' --- @ --- --- Otherwise, if @x@ is negative, the following holds: --- --- @ --- 'truncate' == 'ceiling' --- @ --- --- Proof that 'truncate' doesn't lose money: --- --- @ --- x == case 'truncate' x of (y, z) -> 'fromDiscrete' y + z --- @ -truncate - :: GoodScale scale - => Dense currency - -> (Discrete' currency scale, Dense currency) -- ^ -truncate = roundf Prelude.truncate -{-# INLINABLE truncate #-} - --------------------------------------------------------------------------------- - --- | @'Scale' currency unit@ is a rational number (expressed as @'(numerator, --- denominator)@) indicating how many pieces of @unit@ fit in @currency@. --- --- @currency@ is usually a ISO-4217 currency code, but not necessarily. --- --- The 'Scale' will determine how to convert a 'Dense' value into a --- 'Discrete' value and vice-versa. --- --- For example, there are 100 USD cents in 1 USD, so the scale for this --- relationship is: --- --- @ --- type instance 'Scale' \"USD\" \"cent\" = '(100, 1) --- @ --- --- As another example, there is 1 dollar in USD, so the scale for this --- relationship is: --- --- @ --- type instance 'Scale' \"USD\" \"dollar\" = '(1, 1) --- @ --- --- When using 'Discrete' values to represent money, it will be impossible to --- represent an amount of @currency@ smaller than @unit@. So, if you decide to --- use @Scale \"USD\" \"dollar\"@ as your scale, you will not be able to --- represent values such as USD 3.50 or USD 21.87, since they are not exact --- multiples of a dollar. --- --- If there exists a canonical smallest @unit@ that can fully represent the --- currency, then an instance @'Scale' currency currency@ exists. --- --- @ --- type instance 'Scale' \"USD\" \"USD\" = Scale \"USD\" \"cent\" --- @ --- --- For some monetary values, such as precious metals, the smallest representable --- unit is not obvious, since you can continue to split the precious metal many --- times before it stops being a precious metal. Still, for practical purposes --- we can make a sane arbitrary choice of smallest unit. For example, the base --- unit for XAU (Gold) is the /troy ounce/, which is too big to be considered --- the smallest unit, but we can arbitrarily choose the /milligrain/ as our --- smallest unit, which is about as heavy as a single grain of table salt and --- should be sufficiently precise for all monetary practical purposes. A /troy --- ounce/ equals 480000 /milligrains/. --- --- @ --- type instance 'Scale' \"XAG\" \"milligrain\" = '(480000, 1) --- @ --- --- You can use other units such as /milligrams/ for measuring XAU, for example. --- However, since the amount of /milligrams/ in a /troy ounce/ (31103.477) is --- not integral, we need to use rational number to express it. --- --- @ --- type instance 'Scale' \"XAU\" \"milligram\" = '(31103477, 1000) --- @ --- --- If you try to obtain the 'Scale of a @currency@ without an obvious smallest --- representable @unit@, like XAU, you will get a compile error. -type family Scale (currency :: Symbol) (unit :: Symbol) :: (Nat, Nat) - -#if MIN_VERSION_base(4,9,0) --- | A friendly 'GHC.TypeError' to use for a @currency@ that doesn't have a --- canonical small unit. -type family ErrScaleNonCanonical (currency :: Symbol) :: k where - ErrScaleNonCanonical c = GHC.TypeError - ( 'GHC.Text c 'GHC.:<>: - 'GHC.Text " is not a currency with a canonical smallest unit," 'GHC.:$$: - 'GHC.Text "be explicit about the currency unit you want to use." ) -#else --- | Forbid a @currency@ that doesn't have a canonical small unit. --- --- In GHC versions before 8.0 we can't provide a nice error message here, so we --- simply set this to a value that will fail to satisfy 'GoodScale'. As a --- consequence, trying to use this 'Scale' will result in a cryptic error saying --- /«@Couldn't match type ‘'EQ’ with ‘'LT’@»/. -type ErrScaleNonCanonical (currency :: Symbol) = '(0, 0) -#endif - --- | Constraints to a scale (like the one returned by @'Scale' currency unit@) --- expected to always be satisfied. In particular, the scale is always --- guaranteed to be a positive rational number ('infinity' and 'notANumber' are --- forbidden by 'GoodScale'). -type GoodScale (scale :: (Nat, Nat)) - = ( CmpNat 0 (Fst scale) ~ 'LT - , CmpNat 0 (Snd scale) ~ 'LT - , KnownNat (Fst scale) - , KnownNat (Snd scale) - ) - --- | If the specified @num@ and @den@ satisfy the expectations of 'GoodScale' at --- the type level, then construct a proof for 'GoodScale'. -mkGoodScale - :: forall num den - . (KnownNat num, KnownNat den) - => Maybe (Dict (GoodScale '(num, den))) -mkGoodScale = - let n = natVal (Proxy :: Proxy num) - d = natVal (Proxy :: Proxy den) - in if (n > 0) && (d > 0) - then Just (unsafeCoerce (Dict :: Dict ('LT ~ 'LT, 'LT ~ 'LT, - KnownNat num, KnownNat den))) - else Nothing -{-# INLINABLE mkGoodScale #-} - --- | Term-level representation for the @currency@'s @unit@ 'Scale'. --- --- For example, the 'Scale' for @\"USD\"@ in @\"cent\"@s is @100/1@. --- --- The returned 'Rational' is statically guaranteed to be a positive number, and --- to be different from both 'notANumber' and 'infinity'. -scale :: forall proxy scale. GoodScale scale => proxy scale -> Rational -- ^ -scale = \_ -> - natVal (Proxy :: Proxy (Fst scale)) % - natVal (Proxy :: Proxy (Snd scale)) -{-# INLINABLE scale #-} - --------------------------------------------------------------------------------- - --- | Exchange rate for converting monetary values of currency @src@ into --- monetary values of currency @dst@ by multiplying for it. --- --- For example, if in order to convert USD to GBP we have to multiply by 1.2345, --- then we can represent this situaion using: --- --- @ --- 'exchangeRate' (12345 % 10000) :: 'Maybe' ('ExchangeRate' \"USD\" \"GBP\") --- @ -newtype ExchangeRate (src :: Symbol) (dst :: Symbol) = ExchangeRate Rational - deriving (Eq, Ord, GHC.Generic) - - --- | Composition of 'ExchangeRate's multiplies exchange rates together: --- --- @ --- 'fromExchangeRate' x * 'fromExchangeRate' y == 'fromExchangeRate' (x . y) --- @ --- --- Identity: --- --- @ --- x == x . id == id . x --- @ --- --- Associativity: --- --- @ --- x . y . z == x . (y . z) == (x . y) . z --- @ --- --- Conmutativity (provided the types allow for composition): --- --- @ --- x . y == y . x --- @ --- --- Multiplicative inverse: --- --- @ --- 1 == 'fromExchangeRate' (x . 'flipExchangeRate' x) --- @ -instance Category ExchangeRate where - id = ExchangeRate 1 - {-# INLINE id #-} - ExchangeRate a . ExchangeRate b = ExchangeRate (a * b) - {-# INLINE (.) #-} - -instance forall src dst. - ( KnownSymbol src, KnownSymbol dst - ) => Show (ExchangeRate src dst) where - showsPrec n = \(ExchangeRate r0) -> - let s = symbolVal (Proxy :: Proxy src) - d = symbolVal (Proxy :: Proxy dst) - in showParen (n > 10) $ - showString "ExchangeRate " . showsPrec 0 s . showChar ' ' . - showsPrec 0 d . showChar ' ' . - showsPrec 0 (numerator r0) . showChar '%' . - showsPrec 0 (denominator r0) - -instance forall src dst. - ( KnownSymbol src, KnownSymbol dst - ) => Read (ExchangeRate (src :: Symbol) (dst :: Symbol)) where - readPrec = Read.parens $ do - let s = symbolVal (Proxy :: Proxy src) - d = symbolVal (Proxy :: Proxy dst) - _ <- ReadPrec.lift (ReadP.string - ("ExchangeRate " ++ show s ++ " " ++ show d ++ " ")) - maybe empty pure =<< fmap exchangeRate Read.readPrec - --- | Obtain a 'Rational' representation of the 'ExchangeRate'. --- --- This 'Rational' is statically guaranteed to be greater than 0, different --- from 'infinity' and different from 'notANumber'. -fromExchangeRate :: ExchangeRate src dst -> Rational -fromExchangeRate = \(ExchangeRate r0) -> r0 -{-# INLINABLE fromExchangeRate #-} - --- | Safely construct an 'ExchangeRate' from a 'Rational' number. --- --- For construction to succeed, this 'Rational' must be greater than 0, --- different from 'infinity' and different from 'notANumber'. -exchangeRate :: Rational -> Maybe (ExchangeRate src dst) -exchangeRate = \r0 -> - if (r0 <= 0 || infinity == r0 || notANumber == r0) - then Nothing else Just (ExchangeRate r0) -{-# INLINABLE exchangeRate #-} - --- | Flip the direction of an 'ExchangeRate'. --- --- This function retuns the multiplicative inverse of the given 'ExchangeRate', --- leading to the following identity law: --- --- @ --- 'flipExchangeRate' . 'flipExchangeRate' == 'id' --- @ -flipExchangeRate :: ExchangeRate a b -> ExchangeRate b a -flipExchangeRate = \(ExchangeRate x) -> ExchangeRate (1 / x) -{-# INLINABLE flipExchangeRate #-} - --- | Apply the 'ExchangeRate' to the given @'Dense' src@ monetary value. --- --- Identity law: --- --- @ --- 'exchange' ('flipExchangeRate' x) . 'exchange' x == 'id' --- @ --- --- Use the /Identity law/ for reasoning about going back and forth between @src@ --- and @dst@ in order to manage any leftovers that might not be representable as --- a 'Discrete' monetary value of @src@. -exchange :: ExchangeRate src dst -> Dense src -> Dense dst -exchange = \(ExchangeRate r) -> \(Dense s) -> Dense (r * s) -{-# INLINABLE exchange #-} - --------------------------------------------------------------------------------- --- SomeDense - --- | A monomorphic representation of 'Dense' that is easier to serialize and --- deserialize than 'Dense' in case you don't know the type indexes involved. --- --- If you are trying to construct a value of this type from some raw input, then --- you will need to use the 'mkSomeDense' function. --- --- In order to be able to effectively serialize a 'SomeDense' value, you --- need to serialize the following three values (which are the eventual --- arguments to 'mkSomeDense'): --- --- * 'someDenseCurrency' --- * 'someDenseAmount' -data SomeDense = SomeDense - { _someDenseCurrency :: !String - , _someDenseAmount :: !Rational - } deriving (Eq, Show, GHC.Generic) - --- | WARNING: This instance does not compare monetary amounts, it just helps you --- sort 'SomeDense' values in case you need to put them in a 'Data.Set.Set' or --- similar. -deriving instance Ord SomeDense - --- | Currency name. -someDenseCurrency :: SomeDense -> String -someDenseCurrency = _someDenseCurrency -{-# INLINABLE someDenseCurrency #-} - --- | Currency unit amount. -someDenseAmount :: SomeDense -> Rational -someDenseAmount = _someDenseAmount -{-# INLINABLE someDenseAmount #-} - --- | Build a 'SomeDense' from raw values. --- --- This function is intended for deserialization purposes. You need to convert --- this 'SomeDense' value to a 'Dense' value in order to do any arithmetic --- operation on the monetary value. -mkSomeDense - :: String -- ^ Currency. ('someDenseCurrency') - -> Rational -- ^ Scale. ('someDenseAmount') - -> Maybe SomeDense -mkSomeDense = \c r -> do - guard (denominator r /= 0) - Just (SomeDense c r) -{-# INLINABLE mkSomeDense #-} - --- | Convert a 'Dense' to a 'SomeDense' for ease of serialization. -toSomeDense :: KnownSymbol currency => Dense currency -> SomeDense -toSomeDense = \(Dense r0 :: Dense currency) -> - let c = symbolVal (Proxy :: Proxy currency) - in SomeDense c r0 -{-# INLINABLE toSomeDense #-} - --- | Attempt to convert a 'SomeDense' to a 'Dense', provided you know the target --- @currency@. -fromSomeDense - :: forall currency - . KnownSymbol currency - => SomeDense - -> Maybe (Dense currency) -- ^ -fromSomeDense = \dr -> do - guard (someDenseCurrency dr == symbolVal (Proxy :: Proxy currency)) - Just (Dense (someDenseAmount dr)) -{-# INLINABLE fromSomeDense #-} - --- | Convert a 'SomeDense' to a 'Dense' without knowing the target @currency@. --- --- Notice that @currency@ here can't leave its intended scope unless you can --- prove equality with some other type at the outer scope, but in that case you --- would be better off using 'fromSomeDense' directly. -withSomeDense - :: SomeDense - -> (forall currency. KnownSymbol currency => Dense currency -> r) - -> r -- ^ -withSomeDense dr = \f -> - case someSymbolVal (someDenseCurrency dr) of - SomeSymbol (Proxy :: Proxy currency) -> - f (Dense (someDenseAmount dr) :: Dense currency) -{-# INLINABLE withSomeDense #-} - --------------------------------------------------------------------------------- --- SomeDiscrete - --- | A monomorphic representation of 'Discrete' that is easier to serialize and --- deserialize than 'Discrete' in case you don't know the type indexes involved. --- --- If you are trying to construct a value of this type from some raw input, then --- you will need to use the 'mkSomeDiscrete' function. --- --- In order to be able to effectively serialize a 'SomeDiscrete' value, you need --- to serialize the following four values (which are the eventual arguments to --- 'mkSomeDiscrete'): --- --- * 'someDiscreteCurrency' --- * 'someDiscreteScale' --- * 'someDiscreteAmount' -data SomeDiscrete = SomeDiscrete - { _someDiscreteCurrency :: !String -- ^ Currency name. - , _someDiscreteScale :: !Rational -- ^ Positive, non-zero. - , _someDiscreteAmount :: !Integer -- ^ Amount of unit. - } deriving (Eq, Show, GHC.Generic) - --- | WARNING: This instance does not compare monetary amounts, it just helps you --- sort 'SomeDiscrete' values in case you need to put them in a 'Data.Set.Set' or --- similar. -deriving instance Ord SomeDiscrete - --- | Currency name. -someDiscreteCurrency :: SomeDiscrete -> String -someDiscreteCurrency = _someDiscreteCurrency -{-# INLINABLE someDiscreteCurrency #-} - --- | Positive, non-zero. -someDiscreteScale :: SomeDiscrete -> Rational -someDiscreteScale = _someDiscreteScale -{-# INLINABLE someDiscreteScale #-} - --- | Amount of currency unit. -someDiscreteAmount :: SomeDiscrete -> Integer -someDiscreteAmount = _someDiscreteAmount -{-# INLINABLE someDiscreteAmount #-} - --- | Internal. Build a 'SomeDiscrete' from raw values. --- --- This function is intended for deserialization purposes. You need to convert --- this 'SomeDiscrete' value to a 'Discrete' vallue in order to do any arithmetic --- operation on the monetary value. -mkSomeDiscrete - :: String -- ^ Currency name. ('someDiscreteCurrency') - -> Rational -- ^ Scale. Positive, non-zero. ('someDiscreteScale') - -> Integer -- ^ Amount of unit. ('someDiscreteAmount') - -> Maybe SomeDiscrete -mkSomeDiscrete = \c r a -> do - guard (denominator r /= 0) - guard (r > 0) - Just (SomeDiscrete c r a) -{-# INLINABLE mkSomeDiscrete #-} - --- | Convert a 'Discrete' to a 'SomeDiscrete' for ease of serialization. -toSomeDiscrete - :: (KnownSymbol currency, GoodScale scale) - => Discrete' currency scale - -> SomeDiscrete -- ^ -toSomeDiscrete = \(Discrete i0 :: Discrete' currency scale) -> - let c = symbolVal (Proxy :: Proxy currency) - n = natVal (Proxy :: Proxy (Fst scale)) - d = natVal (Proxy :: Proxy (Snd scale)) - in SomeDiscrete c (n % d) i0 -{-# INLINABLE toSomeDiscrete #-} - --- | Attempt to convert a 'SomeDiscrete' to a 'Discrete', provided you know the --- target @currency@ and @unit@. -fromSomeDiscrete - :: forall currency scale - . (KnownSymbol currency, GoodScale scale) - => SomeDiscrete - -> Maybe (Discrete' currency scale) -- ^ -fromSomeDiscrete = \dr -> - if (someDiscreteCurrency dr == symbolVal (Proxy :: Proxy currency)) && - (someDiscreteScale dr == scale (Proxy :: Proxy scale)) - then Just (Discrete (someDiscreteAmount dr)) - else Nothing -{-# INLINABLE fromSomeDiscrete #-} - --- | Convert a 'SomeDiscrete' to a 'Discrete' without knowing the target --- @currency@ and @unit@. --- --- Notice that @currency@ and @unit@ here can't leave its intended scope unless --- you can prove equality with some other type at the outer scope, but in that --- case you would be better off using 'fromSomeDiscrete' directly. --- --- Notice that you may need to add an explicit type to the result of this --- function in order to keep the compiler happy. -withSomeDiscrete - :: forall r - . SomeDiscrete - -> ( forall currency scale. - ( KnownSymbol currency - , GoodScale scale - ) => Discrete' currency scale - -> r ) - -> r -- ^ -withSomeDiscrete dr = \f -> - case someSymbolVal (someDiscreteCurrency dr) of - SomeSymbol (Proxy :: Proxy currency) -> - case someNatVal (numerator (someDiscreteScale dr)) of - Nothing -> error "withSomeDiscrete: impossible: numerator < 0" - Just (SomeNat (Proxy :: Proxy num)) -> - case someNatVal (denominator (someDiscreteScale dr)) of - Nothing -> error "withSomeDiscrete: impossible: denominator < 0" - Just (SomeNat (Proxy :: Proxy den)) -> - case mkGoodScale of - Nothing -> error "withSomeDiscrete: impossible: mkGoodScale" - Just (Dict :: Dict (GoodScale '(num, den))) -> - f (Discrete (someDiscreteAmount dr) - :: Discrete' currency '(num, den)) -{-# INLINABLE withSomeDiscrete #-} - --------------------------------------------------------------------------------- --- SomeExchangeRate - --- | A monomorphic representation of 'ExchangeRate' that is easier to serialize --- and deserialize than 'ExchangeRate' in case you don't know the type indexes --- involved. --- --- If you are trying to construct a value of this type from some raw input, then --- you will need to use the 'mkSomeExchangeRate' function. --- --- In order to be able to effectively serialize an 'SomeExchangeRate' value, you --- need to serialize the following four values (which are the eventual arguments --- to 'mkSomeExchangeRate'): --- --- * 'someExchangeRateSrcCurrency' --- * 'someExchangeRateDstCurrency' --- * 'someExchangeRateRate' -data SomeExchangeRate = SomeExchangeRate - { _someExchangeRateSrcCurrency :: !String - , _someExchangeRateDstCurrency :: !String - , _someExchangeRateRate :: !Rational -- ^ Positive, non-zero. - } deriving (Eq, Show, GHC.Generic) - --- | WARNING: This instance does not compare monetary amounts, it just helps you --- sort 'SomeExchangeRate' values in case you need to put them in a --- 'Data.Set.Set' or similar. -deriving instance Ord SomeExchangeRate - --- | Source currency name. -someExchangeRateSrcCurrency :: SomeExchangeRate -> String -someExchangeRateSrcCurrency = _someExchangeRateSrcCurrency -{-# INLINABLE someExchangeRateSrcCurrency #-} - --- | Destination currency name. -someExchangeRateDstCurrency :: SomeExchangeRate -> String -someExchangeRateDstCurrency = _someExchangeRateDstCurrency -{-# INLINABLE someExchangeRateDstCurrency #-} - --- | Exchange rate. Positive, non-zero. -someExchangeRateRate :: SomeExchangeRate -> Rational -someExchangeRateRate = _someExchangeRateRate -{-# INLINABLE someExchangeRateRate #-} - --- | Internal. Build a 'SomeExchangeRate' from raw values. --- --- This function is intended for deserialization purposes. You need to convert --- this 'SomeExchangeRate' value to a 'ExchangeRate' value in order to do any --- arithmetic operation with the exchange rate. -mkSomeExchangeRate - :: String -- ^ Source currency name. ('someExchangeRateSrcCurrency') - -> String -- ^ Destination currency name. ('someExchangeRateDstCurrency') - -> Rational -- ^ Exchange rate . Positive, non-zero. ('someExchangeRateRate') - -> Maybe SomeExchangeRate -mkSomeExchangeRate = \src dst r -> do - guard (denominator r /= 0) - guard (r > 0) - Just (SomeExchangeRate src dst r) -{-# INLINABLE mkSomeExchangeRate #-} - --- | Convert a 'ExchangeRate' to a 'SomeDiscrete' for ease of serialization. -toSomeExchangeRate - :: (KnownSymbol src, KnownSymbol dst) - => ExchangeRate src dst - -> SomeExchangeRate -- ^ -toSomeExchangeRate = \(ExchangeRate r0 :: ExchangeRate src dst) -> - let src = symbolVal (Proxy :: Proxy src) - dst = symbolVal (Proxy :: Proxy dst) - in SomeExchangeRate src dst r0 -{-# INLINABLE toSomeExchangeRate #-} - --- | Attempt to convert a 'SomeExchangeRate' to a 'ExchangeRate', provided you --- know the target @src@ and @dst@ types. -fromSomeExchangeRate - :: forall src dst - . (KnownSymbol src, KnownSymbol dst) - => SomeExchangeRate - -> Maybe (ExchangeRate src dst) -- ^ -fromSomeExchangeRate = \x -> - if (someExchangeRateSrcCurrency x == symbolVal (Proxy :: Proxy src)) && - (someExchangeRateDstCurrency x == symbolVal (Proxy :: Proxy dst)) - then Just (ExchangeRate (someExchangeRateRate x)) - else Nothing -{-# INLINABLE fromSomeExchangeRate #-} - --- | Convert a 'SomeExchangeRate' to a 'ExchangeRate' without knowing the target --- @currency@ and @unit@. --- --- Notice that @src@ and @dst@ here can't leave its intended scope unless --- you can prove equality with some other type at the outer scope, but in that --- case you would be better off using 'fromSomeExchangeRate' directly. -withSomeExchangeRate - :: SomeExchangeRate - -> ( forall src dst. - ( KnownSymbol src - , KnownSymbol dst - ) => ExchangeRate src dst - -> r ) - -> r -- ^ -withSomeExchangeRate x = \f -> - case someSymbolVal (someExchangeRateSrcCurrency x) of - SomeSymbol (Proxy :: Proxy src) -> - case someSymbolVal (someExchangeRateDstCurrency x) of - SomeSymbol (Proxy :: Proxy dst) -> - f (ExchangeRate (someExchangeRateRate x) :: ExchangeRate src dst) -{-# INLINABLE withSomeExchangeRate #-} - --------------------------------------------------------------------------------- --- Miscellaneous - -type family Fst (ab :: (ka, kb)) :: ka where Fst '(a,b) = a -type family Snd (ab :: (ka, kb)) :: ka where Snd '(a,b) = b - --------------------------------------------------------------------------------- --- Extra instances: hashable -#ifdef HAS_hashable -instance Hashable (Dense currency) -instance Hashable SomeDense -instance GoodScale scale => Hashable (Discrete' currency scale) -instance Hashable SomeDiscrete -instance Hashable (ExchangeRate src dst) -instance Hashable SomeExchangeRate -#endif - --------------------------------------------------------------------------------- --- Extra instances: deepseq -#ifdef HAS_deepseq -instance NFData (Dense currency) -instance NFData SomeDense -instance GoodScale scale => NFData (Discrete' currency scale) -instance NFData SomeDiscrete -instance NFData (ExchangeRate src dst) -instance NFData SomeExchangeRate -#endif - --------------------------------------------------------------------------------- --- Extra instances: cereal -#ifdef HAS_cereal --- | Compatible with 'SomeDense'. -instance (KnownSymbol currency) => Cereal.Serialize (Dense currency) where - put = Cereal.put . toSomeDense - get = maybe empty pure =<< fmap fromSomeDense Cereal.get - --- | Compatible with 'SomeDiscrete'. -instance - ( KnownSymbol currency, GoodScale scale - ) => Cereal.Serialize (Discrete' currency scale) where - put = Cereal.put . toSomeDiscrete - get = maybe empty pure =<< fmap fromSomeDiscrete Cereal.get - --- | Compatible with 'SomeExchangeRate'. -instance - ( KnownSymbol src, KnownSymbol dst - ) => Cereal.Serialize (ExchangeRate src dst) where - put = Cereal.put . toSomeExchangeRate - get = maybe empty pure =<< fmap fromSomeExchangeRate Cereal.get - --- | Compatible with 'Dense'. -instance Cereal.Serialize SomeDense where - put = \(SomeDense c r) -> do - Cereal.put c - Cereal.put (numerator r) - Cereal.put (denominator r) - get = maybe empty pure =<< do - c :: String <- Cereal.get - n :: Integer <- Cereal.get - d :: Integer <- Cereal.get - when (d == 0) (fail "denominator is zero") - pure (mkSomeDense c (n % d)) - --- | Compatible with 'Discrete'. -instance Cereal.Serialize SomeDiscrete where - put = \(SomeDiscrete c r a) -> do - Cereal.put c - Cereal.put (numerator r) - Cereal.put (denominator r) - Cereal.put a - get = maybe empty pure =<< do - c :: String <- Cereal.get - n :: Integer <- Cereal.get - d :: Integer <- Cereal.get - when (d == 0) (fail "denominator is zero") - a :: Integer <- Cereal.get - pure (mkSomeDiscrete c (n % d) a) - --- | Compatible with 'ExchangeRate'. -instance Cereal.Serialize SomeExchangeRate where - put = \(SomeExchangeRate src dst r) -> do - Cereal.put src - Cereal.put dst - Cereal.put (numerator r) - Cereal.put (denominator r) - get = maybe empty pure =<< do - src :: String <- Cereal.get - dst :: String <- Cereal.get - n :: Integer <- Cereal.get - d :: Integer <- Cereal.get - when (d == 0) (fail "denominator is zero") - pure (mkSomeExchangeRate src dst (n % d)) -#endif - ------------------------------------------------------------------------------- --- Extra instances: binary -#ifdef HAS_binary --- | Compatible with 'SomeDense'. -instance (KnownSymbol currency) => Binary.Binary (Dense currency) where - put = Binary.put . toSomeDense - get = maybe empty pure =<< fmap fromSomeDense Binary.get - --- | Compatible with 'SomeDiscrete'. -instance - ( KnownSymbol currency, GoodScale scale - ) => Binary.Binary (Discrete' currency scale) where - put = Binary.put . toSomeDiscrete - get = maybe empty pure =<< fmap fromSomeDiscrete Binary.get - --- | Compatible with 'SomeExchangeRate'. -instance - ( KnownSymbol src, KnownSymbol dst - ) => Binary.Binary (ExchangeRate src dst) where - put = Binary.put . toSomeExchangeRate - get = maybe empty pure =<< fmap fromSomeExchangeRate Binary.get - --- | Compatible with 'Dense'. -instance Binary.Binary SomeDense where - put = \(SomeDense c r) -> - Binary.put c >> Binary.put (numerator r) >> Binary.put (denominator r) - get = maybe empty pure =<< do - c :: String <- Binary.get - n :: Integer <- Binary.get - d :: Integer <- Binary.get - when (d == 0) (fail "denominator is zero") - pure (mkSomeDense c (n % d)) - --- | Compatible with 'Discrete'. -instance Binary.Binary SomeDiscrete where - put = \(SomeDiscrete c r a) -> - Binary.put c <> - Binary.put (numerator r) <> - Binary.put (denominator r) <> - Binary.put a - get = maybe empty pure =<< do - c :: String <- Binary.get - n :: Integer <- Binary.get - d :: Integer <- Binary.get - when (d == 0) (fail "denominator is zero") - a :: Integer <- Binary.get - pure (mkSomeDiscrete c (n % d) a) - --- | Compatible with 'ExchangeRate'. -instance Binary.Binary SomeExchangeRate where - put = \(SomeExchangeRate src dst r) -> do - Binary.put src - Binary.put dst - Binary.put (numerator r) - Binary.put (denominator r) - get = maybe empty pure =<< do - src :: String <- Binary.get - dst :: String <- Binary.get - n :: Integer <- Binary.get - d :: Integer <- Binary.get - when (d == 0) (fail "denominator is zero") - pure (mkSomeExchangeRate src dst (n % d)) -#endif - --------------------------------------------------------------------------------- --- Extra instances: serialise -#ifdef HAS_serialise --- | Compatible with 'SomeDense'. -instance (KnownSymbol currency) => Ser.Serialise (Dense currency) where - encode = Ser.encode . toSomeDense - decode = maybe (fail "Dense") pure =<< fmap fromSomeDense Ser.decode - --- | Compatible with 'SomeDiscrete'. -instance - ( KnownSymbol currency, GoodScale scale - ) => Ser.Serialise (Discrete' currency scale) where - encode = Ser.encode . toSomeDiscrete - decode = maybe (fail "Discrete'") pure =<< fmap fromSomeDiscrete Ser.decode - --- | Compatible with 'SomeExchangeRate'. -instance - ( KnownSymbol src, KnownSymbol dst - ) => Ser.Serialise (ExchangeRate src dst) where - encode = Ser.encode . toSomeExchangeRate - decode = maybe (fail "ExchangeRate") pure - =<< fmap fromSomeExchangeRate Ser.decode - --- | Compatible with 'Dense'. -instance Ser.Serialise SomeDense where - encode = \(SomeDense c r) -> - Ser.encode c <> Ser.encode (numerator r) <> Ser.encode (denominator r) - decode = maybe (fail "SomeDense") pure =<< do - c :: String <- Ser.decode - n :: Integer <- Ser.decode - d :: Integer <- Ser.decode - when (d == 0) (fail "denominator is zero") - pure (mkSomeDense c (n % d)) - --- | Compatible with 'Discrete'. -instance Ser.Serialise SomeDiscrete where - encode = \(SomeDiscrete c r a) -> - Ser.encode c <> - Ser.encode (numerator r) <> - Ser.encode (denominator r) <> - Ser.encode a - decode = maybe (fail "SomeDiscrete") pure =<< do - c :: String <- Ser.decode - n :: Integer <- Ser.decode - d :: Integer <- Ser.decode - when (d == 0) (fail "denominator is zero") - a :: Integer <- Ser.decode - pure (mkSomeDiscrete c (n % d) a) - --- | Compatible with 'ExchangeRate'. -instance Ser.Serialise SomeExchangeRate where - encode = \(SomeExchangeRate src dst r) -> - Ser.encode src <> - Ser.encode dst <> - Ser.encode (numerator r) <> - Ser.encode (denominator r) - decode = maybe (fail "SomeExchangeRate") pure =<< do - src :: String <- Ser.decode - dst :: String <- Ser.decode - n :: Integer <- Ser.decode - d :: Integer <- Ser.decode - when (d == 0) (fail "denominator is zero") - pure (mkSomeExchangeRate src dst (n % d)) -#endif - --------------------------------------------------------------------------------- --- Extra instances: aeson -#ifdef HAS_aeson --- | Compatible with 'SomeDense' --- --- Example rendering @'fromRational' (2 % 3) :: 'Dense' \"BTC\"@: --- --- @ --- [\"BTC\", 2, 3] --- @ --- --- Note: The JSON serialization changed in version 0.4 (the leading @"Dense"@ --- string was dropped from the rendered 'Ae.Array'). -instance KnownSymbol currency => Ae.ToJSON (Dense currency) where - toJSON = Ae.toJSON . toSomeDense - --- | Compatible with 'SomeDense' --- --- Note: The JSON serialization changed in version 0.4. However, this instance --- is still able to cope with the previous format. -instance KnownSymbol currency => Ae.FromJSON (Dense currency) where - parseJSON = maybe empty pure <=< fmap fromSomeDense . Ae.parseJSON - --- | Compatible with 'Dense' --- --- Note: The JSON serialization changed in version 0.4 (the leading @"Dense"@ --- string was dropped from the rendered 'Ae.Array'). -instance Ae.ToJSON SomeDense where - toJSON = \(SomeDense c r) -> - Ae.toJSON (c, numerator r, denominator r) - --- | Compatible with 'Dense'. --- --- Note: The JSON serialization changed in version 0.4. However, this instance --- is still able to cope with the previous format. -instance Ae.FromJSON SomeDense where - parseJSON = \v -> do - (c, n, d) <- Ae.parseJSON v <|> do - -- Pre 0.4 format. - ("Dense" :: String, c, n, d) <- Ae.parseJSON v - pure (c, n, d) - when (d == 0) (fail "denominator is zero") - maybe empty pure (mkSomeDense c (n % d)) - --- | Compatible with 'SomeDiscrete' --- --- Example rendering @43 :: 'Discrete' \"BTC\" \"satoshi\"@: --- --- @ --- [\"BTC\", 100000000, 1, 43] --- @ --- --- Note: The JSON serialization changed in version 0.4 (the leading @"Discrete"@ --- string was dropped from the rendered 'Ae.Array'). -instance - ( KnownSymbol currency, GoodScale scale - ) => Ae.ToJSON (Discrete' currency scale) where - toJSON = Ae.toJSON . toSomeDiscrete - --- | Compatible with 'SomeDiscrete' --- --- Note: The JSON serialization changed in version 0.4. However, this instance --- is still able to cope with the previous format. -instance - ( KnownSymbol currency, GoodScale scale - ) => Ae.FromJSON (Discrete' currency scale) where - parseJSON = maybe empty pure <=< fmap fromSomeDiscrete . Ae.parseJSON - --- | Compatible with 'Discrete'' --- --- Note: The JSON serialization changed in version 0.4 (the leading @"Discrete"@ --- string was dropped from the rendered 'Ae.Array'). -instance Ae.ToJSON SomeDiscrete where - toJSON = \(SomeDiscrete c r a) -> - Ae.toJSON (c, numerator r, denominator r, a) - --- | Compatible with 'Discrete'' --- --- Note: The JSON serialization changed in version 0.4. However, this instance --- is still able to cope with the previous format. -instance Ae.FromJSON SomeDiscrete where - parseJSON = \v -> do - (c, n, d, a) <- Ae.parseJSON v <|> do - -- Pre 0.4 format. - ("Discrete" :: String, c, n, d, a) <- Ae.parseJSON v - pure (c, n, d, a) - when (d == 0) (fail "denominator is zero") - maybe empty pure (mkSomeDiscrete c (n % d) a) - --- | Compatible with 'SomeExchangeRate' --- --- Example rendering an 'ExchangeRate' constructed with --- @'exchangeRate' (5 % 7) :: 'Maybe' ('ExchangeRate' \"USD\" \"JPY\")@ --- --- @ --- [\"USD\", \"JPY\", 5, 7] --- @ --- --- Note: The JSON serialization changed in version 0.4 (the leading --- @"ExchangeRate"@ string was dropped from the rendered 'Ae.Array'). -instance - ( KnownSymbol src, KnownSymbol dst - ) => Ae.ToJSON (ExchangeRate src dst) where - toJSON = Ae.toJSON . toSomeExchangeRate - --- | Compatible with 'SomeExchangeRate' --- --- Note: The JSON serialization changed in version 0.4. However, this instance --- is still able to cope with the previous format. -instance - ( KnownSymbol src, KnownSymbol dst - ) => Ae.FromJSON (ExchangeRate src dst) where - parseJSON = maybe empty pure <=< fmap fromSomeExchangeRate . Ae.parseJSON - --- | Compatible with 'ExchangeRate' --- --- Note: The JSON serialization changed in version 0.4 (the leading --- @"ExchangeRate"@ string was dropped from the rendered 'Ae.Array'). -instance Ae.ToJSON SomeExchangeRate where - toJSON = \(SomeExchangeRate src dst r) -> - Ae.toJSON (src, dst, numerator r, denominator r) - --- | Compatible with 'ExchangeRate' --- --- Note: The JSON serialization changed in version 0.4. However, this instance --- is still able to cope with the previous format. -instance Ae.FromJSON SomeExchangeRate where - parseJSON = \v -> do - (src, dst, n, d) <- Ae.parseJSON v <|> do - -- Pre 0.4 format. - ("ExchangeRate" :: String, src, dst, n, d) <- Ae.parseJSON v - pure (src, dst, n, d) - when (d == 0) (fail "denominator is zero") - maybe empty pure (mkSomeExchangeRate src dst (n % d)) -#endif - --------------------------------------------------------------------------------- --- Extra instances: xmlbf -#ifdef HAS_xmlbf - --- | Compatible with 'SomeDense' --- --- Example rendering @'fromRational' (2 % 3) :: 'Dense' \"BTC\"@: --- --- @ --- \ --- @ -instance KnownSymbol currency => Xmlbf.ToXml (Dense currency) where - toXml = Xmlbf.toXml . toSomeDense - --- | Compatible with 'SomeDense' -instance KnownSymbol currency => Xmlbf.FromXml (Dense currency) where - fromXml = maybe empty pure =<< fmap fromSomeDense Xmlbf.fromXml - --- | Compatible with 'Dense' -instance Xmlbf.ToXml SomeDense where - toXml = \(SomeDense c r) -> - let as = [ (Text.pack "c", Text.pack c) - , (Text.pack "n", Text.pack (show (numerator r))) - , (Text.pack "d", Text.pack (show (denominator r))) ] - Right e = Xmlbf.element (Text.pack "money-dense") (fromList as) [] - in [e] - --- | Compatible with 'Dense'. -instance Xmlbf.FromXml SomeDense where - fromXml = Xmlbf.pElement (Text.pack "money-dense") $ do - c <- Text.unpack <$> Xmlbf.pAttr "c" - n <- Xmlbf.pRead =<< Xmlbf.pAttr "n" - d <- Xmlbf.pRead =<< Xmlbf.pAttr "d" - when (d == 0) (fail "denominator is zero") - maybe empty pure (mkSomeDense c (n % d)) - --- | Compatible with 'SomeDiscrete' --- --- Example rendering @43 :: 'Discrete' \"BTC\" \"satoshi\"@: --- --- @ --- \ --- @ -instance - ( KnownSymbol currency, GoodScale scale - ) => Xmlbf.ToXml (Discrete' currency scale) where - toXml = Xmlbf.toXml . toSomeDiscrete - --- | Compatible with 'SomeDiscrete' -instance - ( KnownSymbol currency, GoodScale scale - ) => Xmlbf.FromXml (Discrete' currency scale) where - fromXml = maybe empty pure =<< fmap fromSomeDiscrete Xmlbf.fromXml - --- | Compatible with 'Discrete'' -instance Xmlbf.ToXml SomeDiscrete where - toXml = \(SomeDiscrete c r a) -> - let as = [ (Text.pack "c", Text.pack c) - , (Text.pack "n", Text.pack (show (numerator r))) - , (Text.pack "d", Text.pack (show (denominator r))) - , (Text.pack "a", Text.pack (show a)) ] - Right e = Xmlbf.element (Text.pack "money-discrete") (fromList as) [] - in [e] - --- | Compatible with 'Discrete'' -instance Xmlbf.FromXml SomeDiscrete where - fromXml = Xmlbf.pElement (Text.pack "money-discrete") $ do - c <- Text.unpack <$> Xmlbf.pAttr "c" - n <- Xmlbf.pRead =<< Xmlbf.pAttr "n" - d <- Xmlbf.pRead =<< Xmlbf.pAttr "d" - when (d == 0) (fail "denominator is zero") - a <- Xmlbf.pRead =<< Xmlbf.pAttr "a" - maybe empty pure (mkSomeDiscrete c (n % d) a) - --- | Compatible with 'SomeExchangeRate' --- --- Example rendering an 'ExchangeRate' constructed with --- @'exchangeRate' (5 % 7) :: 'Maybe' ('ExchangeRate' \"USD\" \"JPY\")@ --- --- @ --- \ --- @ -instance - ( KnownSymbol src, KnownSymbol dst - ) => Xmlbf.ToXml (ExchangeRate src dst) where - toXml = Xmlbf.toXml . toSomeExchangeRate - --- | Compatible with 'SomeExchangeRate' -instance - ( KnownSymbol src, KnownSymbol dst - ) => Xmlbf.FromXml (ExchangeRate src dst) where - fromXml = maybe empty pure =<< fmap fromSomeExchangeRate Xmlbf.fromXml - --- | Compatible with 'ExchangeRate' -instance Xmlbf.ToXml SomeExchangeRate where - toXml = \(SomeExchangeRate src dst r) -> - let as = [ (Text.pack "src", Text.pack src) - , (Text.pack "dst", Text.pack dst) - , (Text.pack "n", Text.pack (show (numerator r))) - , (Text.pack "d", Text.pack (show (denominator r))) ] - Right e = Xmlbf.element (Text.pack "exchange-rate") (fromList as) [] - in [e] - --- | Compatible with 'ExchangeRate' -instance Xmlbf.FromXml SomeExchangeRate where - fromXml = Xmlbf.pElement (Text.pack "exchange-rate") $ do - src <- Text.unpack <$> Xmlbf.pAttr "src" - dst <- Text.unpack <$> Xmlbf.pAttr "dst" - n <- Xmlbf.pRead =<< Xmlbf.pAttr "n" - d <- Xmlbf.pRead =<< Xmlbf.pAttr "d" - when (d == 0) (fail "denominator is zero") - maybe empty pure (mkSomeExchangeRate src dst (n % d)) -#endif - --------------------------------------------------------------------------------- --- Extra instances: store -#ifdef HAS_store --- | Compatible with 'SomeDense'. -instance (KnownSymbol currency) => Store.Store (Dense currency) where - size = storeContramapSize toSomeDense Store.size - poke = Store.poke . toSomeDense - peek = maybe (fail "peek") pure =<< fmap fromSomeDense Store.peek --- | Compatible with 'Dense'. -instance Store.Store SomeDense where - poke = \(SomeDense c r) -> do - Store.poke c - Store.poke (numerator r) - Store.poke (denominator r) - peek = maybe (fail "peek") pure =<< do - c :: String <- Store.peek - n :: Integer <- Store.peek - d :: Integer <- Store.peek - when (d == 0) (fail "denominator is zero") - pure (mkSomeDense c (n % d)) - --- | Compatible with 'SomeDiscrete'. -instance - ( KnownSymbol currency, GoodScale scale - ) => Store.Store (Discrete' currency scale) where - size = storeContramapSize toSomeDiscrete Store.size - poke = Store.poke . toSomeDiscrete - peek = maybe (fail "peek") pure =<< fmap fromSomeDiscrete Store.peek --- | Compatible with 'Discrete''. -instance Store.Store SomeDiscrete where - poke = \(SomeDiscrete c r a) ->do - Store.poke c - Store.poke (numerator r) - Store.poke (denominator r) - Store.poke a - peek = maybe (fail "peek") pure =<< do - c :: String <- Store.peek - n :: Integer <- Store.peek - d :: Integer <- Store.peek - when (d == 0) (fail "denominator is zero") - a :: Integer <- Store.peek - pure (mkSomeDiscrete c (n % d) a) --- | Compatible with 'SomeExchangeRate'. -instance - ( KnownSymbol src, KnownSymbol dst - ) => Store.Store (ExchangeRate src dst) where - size = storeContramapSize toSomeExchangeRate Store.size - poke = Store.poke . toSomeExchangeRate - peek = maybe (fail "peek") pure =<< fmap fromSomeExchangeRate Store.peek --- | Compatible with 'ExchangeRate'. -instance Store.Store SomeExchangeRate where - poke = \(SomeExchangeRate src dst r) -> do - Store.poke src - Store.poke dst - Store.poke (numerator r) - Store.poke (denominator r) - peek = maybe (fail "peek") pure =<< do - src <- Store.peek - dst <- Store.peek - n <- Store.peek - d <- Store.peek - when (d == 0) (fail "denominator is zero") - pure (mkSomeExchangeRate src dst (n % d)) - -storeContramapSize :: (a -> b) -> Store.Size b -> Store.Size a -storeContramapSize f = \case - Store.VarSize g -> Store.VarSize (g . f) - Store.ConstSize x -> Store.ConstSize x -{-# INLINABLE storeContramapSize #-} -#endif +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_HADDOCK hide #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +-- | This is an internal module. You may use stuff exported from here, but we +-- can't garantee their stability. +module Money.Internal + ( -- * Dense monetary values + Dense + , denseCurrency + , dense + , dense' + , denseFromDiscrete + , denseFromDecimal + , denseToDecimal + -- * Discrete monetary values + , Discrete + , Discrete' + , discrete + , discreteCurrency + , discreteFromDense + , discreteFromDecimal + -- * Currency scales + , Scale + , GoodScale + , ErrScaleNonCanonical + , scale + -- * Currency exchange + , ExchangeRate + , exchangeRate + , exchange + , exchangeRateFromDecimal + , exchangeRateToDecimal + , exchangeRateToRational + , exchangeRateRecip + -- * Serializable representations + , SomeDense + , toSomeDense + , mkSomeDense + , fromSomeDense + , withSomeDense + , someDenseCurrency + , someDenseAmount + , SomeDiscrete + , toSomeDiscrete + , mkSomeDiscrete + , fromSomeDiscrete + , withSomeDiscrete + , someDiscreteCurrency + , someDiscreteScale + , someDiscreteAmount + , SomeExchangeRate + , toSomeExchangeRate + , mkSomeExchangeRate + , fromSomeExchangeRate + , withSomeExchangeRate + , someExchangeRateSrcCurrency + , someExchangeRateDstCurrency + , someExchangeRateRate + -- * Misc + , Approximation(Round, Floor, Ceiling, Truncate) + , rationalToDecimal + , rationalFromDecimal + ) where + +import Control.Applicative ((<|>), empty) +import Control.Category (Category((.), id)) +import Control.Monad ((<=<), guard, when) +import qualified Data.Char as Char +import Data.Constraint (Dict(Dict)) +import Data.Functor (($>)) +import Data.Foldable (for_) +import qualified Data.List as List +import Data.Monoid ((<>)) +import Data.Proxy (Proxy(..)) +import Data.Ratio ((%), numerator, denominator) +import Data.Word (Word8) +import GHC.Exts (Constraint, fromList) +import qualified GHC.Generics as GHC +import GHC.TypeLits + (Symbol, SomeSymbol(..), Nat, SomeNat(..), CmpNat, KnownSymbol, KnownNat, + natVal, someNatVal, symbolVal, someSymbolVal) +import qualified GHC.TypeLits as GHC +import Numeric.Natural (Natural) +import Prelude hiding ((.), id) +import qualified Text.ParserCombinators.ReadPrec as ReadPrec +import qualified Text.ParserCombinators.ReadP as ReadP +import qualified Text.Read as Read +import Unsafe.Coerce (unsafeCoerce) + +#ifdef HAS_aeson +import qualified Data.Aeson as Ae +import qualified Data.Text as T +#endif + +#ifdef HAS_binary +import qualified Data.Binary as Binary +#endif + +#ifdef HAS_cereal +import qualified Data.Serialize as Cereal +#endif + +#ifdef HAS_deepseq +import Control.DeepSeq (NFData) +#endif + +#ifdef HAS_hashable +import Data.Hashable (Hashable) +#endif + +#ifdef HAS_serialise +import qualified Codec.Serialise as Ser +#endif + +#ifdef HAS_store +import qualified Data.Store as Store +#endif + +#ifdef HAS_vector_space +import qualified Data.AdditiveGroup as AG +import qualified Data.VectorSpace as VS +#endif + +#ifdef HAS_xmlbf +import qualified Xmlbf +#endif + +-------------------------------------------------------------------------------- +-- | 'Dense' represents a dense monetary value for @currency@ (usually a +-- ISO-4217 currency code, but not necessarily) as a rational number. +-- +-- While monetary values associated with a particular currency are +-- discrete (e.g., an exact number of coins and bills), you can still treat +-- monetary values as dense while operating on them. For example, the half +-- of @USD 3.41@ is @USD 1.705@, which is not an amount that can't be +-- represented as a number of USD cents (the smallest unit that can +-- represent USD amounts). Nevertheless, if you do manage to represent @USD +-- 1.709@ somehow, and you eventually multiply @USD 1.705@ by @4@ for +-- example, then you end up with @USD 6.82@, which is again a value +-- representable as USD cents. In other words, 'Dense' monetary values +-- allow us to perform precise calculations deferring the conversion to a +-- 'Discrete' monetary values as much as posible. Once you are ready to +-- approximate a 'Dense' value to a 'Discrete' value you can use one +-- 'discreteFromDense'. Otherwise, using 'toRational' you can obtain a +-- precise 'Rational' representation. + +-- Construct 'Dense' monetary values using 'dense', 'dense'', +-- 'denseFromDiscrete', 'denseFromDecimal'. +-- +-- /WARNING/ if you want to treat a dense monetary value as a /Real/ number +-- like 'Float' or 'Double', then you are on your own. We can only +-- guarantee lossless manipulation of rational values, so you will need to +-- convert back and forth betwen the 'Rational' representation for 'Dense' +-- and your (likely lossy) representation for /Real/ numbers. +newtype Dense (currency :: Symbol) = Dense Rational + deriving (Eq, Ord, Real, GHC.Generic) + +-- | Notice that multiplication of 'Dense' values doesn't make sense: +-- +-- @ +-- ('*') :: 'Dense' currency -> 'Dense' currency -> 'Dense' currency +-- @ +-- +-- How is '*' implemented, then? It behaves as the /scalar multiplication/ of a +-- 'Dense' amount by a 'Rational' scalar. That is, you can think of '*' as +-- having one of the the following types: +-- +-- @ +-- ('*') :: 'Rational' -> 'Dense' currency -> 'Dense' currency +-- @ +-- +-- @ +-- ('*') :: 'Dense' currency -> 'Rational' -> 'Dense' currency@ +-- @ +-- +-- That is: +-- +-- @ +-- 'dense'' (1 '%' 4) '*' 'dense'' (1 '%' 2) == 'dense'' (1 '%' 8) +-- @ +-- +-- In fact, if you compiled this library with support for +-- 'Data.VectorSpace.VectorSpace', then '*' functions exactly as +-- 'Data.VectorSpace.*^'. +-- +-- @ +-- ('*') == ('Data.VectorSpace.*^') +-- @ +-- +-- @ +-- ('*') == 'flip' ('Data.VectorSpace.*^') +-- @ +deriving instance Num (Dense currency) + +type family ErrFractionalDense :: Constraint where + ErrFractionalDense + = GHC.TypeError + (('GHC.Text "The ") 'GHC.:<>: + ('GHC.ShowType Dense) 'GHC.:<>: + ('GHC.Text " type is deliberately not an instance of ") 'GHC.:<>: + ('GHC.ShowType Fractional) 'GHC.:$$: + ('GHC.Text "because functions like 'recip' and '/' can diverge.") 'GHC.:$$: + ('GHC.Text "Temporarily convert the ") 'GHC.:<>: + ('GHC.ShowType Dense) 'GHC.:<>: + ('GHC.Text " value to a ") 'GHC.:<>: + ('GHC.ShowType Rational) 'GHC.:$$: + ('GHC.Text " if you know what you are doing.")) + +instance ErrFractionalDense => Fractional (Dense currency) where + fromRational = undefined + recip = undefined + +-- | +-- @ +-- > 'show' ('dense'' (1 '%' 3) :: 'Dense' \"USD\") +-- \"Dense \\\"USD\\\" 1%3\" +-- @ +instance forall currency. KnownSymbol currency => Show (Dense currency) where + showsPrec n = \(Dense r0) -> + let c = symbolVal (Proxy :: Proxy currency) + in showParen (n > 10) $ + showString "Dense " . showsPrec 0 c . showChar ' ' . + showsPrec 0 (numerator r0) . showChar '%' . + showsPrec 0 (denominator r0) + +instance forall currency. KnownSymbol currency => Read (Dense currency) where + readPrec = Read.parens $ do + let c = symbolVal (Proxy :: Proxy currency) + _ <- ReadPrec.lift (ReadP.string ("Dense " ++ show c ++ " ")) + maybe empty pure =<< fmap dense Read.readPrec + +-- | Build a 'Dense' monetary value from a 'Rational' value. +-- +-- For example, if you want to represent @USD 12.52316@, then you can use: +-- +-- @ +-- 'dense' (125316 '%' 10000) +-- @ +-- +-- Notice that 'dense' returns 'Nothing' in case the given 'Rational''s +-- denominator is zero, which although unlikely, it is possible if the +-- 'Rational' was unsafely constructed. When dealing with hardcoded or trusted +-- 'Rational' values, you can use 'dense'' instead of 'dense' which unsafely +-- constructs a 'Dense'. +dense :: Rational -> Maybe (Dense currency) +dense = \r -> + if denominator r /= 0 + then Just (Dense r) + else Nothing +{-# INLINE dense #-} + +-- | Unsafely build a 'Dense' monetary value from a 'Rational' value. Contrary +-- to 'dense', this function *crashes* if the given 'Rational' has zero as a +-- denominator, which is something very unlikely to happen unless the given +-- 'Rational' was itself unsafely constructed. Other than that, 'dense' and +-- 'dense'' behave the same. +-- +-- Prefer to use 'dense' when dealing with 'Rational' inputs from untrusted +-- sources. +-- +-- @ +-- 'denominator' x /= 0 +-- ⇒ 'dense' x == 'Just' ('dense'' x) +-- @ +-- +-- @ +-- 'denominator' x == 0 +-- ⇒ 'undefined' == 'dense'' x +-- @ +dense' :: Rational -> Dense currency +dense' = \r -> + if denominator r /= 0 + then Dense r + else error "dense': malformed Rational given (denominator is zero)." +{-# INLINABLE dense' #-} + +-- | 'Dense' currency identifier. +-- +-- @ +-- > 'denseCurrency' ('dense'' 4 :: 'Dense' \"USD\") +-- \"USD\" +-- @ +denseCurrency :: KnownSymbol currency => Dense currency -> String +denseCurrency = symbolVal +{-# INLINE denseCurrency #-} + +-- | 'Discrete' represents a discrete monetary value for a @currency@ expresed +-- as an integer amount of a particular @unit@. For example, with @currency ~ +-- \"USD\"@ and @unit ~ \"cent\"@ you can represent United States Dollars to +-- their full extent. +-- +-- @currency@ is usually a ISO-4217 currency code, but not necessarily. +-- +-- Construct 'Discrete' values using 'discrete', 'fromIntegral', 'fromInteger', +-- 'discreteFromDense', 'discreteFromDecimal'. +-- +-- For example, if you want to represent @GBP 21.05@, where the smallest +-- represetable unit for a GBP (United Kingdom Pound) is the /penny/, and 100 +-- /pennies/ equal 1 GBP (i.e., @'Scale' \"GBP\" ~ '(100, 1)@), then you can +-- use: +-- +-- @ +-- 'discrete' 2105 :: 'Discrete' \"GBP\" \"penny\" +-- @ +-- +-- Because @2015 / 100 == 20.15@. +type Discrete (currency :: Symbol) (unit :: Symbol) + = Discrete' currency (Scale currency unit) + +-- | 'Discrete'' represents a discrete monetary value for a @currency@ expresed +-- as amount of @scale@, which is a rational number expressed as @(numerator, +-- denominator)@. +-- +-- You'll be using 'Discrete' instead of 'Discrete'' most of the time, which +-- mentions the unit name (such as /cent/ or /centavo/) instead of explicitely +-- mentioning the unit scale. +newtype Discrete' (currency :: Symbol) (scale :: (Nat, Nat)) + = Discrete Integer + +deriving instance GoodScale scale => Eq (Discrete' currency scale) +deriving instance GoodScale scale => Ord (Discrete' currency scale) +deriving instance GoodScale scale => Enum (Discrete' currency scale) +deriving instance GoodScale scale => Real (Discrete' currency scale) +deriving instance GoodScale scale => Integral (Discrete' currency scale) +deriving instance GoodScale scale => GHC.Generic (Discrete' currency scale) + +-- | Notice that multiplication of 'Discrete'' values doesn't make sense: +-- +-- @ +-- ('*') :: 'Discrete'' currency scale -> 'Discrete'' currency scale -> 'Discrete'' currency scale +-- @ +-- +-- How is '*' implemented, then? It behaves as the /scalar multiplication/ of a +-- 'Discrete'' amount by an 'Integer' scalar. That is, you can think of '*' as +-- having one of the the following types: +-- +-- @ +-- ('*') :: 'Integer' -> 'Discrete'' currency scale -> 'Discrete'' currency scale +-- @ +-- +-- @ +-- ('*') :: 'Discrete'' currency scale -> 'Integer' -> 'Discrete'' currency scale@ +-- @ +-- +-- That is: +-- +-- @ +-- 'discrete' 2 '*' 'discrete' 4 == 'discrete' 8 +-- @ +-- +-- In fact, if you compiled this library with support for +-- 'Data.VectorSpace.VectorSpace', then '*' functions exactly as +-- 'Data.VectorSpace.*^'. +-- +-- @ +-- ('*') == ('Data.VectorSpace.*^') +-- @ +-- +-- @ +-- ('*') == 'flip' ('Data.VectorSpace.*^') +-- @ +deriving instance GoodScale scale => Num (Discrete' currency scale) + +-- | +-- @ +-- > 'show' ('discrete' 123 :: 'Discrete' \"USD\" \"cent\") +-- \"Discrete \\\"USD\\\" 100%1 123\" +-- @ +instance forall currency scale. + ( KnownSymbol currency, GoodScale scale + ) => Show (Discrete' currency scale) where + showsPrec n = \d0@(Discrete i0) -> + let c = symbolVal (Proxy :: Proxy currency) + s = scale d0 + in showParen (n > 10) $ + showString "Discrete " . showsPrec 0 c . showChar ' ' . + showsPrec 0 (numerator s) . showChar '%' . + showsPrec 0 (denominator s) . showChar ' ' . + showsPrec 0 i0 + +instance forall currency scale. + ( KnownSymbol currency, GoodScale scale + ) => Read (Discrete' currency scale) where + readPrec = Read.parens $ do + let c = symbolVal (Proxy :: Proxy currency) + s = scale (Proxy :: Proxy scale) + _ <- ReadPrec.lift (ReadP.string (concat + [ "Discrete ", show c, " " + , show (numerator s), "%" + , show (denominator s), " " + ])) + fmap Discrete Read.readPrec + +type family ErrFractionalDiscrete :: Constraint where + ErrFractionalDiscrete + = GHC.TypeError + (('GHC.Text "The ") 'GHC.:<>: + ('GHC.ShowType Discrete') 'GHC.:<>: + ('GHC.Text " type is deliberately not a ") 'GHC.:<>: + ('GHC.ShowType Fractional) 'GHC.:$$: + ('GHC.Text "instance. Convert the ") 'GHC.:<>: + ('GHC.ShowType Discrete') 'GHC.:<>: + ('GHC.Text " value to a ") 'GHC.:<>: + ('GHC.ShowType Dense) 'GHC.:$$: + ('GHC.Text "value and use the ") 'GHC.:<>: + ('GHC.ShowType Fractional) 'GHC.:<>: + ('GHC.Text " features on it instead.")) + +instance + ( ErrFractionalDiscrete + , GoodScale scale + ) => Fractional (Discrete' currency scale) where + fromRational = undefined + recip = undefined + +-- | Construct a 'Discrete' value. +discrete :: GoodScale scale => Integer -> Discrete' currency scale +discrete = Discrete +{-# INLINE discrete #-} + + +-- | Convert currency 'Discrete' monetary value into a 'Dense' monetary +-- value. +denseFromDiscrete + :: GoodScale scale + => Discrete' currency scale + -> Dense currency -- ^ +denseFromDiscrete = \c@(Discrete i) -> Dense (fromInteger i / scale c) +{-# INLINE denseFromDiscrete #-} + +-- | 'Discrete' currency identifier. +-- +-- @ +-- > 'discreteCurrency' ('discrete' 4 :: 'Discrete' \"USD\" \"cent\") +-- \"USD\" +-- @ +discreteCurrency + :: forall currency scale + . (KnownSymbol currency, GoodScale scale) + => Discrete' currency scale + -> String -- ^ +discreteCurrency = \_ -> symbolVal (Proxy :: Proxy currency) +{-# INLINE discreteCurrency #-} + +-- | Method for approximating a fractional number to an integer number. +data Approximation + = Round + -- ^ Approximate @x@ to the nearest integer, or to the nearest even integer if + -- @x@ is equidistant between two integers. + | Floor + -- ^ Approximate @x@ to the nearest integer less than or equal to @x@. + | Ceiling + -- ^ Approximate @x@ to the nearest integer greater than or equal to @x@. + | Truncate + -- ^ Approximate @x@ to the nearest integer betwen @0@ and @x@, inclusive. + deriving (Eq, Ord, Show, Read, GHC.Generic) + + +approximate :: Approximation -> Rational -> Integer +{-# INLINE approximate #-} +approximate = \case + Round -> round + Floor -> floor + Ceiling -> ceiling + Truncate -> truncate + +-- | Approximate a 'Dense' value @x@ to the nearest value fully representable a +-- given @scale@. +-- +-- If the given 'Dense' doesn't fit entirely in the @scale@, then a non-zero +-- 'Dense' reminder is returned alongside the 'Discrete' approximation. +-- +-- Proof that 'discreteFromDense' doesn't lose money: +-- +-- @ +-- x == case 'discreteFromDense' a x of +-- (y, z) -> 'denseFromDiscrete' y + z +-- @ +discreteFromDense + :: forall currency scale + . GoodScale scale + => Approximation + -- ^ Approximation to use if necesary in order to fit the 'Dense' amount in + -- the requested @scale@. + -> Dense currency + -> (Discrete' currency scale, Dense currency) +discreteFromDense a = \c0 -> + let !r0 = toRational c0 :: Rational + !r1 = scale (Proxy :: Proxy scale) + !i2 = approximate a (r0 * r1) :: Integer + !r2 = fromInteger i2 / r1 :: Rational + !d2 = Discrete i2 + !rest = Dense (r0 - r2) + in (d2, rest) +{-# INLINABLE discreteFromDense #-} + +-------------------------------------------------------------------------------- + +-- | @'Scale' currency unit@ is an rational number (expressed as @'(numerator, +-- denominator)@) indicating how many pieces of @unit@ fit in @currency@. +-- +-- @currency@ is usually a ISO-4217 currency code, but not necessarily. +-- +-- The 'Scale' will determine how to convert a 'Dense' value into a +-- 'Discrete' value and vice-versa. +-- +-- For example, there are 100 USD cents in 1 USD, so the scale for this +-- relationship is: +-- +-- @ +-- type instance 'Scale' \"USD\" \"cent\" = '(100, 1) +-- @ +-- +-- As another example, there is 1 dollar in USD, so the scale for this +-- relationship is: +-- +-- @ +-- type instance 'Scale' \"USD\" \"dollar\" = '(1, 1) +-- @ +-- +-- When using 'Discrete' values to represent money, it will be impossible to +-- represent an amount of @currency@ smaller than @unit@. So, if you decide to +-- use @Scale \"USD\" \"dollar\"@ as your scale, you will not be able to +-- represent values such as USD 3.50 or USD 21.87 becacuse they are not exact +-- multiples of a dollar. +-- +-- If there exists a canonical smallest @unit@ that can fully represent the +-- currency in all its denominations, then an instance @'Scale' currency +-- currency@ exists. +-- +-- @ +-- type instance 'Scale' \"USD\" \"USD\" = 'Scale' \"USD\" \"cent\" +-- @ +-- +-- For some monetary values, such as precious metals, there is no smallest +-- representable unit, since you can repeatedly split the precious metal many +-- times before it stops being a precious metal. Nevertheless, for practical +-- purposes we can make a sane arbitrary choice of smallest unit. For example, +-- the base unit for XAU (Gold) is the /troy ounce/, which is too big to be +-- considered the smallest unit, but we can arbitrarily choose the /milligrain/ +-- as our smallest unit, which is about as heavy as a single grain of table salt +-- and should be sufficiently precise for all monetary practical purposes. A +-- /troy ounce/ equals 480000 /milligrains/. +-- +-- @ +-- type instance 'Scale' \"XAU\" \"milligrain\" = '(480000, 1) +-- @ +-- +-- You can use other units such as /milligrams/ for measuring XAU, for example. +-- However, since the amount of /milligrams/ in a /troy ounce/ (31103.477) is +-- not integral, we need to use rational with a denominator different than 1 to +-- express it. +-- +-- @ +-- type instance 'Scale' \"XAU\" \"milligram\" = '(31103477, 1000) +-- @ +-- +-- If you try to obtain the 'Scale' of a @currency@ without an obvious smallest +-- representable @unit@, like XAU, you will get a compile error. +type family Scale (currency :: Symbol) (unit :: Symbol) :: (Nat, Nat) + +-- | A friendly 'GHC.TypeError' to use for a @currency@ that doesn't have a +-- canonical small unit. +type family ErrScaleNonCanonical (currency :: Symbol) :: k where + ErrScaleNonCanonical c = GHC.TypeError + ( 'GHC.Text c 'GHC.:<>: + 'GHC.Text " is not a currency with a canonical smallest unit," 'GHC.:$$: + 'GHC.Text "be explicit about the currency unit you want to use." ) + +-- | Constraints to a scale (like the one returned by @'Scale' currency unit@) +-- expected to always be satisfied. In particular, the scale is always +-- guaranteed to be a positive rational number ('GHC.Real.infinity' and +-- 'GHC.Real.notANumber' are forbidden by 'GoodScale'). +type GoodScale (scale :: (Nat, Nat)) + = ( CmpNat 0 (Fst scale) ~ 'LT + , CmpNat 0 (Snd scale) ~ 'LT + , KnownNat (Fst scale) + , KnownNat (Snd scale) + ) + +-- | If the specified @num@ and @den@ satisfy the expectations of 'GoodScale' at +-- the type level, then construct a proof for 'GoodScale'. +mkGoodScale + :: forall num den + . (KnownNat num, KnownNat den) + => Maybe (Dict (GoodScale '(num, den))) +mkGoodScale = + let n = natVal (Proxy :: Proxy num) + d = natVal (Proxy :: Proxy den) + in if (n > 0) && (d > 0) + then Just (unsafeCoerce (Dict :: Dict ('LT ~ 'LT, 'LT ~ 'LT, + KnownNat num, KnownNat den))) + else Nothing +{-# INLINABLE mkGoodScale #-} + +-- | Term-level representation of a currrency @scale@. +-- +-- For example, the 'Scale' for @\"USD\"@ in @\"cent\"@s is @100/1@. +-- +-- @ +-- > 'scale' ('Proxy' :: 'Proxy' ('Scale' \"USD\" \"cent\")) +-- 100 '%' 1 +-- @ +-- +-- @ +-- > 'scale' (x :: 'Discrete' \"USD\" \"cent\") +-- 100 '%' 1 +-- @ +-- +-- The returned 'Rational' is statically guaranteed to be a positive number. +scale :: forall proxy scale. GoodScale scale => proxy scale -> Rational -- ^ +scale = \_ -> natVal (Proxy :: Proxy (Fst scale)) % + natVal (Proxy :: Proxy (Snd scale)) +{-# INLINE scale #-} + +-------------------------------------------------------------------------------- + +-- | Exchange rate for converting monetary values of currency @src@ into +-- monetary values of currency @dst@ by multiplying for it. +-- +-- For example, if in order to convert USD to GBP we have to multiply by 1.2345, +-- then we can represent this situaion using: +-- +-- @ +-- 'exchangeRate' (12345 '%' 10000) :: 'Maybe' ('ExchangeRate' \"USD\" \"GBP\") +-- @ +newtype ExchangeRate (src :: Symbol) (dst :: Symbol) = ExchangeRate Rational + deriving (Eq, Ord, GHC.Generic) + + +-- | Composition of 'ExchangeRate's multiplies exchange rates together: +-- +-- @ +-- 'exchangeRateToRational' x * 'exchangeRateToRational' y == 'exchangeRateToRational' (x . y) +-- @ +-- +-- Identity: +-- +-- @ +-- x == x . id == id . x +-- @ +-- +-- Associativity: +-- +-- @ +-- x . y . z == x . (y . z) == (x . y) . z +-- @ +-- +-- Conmutativity (provided the types allow for composition): +-- +-- @ +-- x . y == y . x +-- @ +-- +-- Reciprocal: +-- +-- @ +-- 1 == 'exchangeRateToRational' (x . 'exchangeRateRecip' x) +-- @ +instance Category ExchangeRate where + id = ExchangeRate 1 + {-# INLINE id #-} + ExchangeRate a . ExchangeRate b = ExchangeRate (a * b) + {-# INLINE (.) #-} + +-- | +-- @ +-- > 'show' ('exchangeRate' (5 '%' 7) :: 'Maybe' ('ExchangeRate' \"USD\" \"JPY\"))@ +-- Just \"ExchangeRate \\\"USD\\\" \\\"JPY\\\" 5%7\" +-- @ +instance forall src dst. + ( KnownSymbol src, KnownSymbol dst + ) => Show (ExchangeRate src dst) where + showsPrec n = \(ExchangeRate r0) -> + let s = symbolVal (Proxy :: Proxy src) + d = symbolVal (Proxy :: Proxy dst) + in showParen (n > 10) $ + showString "ExchangeRate " . showsPrec 0 s . showChar ' ' . + showsPrec 0 d . showChar ' ' . + showsPrec 0 (numerator r0) . showChar '%' . + showsPrec 0 (denominator r0) + +instance forall src dst. + ( KnownSymbol src, KnownSymbol dst + ) => Read (ExchangeRate (src :: Symbol) (dst :: Symbol)) where + readPrec = Read.parens $ do + let s = symbolVal (Proxy :: Proxy src) + d = symbolVal (Proxy :: Proxy dst) + _ <- ReadPrec.lift (ReadP.string + ("ExchangeRate " ++ show s ++ " " ++ show d ++ " ")) + maybe empty pure =<< fmap exchangeRate Read.readPrec + + +-- | Obtain a 'Rational' representation of the 'ExchangeRate'. +-- +-- This 'Rational' is guaranteed to be a positive number. +exchangeRateToRational :: ExchangeRate src dst -> Rational +exchangeRateToRational = \(ExchangeRate r0) -> r0 +{-# INLINE exchangeRateToRational #-} + +-- | Safely construct an 'ExchangeRate' from a *positive* 'Rational' number. +exchangeRate :: Rational -> Maybe (ExchangeRate src dst) +exchangeRate = \r -> + if denominator r /= 0 && r > 0 + then Just (ExchangeRate r) + else Nothing +{-# INLINE exchangeRate #-} + +-- | Reciprocal 'ExchangeRate'. +-- +-- This function retuns the reciprocal or multiplicative inverse of the given +-- 'ExchangeRate', leading to the following identity law: +-- +-- @ +-- 'exchangeRateRecip' . 'exchangeRateRecip' == 'id' +-- @ +-- +-- Note: If 'ExchangeRate' had a 'Fractional' instance, then 'exchangeRateRecip' +-- would be the implementation of 'recip'. +exchangeRateRecip :: ExchangeRate a b -> ExchangeRate b a +exchangeRateRecip = \(ExchangeRate x) -> + ExchangeRate (1 / x) -- 'exchangeRate' guarantees that @x@ isn't zero. +{-# INLINE exchangeRateRecip #-} + +-- | Apply the 'ExchangeRate' to the given @'Dense' src@ monetary value. +-- +-- Identity law: +-- +-- @ +-- 'exchange' ('exchangeRateRecip' x) . 'exchange' x == 'id' +-- @ +-- +-- Use the /Identity law/ for reasoning about going back and forth between @src@ +-- and @dst@ in order to manage any leftovers that might not be representable as +-- a 'Discrete' monetary value of @src@. +exchange :: ExchangeRate src dst -> Dense src -> Dense dst +exchange (ExchangeRate r) = \(Dense s) -> Dense (r * s) +{-# INLINE exchange #-} + +-------------------------------------------------------------------------------- +-- SomeDense + +-- | A monomorphic representation of 'Dense' that is easier to serialize and +-- deserialize than 'Dense' in case you don't know the type indexes involved. +-- +-- If you are trying to construct a value of this type from some raw input, then +-- you will need to use the 'mkSomeDense' function. +-- +-- In order to be able to effectively serialize a 'SomeDense' value, you +-- need to serialize the following three values (which are the eventual +-- arguments to 'mkSomeDense'): +-- +-- * 'someDenseCurrency' +-- * 'someDenseAmount' +data SomeDense = SomeDense + { _someDenseCurrency :: !String + , _someDenseAmount :: !Rational + } deriving (Eq, Show, GHC.Generic) + +-- | __WARNING__ This instance does not compare monetary amounts, it just helps +-- you sort 'SomeDense' values in case you need to put them in a 'Data.Set.Set' +-- or similar. +deriving instance Ord SomeDense + +-- | Currency name. +someDenseCurrency :: SomeDense -> String +someDenseCurrency = _someDenseCurrency +{-# INLINE someDenseCurrency #-} + +-- | Currency unit amount. +someDenseAmount :: SomeDense -> Rational +someDenseAmount = _someDenseAmount +{-# INLINE someDenseAmount #-} + +-- | Build a 'SomeDense' from raw values. +-- +-- This function is intended for deserialization purposes. You need to convert +-- this 'SomeDense' value to a 'Dense' value in order to do any arithmetic +-- operation on the monetary value. +mkSomeDense + :: String -- ^ Currency. ('someDenseCurrency') + -> Rational -- ^ Scale. ('someDenseAmount') + -> Maybe SomeDense +mkSomeDense = \c r -> + if (denominator r /= 0) + then Just (SomeDense c r) + else Nothing +{-# INLINABLE mkSomeDense #-} + +-- | Convert a 'Dense' to a 'SomeDense' for ease of serialization. +toSomeDense :: KnownSymbol currency => Dense currency -> SomeDense +toSomeDense = \(Dense r0 :: Dense currency) -> + let c = symbolVal (Proxy :: Proxy currency) + in SomeDense c r0 +{-# INLINE toSomeDense #-} + +-- | Attempt to convert a 'SomeDense' to a 'Dense', provided you know the target +-- @currency@. +fromSomeDense + :: forall currency + . KnownSymbol currency + => SomeDense + -> Maybe (Dense currency) -- ^ +fromSomeDense = \dr -> + if (someDenseCurrency dr == symbolVal (Proxy :: Proxy currency)) + then Just (Dense (someDenseAmount dr)) + else Nothing +{-# INLINABLE fromSomeDense #-} + +-- | Convert a 'SomeDense' to a 'Dense' without knowing the target @currency@. +-- +-- Notice that @currency@ here can't leave its intended scope unless you can +-- prove equality with some other type at the outer scope, but in that case you +-- would be better off using 'fromSomeDense' directly. +withSomeDense + :: SomeDense + -> (forall currency. KnownSymbol currency => Dense currency -> r) + -> r -- ^ +withSomeDense dr = \f -> + case someSymbolVal (someDenseCurrency dr) of + SomeSymbol (Proxy :: Proxy currency) -> + f (Dense (someDenseAmount dr) :: Dense currency) +{-# INLINABLE withSomeDense #-} + +-------------------------------------------------------------------------------- +-- SomeDiscrete + +-- | A monomorphic representation of 'Discrete' that is easier to serialize and +-- deserialize than 'Discrete' in case you don't know the type indexes involved. +-- +-- If you are trying to construct a value of this type from some raw input, then +-- you will need to use the 'mkSomeDiscrete' function. +-- +-- In order to be able to effectively serialize a 'SomeDiscrete' value, you need +-- to serialize the following four values (which are the eventual arguments to +-- 'mkSomeDiscrete'): +-- +-- * 'someDiscreteCurrency' +-- * 'someDiscreteScale' +-- * 'someDiscreteAmount' +data SomeDiscrete = SomeDiscrete + { _someDiscreteCurrency :: !String -- ^ Currency name. + , _someDiscreteScale :: !Rational -- ^ Positive, non-zero. + , _someDiscreteAmount :: !Integer -- ^ Amount of unit. + } deriving (Eq, Show, GHC.Generic) + +-- | __WARNING__ This instance does not compare monetary amounts, it just helps +-- you sort 'SomeDiscrete' values in case you need to put them in a +-- 'Data.Set.Set' or similar. +deriving instance Ord SomeDiscrete + +-- | Currency name. +someDiscreteCurrency :: SomeDiscrete -> String +someDiscreteCurrency = _someDiscreteCurrency +{-# INLINE someDiscreteCurrency #-} + +-- | Positive, non-zero. +someDiscreteScale :: SomeDiscrete -> Rational +someDiscreteScale = _someDiscreteScale +{-# INLINE someDiscreteScale #-} + +-- | Amount of currency unit. +someDiscreteAmount :: SomeDiscrete -> Integer +someDiscreteAmount = _someDiscreteAmount +{-# INLINE someDiscreteAmount #-} + +-- | Internal. Build a 'SomeDiscrete' from raw values. +-- +-- This function is intended for deserialization purposes. You need to convert +-- this 'SomeDiscrete' value to a 'Discrete' vallue in order to do any arithmetic +-- operation on the monetary value. +mkSomeDiscrete + :: String -- ^ Currency name. ('someDiscreteCurrency') + -> Rational -- ^ Scale. Positive, non-zero. ('someDiscreteScale') + -> Integer -- ^ Amount of unit. ('someDiscreteAmount') + -> Maybe SomeDiscrete +mkSomeDiscrete = \c r a -> + if (denominator r /= 0) && (r > 0) + then Just (SomeDiscrete c r a) + else Nothing +{-# INLINABLE mkSomeDiscrete #-} + +-- | Convert a 'Discrete' to a 'SomeDiscrete' for ease of serialization. +toSomeDiscrete + :: (KnownSymbol currency, GoodScale scale) + => Discrete' currency scale + -> SomeDiscrete -- ^ +toSomeDiscrete = \(Discrete i0 :: Discrete' currency scale) -> + let c = symbolVal (Proxy :: Proxy currency) + n = natVal (Proxy :: Proxy (Fst scale)) + d = natVal (Proxy :: Proxy (Snd scale)) + in SomeDiscrete c (n % d) i0 +{-# INLINABLE toSomeDiscrete #-} + +-- | Attempt to convert a 'SomeDiscrete' to a 'Discrete', provided you know the +-- target @currency@ and @unit@. +fromSomeDiscrete + :: forall currency scale + . (KnownSymbol currency, GoodScale scale) + => SomeDiscrete + -> Maybe (Discrete' currency scale) -- ^ +fromSomeDiscrete = \dr -> + if (someDiscreteCurrency dr == symbolVal (Proxy :: Proxy currency)) && + (someDiscreteScale dr == scale (Proxy :: Proxy scale)) + then Just (Discrete (someDiscreteAmount dr)) + else Nothing +{-# INLINABLE fromSomeDiscrete #-} + +-- | Convert a 'SomeDiscrete' to a 'Discrete' without knowing the target +-- @currency@ and @unit@. +-- +-- Notice that @currency@ and @unit@ here can't leave its intended scope unless +-- you can prove equality with some other type at the outer scope, but in that +-- case you would be better off using 'fromSomeDiscrete' directly. +-- +-- Notice that you may need to add an explicit type to the result of this +-- function in order to keep the compiler happy. +withSomeDiscrete + :: forall r + . SomeDiscrete + -> ( forall currency scale. + ( KnownSymbol currency + , GoodScale scale + ) => Discrete' currency scale + -> r ) + -> r -- ^ +withSomeDiscrete dr = \f -> + case someSymbolVal (someDiscreteCurrency dr) of + SomeSymbol (Proxy :: Proxy currency) -> + case someNatVal (numerator (someDiscreteScale dr)) of + Nothing -> error "withSomeDiscrete: impossible: numerator < 0" + Just (SomeNat (Proxy :: Proxy num)) -> + case someNatVal (denominator (someDiscreteScale dr)) of + Nothing -> error "withSomeDiscrete: impossible: denominator < 0" + Just (SomeNat (Proxy :: Proxy den)) -> + case mkGoodScale of + Nothing -> error "withSomeDiscrete: impossible: mkGoodScale" + Just (Dict :: Dict (GoodScale '(num, den))) -> + f (Discrete (someDiscreteAmount dr) + :: Discrete' currency '(num, den)) +{-# INLINABLE withSomeDiscrete #-} + +-------------------------------------------------------------------------------- +-- SomeExchangeRate + +-- | A monomorphic representation of 'ExchangeRate' that is easier to serialize +-- and deserialize than 'ExchangeRate' in case you don't know the type indexes +-- involved. +-- +-- If you are trying to construct a value of this type from some raw input, then +-- you will need to use the 'mkSomeExchangeRate' function. +-- +-- In order to be able to effectively serialize an 'SomeExchangeRate' value, you +-- need to serialize the following four values (which are the eventual arguments +-- to 'mkSomeExchangeRate'): +-- +-- * 'someExchangeRateSrcCurrency' +-- * 'someExchangeRateDstCurrency' +-- * 'someExchangeRateRate' +data SomeExchangeRate = SomeExchangeRate + { _someExchangeRateSrcCurrency :: !String + , _someExchangeRateDstCurrency :: !String + , _someExchangeRateRate :: !Rational -- ^ Positive, non-zero. + } deriving (Eq, Show, GHC.Generic) + +-- | __WARNING__ This instance does not compare monetary amounts, it just helps +-- you sort 'SomeExchangeRate' values in case you need to put them in a +-- 'Data.Set.Set' or similar. +deriving instance Ord SomeExchangeRate + +-- | Source currency name. +someExchangeRateSrcCurrency :: SomeExchangeRate -> String +someExchangeRateSrcCurrency = _someExchangeRateSrcCurrency +{-# INLINE someExchangeRateSrcCurrency #-} + +-- | Destination currency name. +someExchangeRateDstCurrency :: SomeExchangeRate -> String +someExchangeRateDstCurrency = _someExchangeRateDstCurrency +{-# INLINE someExchangeRateDstCurrency #-} + +-- | Exchange rate. Positive, non-zero. +someExchangeRateRate :: SomeExchangeRate -> Rational +someExchangeRateRate = _someExchangeRateRate +{-# INLINE someExchangeRateRate #-} + +-- | Internal. Build a 'SomeExchangeRate' from raw values. +-- +-- This function is intended for deserialization purposes. You need to convert +-- this 'SomeExchangeRate' value to a 'ExchangeRate' value in order to do any +-- arithmetic operation with the exchange rate. +mkSomeExchangeRate + :: String -- ^ Source currency name. ('someExchangeRateSrcCurrency') + -> String -- ^ Destination currency name. ('someExchangeRateDstCurrency') + -> Rational -- ^ Exchange rate . Positive, non-zero. ('someExchangeRateRate') + -> Maybe SomeExchangeRate +mkSomeExchangeRate = \src dst r -> + if (denominator r /= 0) && (r > 0) + then Just (SomeExchangeRate src dst r) + else Nothing +{-# INLINABLE mkSomeExchangeRate #-} + +-- | Convert a 'ExchangeRate' to a 'SomeDiscrete' for ease of serialization. +toSomeExchangeRate + :: (KnownSymbol src, KnownSymbol dst) + => ExchangeRate src dst + -> SomeExchangeRate -- ^ +toSomeExchangeRate = \(ExchangeRate r0 :: ExchangeRate src dst) -> + let src = symbolVal (Proxy :: Proxy src) + dst = symbolVal (Proxy :: Proxy dst) + in SomeExchangeRate src dst r0 +{-# INLINABLE toSomeExchangeRate #-} + +-- | Attempt to convert a 'SomeExchangeRate' to a 'ExchangeRate', provided you +-- know the target @src@ and @dst@ types. +fromSomeExchangeRate + :: forall src dst + . (KnownSymbol src, KnownSymbol dst) + => SomeExchangeRate + -> Maybe (ExchangeRate src dst) -- ^ +fromSomeExchangeRate = \x -> + if (someExchangeRateSrcCurrency x == symbolVal (Proxy :: Proxy src)) && + (someExchangeRateDstCurrency x == symbolVal (Proxy :: Proxy dst)) + then Just (ExchangeRate (someExchangeRateRate x)) + else Nothing +{-# INLINABLE fromSomeExchangeRate #-} + +-- | Convert a 'SomeExchangeRate' to a 'ExchangeRate' without knowing the target +-- @currency@ and @unit@. +-- +-- Notice that @src@ and @dst@ here can't leave its intended scope unless +-- you can prove equality with some other type at the outer scope, but in that +-- case you would be better off using 'fromSomeExchangeRate' directly. +withSomeExchangeRate + :: SomeExchangeRate + -> ( forall src dst. + ( KnownSymbol src + , KnownSymbol dst + ) => ExchangeRate src dst + -> r ) + -> r -- ^ +withSomeExchangeRate x = \f -> + case someSymbolVal (someExchangeRateSrcCurrency x) of + SomeSymbol (Proxy :: Proxy src) -> + case someSymbolVal (someExchangeRateDstCurrency x) of + SomeSymbol (Proxy :: Proxy dst) -> + f (ExchangeRate (someExchangeRateRate x) :: ExchangeRate src dst) +{-# INLINABLE withSomeExchangeRate #-} + +-------------------------------------------------------------------------------- +-- Miscellaneous + +type family Fst (ab :: (ka, kb)) :: ka where Fst '(a,b) = a +type family Snd (ab :: (ka, kb)) :: ka where Snd '(a,b) = b + +-------------------------------------------------------------------------------- +-- vector-space instances + +#ifdef HAS_vector_space +instance AG.AdditiveGroup (Dense currency) where + zeroV = Dense AG.zeroV + {-# INLINE zeroV #-} + Dense a ^+^ Dense b = Dense $! (a AG.^+^ b) + {-# INLINE (^+^) #-} + negateV (Dense a) = Dense $! (AG.negateV a) + {-# INLINE negateV #-} + Dense a ^-^ Dense b = Dense $! (a AG.^-^ b) + {-# INLINE (^-^) #-} + +-- | __WARNING__ a scalar with a zero denominator will cause 'VS.*^' to crash. +instance VS.VectorSpace (Dense currency) where + type Scalar (Dense currency) = Rational + s *^ Dense a = + if denominator s /= 0 + then Dense $! s VS.*^ a + else error "(*^)': malformed Rational given (denominator is zero)." + {-# INLINE (*^) #-} + +instance GoodScale scale => AG.AdditiveGroup (Discrete' currency scale) where + zeroV = Discrete AG.zeroV + {-# INLINE zeroV #-} + Discrete a ^+^ Discrete b = Discrete $! (a AG.^+^ b) + {-# INLINE (^+^) #-} + negateV (Discrete a) = Discrete $! (AG.negateV a) + {-# INLINE negateV #-} + Discrete a ^-^ Discrete b = Discrete $! (a AG.^-^ b) + {-# INLINE (^-^) #-} + +instance GoodScale scale => VS.VectorSpace (Discrete' currency scale) where + type Scalar (Discrete' currency scale) = Integer + s *^ Discrete a = Discrete $! (s VS.*^ a) + {-# INLINE (*^) #-} +#endif + +-------------------------------------------------------------------------------- +-- Extra instances: hashable +#ifdef HAS_hashable +instance Hashable Approximation +instance Hashable (Dense currency) +instance Hashable SomeDense +instance GoodScale scale => Hashable (Discrete' currency scale) +instance Hashable SomeDiscrete +instance Hashable (ExchangeRate src dst) +instance Hashable SomeExchangeRate +#endif + +-------------------------------------------------------------------------------- +-- Extra instances: deepseq +#ifdef HAS_deepseq +instance NFData Approximation +instance NFData (Dense currency) +instance NFData SomeDense +instance GoodScale scale => NFData (Discrete' currency scale) +instance NFData SomeDiscrete +instance NFData (ExchangeRate src dst) +instance NFData SomeExchangeRate +#endif + +-------------------------------------------------------------------------------- +-- Extra instances: cereal +#ifdef HAS_cereal +-- | Compatible with 'SomeDense'. +instance (KnownSymbol currency) => Cereal.Serialize (Dense currency) where + put = Cereal.put . toSomeDense + get = maybe empty pure =<< fmap fromSomeDense Cereal.get + +-- | Compatible with 'SomeDiscrete'. +instance + ( KnownSymbol currency, GoodScale scale + ) => Cereal.Serialize (Discrete' currency scale) where + put = Cereal.put . toSomeDiscrete + get = maybe empty pure =<< fmap fromSomeDiscrete Cereal.get + +-- | Compatible with 'SomeExchangeRate'. +instance + ( KnownSymbol src, KnownSymbol dst + ) => Cereal.Serialize (ExchangeRate src dst) where + put = Cereal.put . toSomeExchangeRate + get = maybe empty pure =<< fmap fromSomeExchangeRate Cereal.get + +-- | Compatible with 'Dense'. +instance Cereal.Serialize SomeDense where + put = \(SomeDense c r) -> do + Cereal.put c + Cereal.put (numerator r) + Cereal.put (denominator r) + get = maybe empty pure =<< do + c :: String <- Cereal.get + n :: Integer <- Cereal.get + d :: Integer <- Cereal.get + when (d == 0) (fail "denominator is zero") + pure (mkSomeDense c (n % d)) + +-- | Compatible with 'Discrete'. +instance Cereal.Serialize SomeDiscrete where + put = \(SomeDiscrete c r a) -> do + Cereal.put c + Cereal.put (numerator r) + Cereal.put (denominator r) + Cereal.put a + get = maybe empty pure =<< do + c :: String <- Cereal.get + n :: Integer <- Cereal.get + d :: Integer <- Cereal.get + when (d == 0) (fail "denominator is zero") + a :: Integer <- Cereal.get + pure (mkSomeDiscrete c (n % d) a) + +-- | Compatible with 'ExchangeRate'. +instance Cereal.Serialize SomeExchangeRate where + put = \(SomeExchangeRate src dst r) -> do + Cereal.put src + Cereal.put dst + Cereal.put (numerator r) + Cereal.put (denominator r) + get = maybe empty pure =<< do + src :: String <- Cereal.get + dst :: String <- Cereal.get + n :: Integer <- Cereal.get + d :: Integer <- Cereal.get + when (d == 0) (fail "denominator is zero") + pure (mkSomeExchangeRate src dst (n % d)) +#endif + +------------------------------------------------------------------------------ +-- Extra instances: binary +#ifdef HAS_binary +-- | Compatible with 'SomeDense'. +instance (KnownSymbol currency) => Binary.Binary (Dense currency) where + put = Binary.put . toSomeDense + get = maybe empty pure =<< fmap fromSomeDense Binary.get + +-- | Compatible with 'SomeDiscrete'. +instance + ( KnownSymbol currency, GoodScale scale + ) => Binary.Binary (Discrete' currency scale) where + put = Binary.put . toSomeDiscrete + get = maybe empty pure =<< fmap fromSomeDiscrete Binary.get + +-- | Compatible with 'SomeExchangeRate'. +instance + ( KnownSymbol src, KnownSymbol dst + ) => Binary.Binary (ExchangeRate src dst) where + put = Binary.put . toSomeExchangeRate + get = maybe empty pure =<< fmap fromSomeExchangeRate Binary.get + +-- | Compatible with 'Dense'. +instance Binary.Binary SomeDense where + put = \(SomeDense c r) -> + Binary.put c >> Binary.put (numerator r) >> Binary.put (denominator r) + get = maybe empty pure =<< do + c :: String <- Binary.get + n :: Integer <- Binary.get + d :: Integer <- Binary.get + when (d == 0) (fail "denominator is zero") + pure (mkSomeDense c (n % d)) + +-- | Compatible with 'Discrete'. +instance Binary.Binary SomeDiscrete where + put = \(SomeDiscrete c r a) -> + Binary.put c <> + Binary.put (numerator r) <> + Binary.put (denominator r) <> + Binary.put a + get = maybe empty pure =<< do + c :: String <- Binary.get + n :: Integer <- Binary.get + d :: Integer <- Binary.get + when (d == 0) (fail "denominator is zero") + a :: Integer <- Binary.get + pure (mkSomeDiscrete c (n % d) a) + +-- | Compatible with 'ExchangeRate'. +instance Binary.Binary SomeExchangeRate where + put = \(SomeExchangeRate src dst r) -> do + Binary.put src + Binary.put dst + Binary.put (numerator r) + Binary.put (denominator r) + get = maybe empty pure =<< do + src :: String <- Binary.get + dst :: String <- Binary.get + n :: Integer <- Binary.get + d :: Integer <- Binary.get + when (d == 0) (fail "denominator is zero") + pure (mkSomeExchangeRate src dst (n % d)) +#endif + +-------------------------------------------------------------------------------- +-- Extra instances: serialise +#ifdef HAS_serialise +-- | Compatible with 'SomeDense'. +instance (KnownSymbol currency) => Ser.Serialise (Dense currency) where + encode = Ser.encode . toSomeDense + decode = maybe (fail "Dense") pure =<< fmap fromSomeDense Ser.decode + +-- | Compatible with 'SomeDiscrete'. +instance + ( KnownSymbol currency, GoodScale scale + ) => Ser.Serialise (Discrete' currency scale) where + encode = Ser.encode . toSomeDiscrete + decode = maybe (fail "Discrete'") pure =<< fmap fromSomeDiscrete Ser.decode + +-- | Compatible with 'SomeExchangeRate'. +instance + ( KnownSymbol src, KnownSymbol dst + ) => Ser.Serialise (ExchangeRate src dst) where + encode = Ser.encode . toSomeExchangeRate + decode = maybe (fail "ExchangeRate") pure + =<< fmap fromSomeExchangeRate Ser.decode + +-- | Compatible with 'Dense'. +instance Ser.Serialise SomeDense where + encode = \(SomeDense c r) -> + Ser.encode c <> Ser.encode (numerator r) <> Ser.encode (denominator r) + decode = maybe (fail "SomeDense") pure =<< do + c :: String <- Ser.decode + n :: Integer <- Ser.decode + d :: Integer <- Ser.decode + when (d == 0) (fail "denominator is zero") + pure (mkSomeDense c (n % d)) + +-- | Compatible with 'Discrete'. +instance Ser.Serialise SomeDiscrete where + encode = \(SomeDiscrete c r a) -> + Ser.encode c <> + Ser.encode (numerator r) <> + Ser.encode (denominator r) <> + Ser.encode a + decode = maybe (fail "SomeDiscrete") pure =<< do + c :: String <- Ser.decode + n :: Integer <- Ser.decode + d :: Integer <- Ser.decode + when (d == 0) (fail "denominator is zero") + a :: Integer <- Ser.decode + pure (mkSomeDiscrete c (n % d) a) + +-- | Compatible with 'ExchangeRate'. +instance Ser.Serialise SomeExchangeRate where + encode = \(SomeExchangeRate src dst r) -> + Ser.encode src <> + Ser.encode dst <> + Ser.encode (numerator r) <> + Ser.encode (denominator r) + decode = maybe (fail "SomeExchangeRate") pure =<< do + src :: String <- Ser.decode + dst :: String <- Ser.decode + n :: Integer <- Ser.decode + d :: Integer <- Ser.decode + when (d == 0) (fail "denominator is zero") + pure (mkSomeExchangeRate src dst (n % d)) +#endif + +-------------------------------------------------------------------------------- +-- Extra instances: aeson +#ifdef HAS_aeson +-- | Compatible with 'SomeDense' +-- +-- Example rendering @'dense'' (2 '%' 3) :: 'Dense' \"BTC\"@: +-- +-- @ +-- [\"BTC\", 2, 3] +-- @ +-- +-- Note: The JSON serialization changed in version 0.4 (the leading @"Dense"@ +-- string was dropped from the rendered 'Ae.Array'). +instance KnownSymbol currency => Ae.ToJSON (Dense currency) where + toJSON = Ae.toJSON . toSomeDense + +-- | Compatible with 'SomeDense' +-- +-- Note: The JSON serialization changed in version 0.4. However, this instance +-- is still able to cope with the previous format. +instance KnownSymbol currency => Ae.FromJSON (Dense currency) where + parseJSON = maybe empty pure <=< fmap fromSomeDense . Ae.parseJSON + +-- | Compatible with 'Dense' +-- +-- Note: The JSON serialization changed in version 0.4 (the leading @"Dense"@ +-- string was dropped from the rendered 'Ae.Array'). +instance Ae.ToJSON SomeDense where + toJSON = \(SomeDense c r) -> + Ae.toJSON (c, numerator r, denominator r) + +-- | Compatible with 'Dense'. +-- +-- Note: The JSON serialization changed in version 0.4. However, this instance +-- is still able to cope with the previous format. +instance Ae.FromJSON SomeDense where + parseJSON = \v -> do + (c, n, d) <- Ae.parseJSON v <|> do + -- Pre 0.4 format. + ("Dense" :: String, c, n, d) <- Ae.parseJSON v + pure (c, n, d) + when (d == 0) (fail "denominator is zero") + maybe empty pure (mkSomeDense c (n % d)) + +-- | Compatible with 'SomeDiscrete' +-- +-- Example rendering @'discrete' 43 :: 'Discrete' \"BTC\" \"satoshi\"@: +-- +-- @ +-- [\"BTC\", 100000000, 1, 43] +-- @ +-- +-- Note: The JSON serialization changed in version 0.4 (the leading @"Discrete"@ +-- string was dropped from the rendered 'Ae.Array'). +instance + ( KnownSymbol currency, GoodScale scale + ) => Ae.ToJSON (Discrete' currency scale) where + toJSON = Ae.toJSON . toSomeDiscrete + +-- | Compatible with 'SomeDiscrete' +-- +-- Note: The JSON serialization changed in version 0.4. However, this instance +-- is still able to cope with the previous format. +instance + ( KnownSymbol currency, GoodScale scale + ) => Ae.FromJSON (Discrete' currency scale) where + parseJSON = maybe empty pure <=< fmap fromSomeDiscrete . Ae.parseJSON + +-- | Compatible with 'Discrete'' +-- +-- Note: The JSON serialization changed in version 0.4 (the leading @"Discrete"@ +-- string was dropped from the rendered 'Ae.Array'). +instance Ae.ToJSON SomeDiscrete where + toJSON = \(SomeDiscrete c r a) -> + Ae.toJSON (c, numerator r, denominator r, a) + +-- | Compatible with 'Discrete'' +-- +-- Note: The JSON serialization changed in version 0.4. However, this instance +-- is still able to cope with the previous format. +instance Ae.FromJSON SomeDiscrete where + parseJSON = \v -> do + (c, n, d, a) <- Ae.parseJSON v <|> do + -- Pre 0.4 format. + ("Discrete" :: String, c, n, d, a) <- Ae.parseJSON v + pure (c, n, d, a) + when (d == 0) (fail "denominator is zero") + maybe empty pure (mkSomeDiscrete c (n % d) a) + +-- | Compatible with 'SomeExchangeRate' +-- +-- Example rendering an 'ExchangeRate' constructed with +-- @'exchangeRate' (5 '%' 7) :: 'ExchangeRate' \"USD\" \"JPY\"@ +-- +-- @ +-- [\"USD\", \"JPY\", 5, 7] +-- @ +-- +-- Note: The JSON serialization changed in version 0.4 (the leading +-- @"ExchangeRate"@ string was dropped from the rendered 'Ae.Array'). +instance + ( KnownSymbol src, KnownSymbol dst + ) => Ae.ToJSON (ExchangeRate src dst) where + toJSON = Ae.toJSON . toSomeExchangeRate + +-- | Compatible with 'SomeExchangeRate' +-- +-- Note: The JSON serialization changed in version 0.4. However, this instance +-- is still able to cope with the previous format. +instance + ( KnownSymbol src, KnownSymbol dst + ) => Ae.FromJSON (ExchangeRate src dst) where + parseJSON = maybe empty pure <=< fmap fromSomeExchangeRate . Ae.parseJSON + +-- | Compatible with 'ExchangeRate' +-- +-- Note: The JSON serialization changed in version 0.4 (the leading +-- @"ExchangeRate"@ string was dropped from the rendered 'Ae.Array'). +instance Ae.ToJSON SomeExchangeRate where + toJSON = \(SomeExchangeRate src dst r) -> + Ae.toJSON (src, dst, numerator r, denominator r) + +-- | Compatible with 'ExchangeRate' +-- +-- Note: The JSON serialization changed in version 0.4. However, this instance +-- is still able to cope with the previous format. +instance Ae.FromJSON SomeExchangeRate where + parseJSON = \v -> do + (src, dst, n, d) <- Ae.parseJSON v <|> do + -- Pre 0.4 format. + ("ExchangeRate" :: String, src, dst, n, d) <- Ae.parseJSON v + pure (src, dst, n, d) + when (d == 0) (fail "denominator is zero") + maybe empty pure (mkSomeExchangeRate src dst (n % d)) +#endif + +-------------------------------------------------------------------------------- +-- Extra instances: xmlbf +#ifdef HAS_xmlbf + +-- | Compatible with 'SomeDense' +-- +-- Example rendering @'dense' (2 '%' 3) :: 'Dense' \"BTC\"@: +-- +-- @ +-- \ +-- @ +instance KnownSymbol currency => Xmlbf.ToXml (Dense currency) where + toXml = Xmlbf.toXml . toSomeDense + +-- | Compatible with 'SomeDense' +instance KnownSymbol currency => Xmlbf.FromXml (Dense currency) where + fromXml = maybe empty pure =<< fmap fromSomeDense Xmlbf.fromXml + +-- | Compatible with 'Dense' +instance Xmlbf.ToXml SomeDense where + toXml = \(SomeDense c r) -> + let as = [ (T.pack "c", T.pack c) + , (T.pack "n", T.pack (show (numerator r))) + , (T.pack "d", T.pack (show (denominator r))) ] + Right e = Xmlbf.element (T.pack "money-dense") (fromList as) [] + in [e] + +-- | Compatible with 'Dense'. +instance Xmlbf.FromXml SomeDense where + fromXml = Xmlbf.pElement (T.pack "money-dense") $ do + c <- T.unpack <$> Xmlbf.pAttr "c" + n <- Xmlbf.pRead =<< Xmlbf.pAttr "n" + d <- Xmlbf.pRead =<< Xmlbf.pAttr "d" + when (d == 0) (fail "denominator is zero") + maybe empty pure (mkSomeDense c (n % d)) + +-- | Compatible with 'SomeDiscrete' +-- +-- Example rendering @'discrete' 43 :: 'Discrete' \"BTC\" \"satoshi\"@: +-- +-- @ +-- \ +-- @ +instance + ( KnownSymbol currency, GoodScale scale + ) => Xmlbf.ToXml (Discrete' currency scale) where + toXml = Xmlbf.toXml . toSomeDiscrete + +-- | Compatible with 'SomeDiscrete' +instance + ( KnownSymbol currency, GoodScale scale + ) => Xmlbf.FromXml (Discrete' currency scale) where + fromXml = maybe empty pure =<< fmap fromSomeDiscrete Xmlbf.fromXml + +-- | Compatible with 'Discrete'' +instance Xmlbf.ToXml SomeDiscrete where + toXml = \(SomeDiscrete c r a) -> + let as = [ (T.pack "c", T.pack c) + , (T.pack "n", T.pack (show (numerator r))) + , (T.pack "d", T.pack (show (denominator r))) + , (T.pack "a", T.pack (show a)) ] + Right e = Xmlbf.element (T.pack "money-discrete") (fromList as) [] + in [e] + +-- | Compatible with 'Discrete'' +instance Xmlbf.FromXml SomeDiscrete where + fromXml = Xmlbf.pElement (T.pack "money-discrete") $ do + c <- T.unpack <$> Xmlbf.pAttr "c" + n <- Xmlbf.pRead =<< Xmlbf.pAttr "n" + d <- Xmlbf.pRead =<< Xmlbf.pAttr "d" + when (d == 0) (fail "denominator is zero") + a <- Xmlbf.pRead =<< Xmlbf.pAttr "a" + maybe empty pure (mkSomeDiscrete c (n % d) a) + +-- | Compatible with 'SomeExchangeRate' +-- +-- Example rendering an 'ExchangeRate' constructed with +-- @'exchangeRate' (5 '%' 7) :: 'ExchangeRate' \"USD\" \"JPY\"@ +-- +-- @ +-- \ +-- @ +instance + ( KnownSymbol src, KnownSymbol dst + ) => Xmlbf.ToXml (ExchangeRate src dst) where + toXml = Xmlbf.toXml . toSomeExchangeRate + +-- | Compatible with 'SomeExchangeRate' +instance + ( KnownSymbol src, KnownSymbol dst + ) => Xmlbf.FromXml (ExchangeRate src dst) where + fromXml = maybe empty pure =<< fmap fromSomeExchangeRate Xmlbf.fromXml + +-- | Compatible with 'ExchangeRate' +instance Xmlbf.ToXml SomeExchangeRate where + toXml = \(SomeExchangeRate src dst r) -> + let as = [ (T.pack "src", T.pack src) + , (T.pack "dst", T.pack dst) + , (T.pack "n", T.pack (show (numerator r))) + , (T.pack "d", T.pack (show (denominator r))) ] + Right e = Xmlbf.element (T.pack "exchange-rate") (fromList as) [] + in [e] + +-- | Compatible with 'ExchangeRate' +instance Xmlbf.FromXml SomeExchangeRate where + fromXml = Xmlbf.pElement (T.pack "exchange-rate") $ do + src <- T.unpack <$> Xmlbf.pAttr "src" + dst <- T.unpack <$> Xmlbf.pAttr "dst" + n <- Xmlbf.pRead =<< Xmlbf.pAttr "n" + d <- Xmlbf.pRead =<< Xmlbf.pAttr "d" + when (d == 0) (fail "denominator is zero") + maybe empty pure (mkSomeExchangeRate src dst (n % d)) +#endif + +-------------------------------------------------------------------------------- +-- Extra instances: store +#ifdef HAS_store +-- | Compatible with 'SomeDense'. +instance (KnownSymbol currency) => Store.Store (Dense currency) where + size = storeContramapSize toSomeDense Store.size + poke = Store.poke . toSomeDense + peek = maybe (fail "peek") pure =<< fmap fromSomeDense Store.peek +-- | Compatible with 'Dense'. +instance Store.Store SomeDense where + poke = \(SomeDense c r) -> do + Store.poke c + Store.poke (numerator r) + Store.poke (denominator r) + peek = maybe (fail "peek") pure =<< do + c :: String <- Store.peek + n :: Integer <- Store.peek + d :: Integer <- Store.peek + when (d == 0) (fail "denominator is zero") + pure (mkSomeDense c (n % d)) + +-- | Compatible with 'SomeDiscrete'. +instance + ( KnownSymbol currency, GoodScale scale + ) => Store.Store (Discrete' currency scale) where + size = storeContramapSize toSomeDiscrete Store.size + poke = Store.poke . toSomeDiscrete + peek = maybe (fail "peek") pure =<< fmap fromSomeDiscrete Store.peek +-- | Compatible with 'Discrete''. +instance Store.Store SomeDiscrete where + poke = \(SomeDiscrete c r a) ->do + Store.poke c + Store.poke (numerator r) + Store.poke (denominator r) + Store.poke a + peek = maybe (fail "peek") pure =<< do + c :: String <- Store.peek + n :: Integer <- Store.peek + d :: Integer <- Store.peek + when (d == 0) (fail "denominator is zero") + a :: Integer <- Store.peek + pure (mkSomeDiscrete c (n % d) a) +-- | Compatible with 'SomeExchangeRate'. +instance + ( KnownSymbol src, KnownSymbol dst + ) => Store.Store (ExchangeRate src dst) where + size = storeContramapSize toSomeExchangeRate Store.size + poke = Store.poke . toSomeExchangeRate + peek = maybe (fail "peek") pure =<< fmap fromSomeExchangeRate Store.peek +-- | Compatible with 'ExchangeRate'. +instance Store.Store SomeExchangeRate where + poke = \(SomeExchangeRate src dst r) -> do + Store.poke src + Store.poke dst + Store.poke (numerator r) + Store.poke (denominator r) + peek = maybe (fail "peek") pure =<< do + src <- Store.peek + dst <- Store.peek + n <- Store.peek + d <- Store.peek + when (d == 0) (fail "denominator is zero") + pure (mkSomeExchangeRate src dst (n % d)) + +storeContramapSize :: (a -> b) -> Store.Size b -> Store.Size a +storeContramapSize f = \case + Store.VarSize g -> Store.VarSize (g . f) + Store.ConstSize x -> Store.ConstSize x +{-# INLINABLE storeContramapSize #-} +#endif + +-------------------------------------------------------------------------------- +-- Decimal rendering + +-- | Render a 'Dense' monetary amount as a decimal number in a potentially lossy +-- manner. +-- +-- @ +-- > 'denseToDecimal' 'Round' 'True' ('Just' \',\') \'.\' 2 +-- ('Proxy' :: 'Proxy' ('Scale' \"USD\" \"dollar\")) +-- ('dense'' (123456 '%' 100) :: 'Dense' \"USD\") +-- Just \"+1,234.56\" +-- @ +-- +-- @ +-- > 'denseToDecimal' 'Round' 'True' ('Just' \',\') \'.\' 2 +-- ('Proxy' :: 'Proxy' ('Scale' \"USD\" \"cent\")) +-- ('dense'' (123456 '%' 100) :: 'Dense' \"USD\") +-- Just \"+123,456.00\" +-- @ +-- +-- This function returns 'Nothing' if it is not possible to reliably render the +-- decimal string due to a bad choice of separators. That is, if the separators +-- are digits or equal among themselves, this function returns 'Nothing'. +denseToDecimal + :: GoodScale scale + => Approximation + -- ^ Approximation to use if necesary in order to fit the 'Dense' amount in + -- as many decimal numbers as requested. + -> Bool + -- ^ Whether to render a leading @\'+\'@ sign in case the amount is positive. + -> Maybe Char + -- ^ Thousands separator for the integer part, if any (i.e., the @\',\'@ in + -- @1,234.56789@). + -> Char + -- ^ Decimal separator (i.e., the @\'.\'@ in @1,234.56789@) + -> Word8 + -- ^ Number of decimal numbers to render, if any. + -> Proxy scale + -- ^ Scale used by the integer part of the decimal number. For example, a when + -- rendering render @'dense'' (123 '%' 100) :: 'Dense' "USD"@ as a decimal + -- number with three decimal places, a scale of @1@ (i.e. @'Scale' \"USD\" + -- \"dollar\"@) would render @1@ as the integer part and @230@ as the + -- fractional part, whereas a scale of @100@ (i.e., @'Scale' \"USD\" + -- \"cent\"@) would render @123@ as the integer part and @000@ as the + -- fractional part. + -> Dense currency + -- ^ The dense monetary amount to render. + -> Maybe String + -- ^ Returns 'Nothing' is the given separators are not acceptable (i.e., they + -- are digits, or they are equal). +{-# INLINABLE denseToDecimal #-} +denseToDecimal a plus ytsep dsep fdigs0 ps = \(Dense r0) -> + rationalToDecimal a plus ytsep dsep fdigs0 (scale ps * r0) + +-- | Render a 'ExchangeRate' as a decimal number in a potentially lossy manner. +-- +-- @ +-- > 'exchangeRateToDecimal' 'Round' 'True' ('Just' \',\') \'.\' 2 +-- '=<<' ('exchangeRate' (123456 '%' 100) :: 'Maybe' ('ExchangeRate' \"USD\" \"EUR\")) +-- Just \"1,234.56\" +-- @ +-- +-- This function returns 'Nothing' if it is not possible to reliably render the +-- decimal string due to a bad choice of separators. That is, if the separators +-- are digits or equal among themselves, this function returns 'Nothing'. +exchangeRateToDecimal + :: Approximation + -- ^ Approximation to use if necesary in order to fit the 'Dense' amount in + -- as many decimal numbers as requested. + -> Maybe Char + -- ^ Thousands separator for the integer part, if any (i.e., the @\',\'@ in + -- @1,234.56789@). + -> Char + -- ^ Decimal separator (i.e., the @\'.\'@ in @1,234.56789@) + -> Word8 + -- ^ Number of decimal numbers to render, if any. + -> ExchangeRate src dst + -- ^ The 'ExchangeRate' to render. + -> Maybe String + -- ^ Returns 'Nothing' is the given separators are not acceptable (i.e., they + -- are digits, or they are equal). +{-# INLINABLE exchangeRateToDecimal #-} +exchangeRateToDecimal a ytsep dsep fdigs0 = \(ExchangeRate r0) -> + rationalToDecimal a False ytsep dsep fdigs0 r0 + +-- | Render a 'Rational' number as a decimal approximation. +-- +-- This function returns 'Nothing' if it is not possible to reliably render the +-- decimal string due to a bad choice of separators. That is, if the separators +-- are digits or equal among themselves, this function returns 'Nothing'. +rationalToDecimal + :: Approximation + -- ^ Approximation to use if necesary in order to fit the 'Dense' amount in + -- as many decimal numbers as requested. + -> Bool + -- ^ Whether to render a leading @\'+\'@ sign in case the amount is positive. + -> Maybe Char + -- ^ Thousands separator for the integer part, if any (i.e., the @\',\'@ in + -- @1,234.56789@). + -> Char + -- ^ Decimal separator (i.e., the @\'.\'@ in @1,234.56789@) + -> Word8 + -- ^ Number of decimal numbers to render, if any. + -> Rational + -- ^ The dense monetary amount to render. + -> Maybe String + -- ^ Returns 'Nothing' is the given separators are not acceptable (i.e., they + -- are digits, or they are equal). +{-# INLINABLE rationalToDecimal #-} +rationalToDecimal a plus ytsep dsep fdigs0 = \r0 -> do + for_ ytsep $ \tsep -> + guard (tsep /= dsep && not (Char.isDigit tsep)) + guard (not (Char.isDigit dsep)) + -- this string-fu is not particularly efficient. + let parts = approximate a (r0 * (10 ^ fdigs0)) :: Integer + ipart = fromInteger (abs parts) `div` (10 ^ fdigs0) :: Natural + ftext | ipart == 0 = show (abs parts) :: String + | otherwise = drop (length (show ipart)) (show (abs parts)) + itext = maybe (show ipart) (renderThousands ipart) ytsep :: String + fpad0 = List.replicate (fromIntegral fdigs0 - length ftext) '0' :: String + Just $ mconcat + [ if | parts < 0 -> "-" + | plus && parts > 0 -> "+" + | otherwise -> "" + , itext + , if | fdigs0 > 0 -> dsep : ftext <> fpad0 + | otherwise -> "" + ] + + +-- | Render a 'Natural' number with thousand markers. +-- +-- @ +-- > 'renderThousands' 12045 \',\' +-- \"12,045\" +-- @ +renderThousands :: Natural -> Char -> String +{-# INLINABLE renderThousands #-} +renderThousands n0 + | n0 < 1000 = \_ -> show n0 + | otherwise = \c -> List.foldl' (flip mappend) mempty (List.unfoldr (f c) n0) + where f :: Char -> Natural -> Maybe (String, Natural) + f c = \x -> case divMod x 1000 of + (0, 0) -> Nothing + (0, z) -> Just (show z, 0) + (y, z) | z < 10 -> Just (c:'0':'0':show z, y) + | z < 100 -> Just (c:'0':show z, y) + | otherwise -> Just (c:show z, y) + +-------------------------------------------------------------------------------- +-- Decimal parsing + +-- | Parses a decimal representation of a 'Dense'. +-- +-- Leading @\'-\'@ and @\'+\'@ characters are considered. +denseFromDecimal + :: Maybe Char + -- ^ Thousands separator for the integer part, if any (i.e., the @\',\'@ in + -- @-1,234.56789@). + -> Char + -- ^ Decimal separator (i.e., the @\'.\'@ in @-1,234.56789@) + -> String + -- ^ The raw string containing the decimal representation (e.g., + -- @"-1,234.56789"@). + -> Maybe (Dense currency) +denseFromDecimal yst sf = fmap Dense . rationalFromDecimal yst sf + +-- | Parses a decimal representation of a 'Discrete'. +-- +-- Leading @\'-\'@ and @\'+\'@ characters are considered. +-- +-- Notice that parsing will fail unless the entire precision of the decimal +-- number can be represented in the desired @scale@. +discreteFromDecimal + :: GoodScale scale + => Maybe Char + -- ^ Thousands separator for the integer part, if any (i.e., the @\',\'@ in + -- @-1,234.56789@). + -> Char + -- ^ Decimal separator (i.e., the @\'.\'@ in @-1,234.56789@) + -> String + -- ^ The raw string containing the decimal representation (e.g., + -- @"-1,234.56789"@). + -> Maybe (Discrete' currency scale) +discreteFromDecimal yst sf = \s -> do + dns <- denseFromDecimal yst sf s + case discreteFromDense Truncate dns of + (x, 0) -> Just x + _ -> Nothing -- We fail for decimals that don't fit exactly in our scale. + +-- | Parses a decimal representation of an 'ExchangeRate'. +exchangeRateFromDecimal + :: Maybe Char + -- ^ Thousands separator for the integer part, if any (i.e., the @\',\'@ in + -- @1,234.56789@). + -> Char + -- ^ Decimal separator (i.e., the @\'.\'@ in @1,234.56789@) + -> String + -- ^ The raw string containing the decimal representation (e.g., + -- @"1,234.56789"@). + -> Maybe (ExchangeRate src dst) +exchangeRateFromDecimal yst sf = \case + ('-':_) -> Nothing + str -> exchangeRate =<< rationalFromDecimal yst sf str + +rationalFromDecimal + :: Maybe Char + -- ^ Thousands separator for the integer part, if any (i.e., the @\',\'@ in + -- @-1,234.56789@). + -> Char + -- ^ Decimal separator (i.e., the @\'.\'@ in @-1,234.56789@) + -> String + -- ^ The raw string containing the decimal representation (e.g., + -- @"-1,234.56789"@). + -> Maybe Rational +rationalFromDecimal yst sf = \s -> + case ReadP.readP_to_S (rationalFromDecimalP yst sf) s of + [(x,"")] -> Just x + _ -> Nothing + +-- TODO limit number of digits parsed to prevent DoS +rationalFromDecimalP + :: Maybe Char + -- ^ Thousands separator for the integer part, if any (i.e., the @\',\'@ in + -- @-1,234.56789@). + -- + -- The separator can't be a digit or control character. If it is, then parsing + -- will always fail. + -> Char + -- ^ Decimal separator (i.e., the @\'.\'@ in @-1,234.56789@). + -- + -- The separator can't be a digit or control character. If it is, then parsing + -- will always fail. + -> ReadP.ReadP Rational +rationalFromDecimalP ytsep dsep = do + for_ ytsep $ \tsep -> + guard (tsep /= dsep && not (Char.isDigit tsep)) + guard (not (Char.isDigit dsep)) + sig :: Rational -> Rational <- + (ReadP.char '-' $> negate) <|> + (ReadP.char '+' $> id) <|> + (pure id) + ipart :: String <- case ytsep of + Nothing -> ReadP.munch1 Char.isDigit + Just tsep -> mappend + <$> (ReadP.count 3 (ReadP.satisfy Char.isDigit) <|> + ReadP.count 2 (ReadP.satisfy Char.isDigit) <|> + ReadP.count 1 (ReadP.satisfy Char.isDigit)) + <*> (fmap concat $ ReadP.many + (ReadP.char tsep *> ReadP.count 3 (ReadP.satisfy Char.isDigit))) + yfpart :: Maybe String <- + (ReadP.char dsep *> fmap Just (ReadP.munch1 Char.isDigit) <* ReadP.eof) <|> + (ReadP.eof $> Nothing) + pure $! sig $ case yfpart of + Nothing -> fromInteger (read ipart) + Just fpart -> read (ipart <> fpart) % (10 ^ length fpart) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -5,17 +5,22 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} module Main where import Control.Category (Category((.), id)) import qualified Data.ByteString.Lazy as BSL -import Data.Maybe (catMaybes, isJust, isNothing) +import qualified Data.Char as Char +import Data.Maybe (catMaybes, isJust, isNothing, fromJust) import Data.Proxy (Proxy(Proxy)) -import Data.Ratio (numerator, denominator) +import Data.Ratio ((%), numerator, denominator) +import Data.Word (Word8) import GHC.TypeLits (Nat, Symbol, KnownSymbol, symbolVal) import Prelude hiding ((.), id) import qualified Test.Tasty as Tasty +import Test.Tasty.HUnit ((@?=)) +import qualified Test.Tasty.HUnit as HU import qualified Test.Tasty.Runners as Tasty import Test.Tasty.QuickCheck ((===), (==>), (.&&.)) import qualified Test.Tasty.QuickCheck as QC @@ -40,12 +45,19 @@ import qualified Data.Store as Store #endif +#ifdef HAS_vector_space +import qualified Data.AdditiveGroup as AG +import qualified Data.VectorSpace as VS +#endif + #ifdef HAS_xmlbf import qualified Xmlbf import qualified Data.Text as Text #endif import qualified Money +import qualified Money.Internal as Money + (rationalFromDecimal, rationalToDecimal) -------------------------------------------------------------------------------- @@ -59,46 +71,73 @@ arbitrary = do let md = Money.mkSomeDiscrete <$> QC.arbitrary <*> QC.arbitrary <*> QC.arbitrary - Just x <- QC.suchThat md isJust - pure x + fromJust <$> QC.suchThat md isJust shrink = \x -> Money.withSomeDiscrete x (map Money.toSomeDiscrete . QC.shrink) instance QC.Arbitrary (Money.Dense currency) where arbitrary = do - Just x <- QC.suchThat (Money.dense <$> QC.arbitrary) isJust - pure x - shrink = catMaybes . fmap Money.dense . QC.shrink . toRational + let myd = fmap Money.dense QC.arbitrary + fromJust <$> QC.suchThat myd isJust + shrink = catMaybes . map Money.dense . QC.shrink . toRational instance QC.Arbitrary Money.SomeDense where arbitrary = do let md = Money.mkSomeDense <$> QC.arbitrary <*> QC.arbitrary - Just x <- QC.suchThat md isJust - pure x + fromJust <$> QC.suchThat md isJust shrink = \x -> Money.withSomeDense x (map Money.toSomeDense . QC.shrink) instance QC.Arbitrary (Money.ExchangeRate src dst) where arbitrary = do - Just x <- QC.suchThat (fmap Money.exchangeRate QC.arbitrary) isJust - pure x - shrink = - catMaybes . fmap Money.exchangeRate . QC.shrink . Money.fromExchangeRate + let myxr = fmap Money.exchangeRate QC.arbitrary + fromJust <$> QC.suchThat myxr isJust + shrink = catMaybes . map Money.exchangeRate + . QC.shrink . Money.exchangeRateToRational instance QC.Arbitrary Money.SomeExchangeRate where arbitrary = do let md = Money.mkSomeExchangeRate <$> QC.arbitrary <*> QC.arbitrary <*> QC.arbitrary - Just x <- QC.suchThat md isJust - pure x + fromJust <$> QC.suchThat md isJust shrink = \x -> Money.withSomeExchangeRate x (map Money.toSomeExchangeRate . QC.shrink) +instance QC.Arbitrary Money.Approximation where + arbitrary = QC.oneof [ pure Money.Round + , pure Money.Floor + , pure Money.Ceiling + , pure Money.Truncate ] + +-- | Generates a valid 'Money.rationalToDecimal' result. Returns the thousand +-- and decimal separators as welland decimal separators as well. +genDecimal :: QC.Gen (String, Maybe Char, Char) +genDecimal = do + aprox :: Money.Approximation <- QC.arbitrary + plus :: Bool <- QC.arbitrary + digs :: Word8 <- QC.arbitrary + r :: Rational <- (%) <$> QC.arbitrary <*> QC.suchThat QC.arbitrary (/= 0) + (yts, ds) <- genDecimalSeps + Just dec <- pure (Money.rationalToDecimal aprox plus yts ds digs r) + pure (dec, yts, ds) + +-- | Generates valid separators for decimal representations (see genDecimal). +genDecimalSeps :: QC.Gen (Maybe Char, Char) +genDecimalSeps = do + let msep = QC.suchThat QC.arbitrary (not . Char.isDigit) + ds :: Char <- msep + yts :: Maybe Char <- genMaybe (QC.suchThat msep (/= ds)) + pure (yts, ds) + + +genMaybe :: QC.Gen a -> QC.Gen (Maybe a) +genMaybe m = QC.oneof [pure Nothing, fmap Just m] + -------------------------------------------------------------------------------- main :: IO () main = Tasty.defaultMainWithIngredients [ Tasty.consoleTestReporter , Tasty.listingTests - ] tests + ] (Tasty.localOption (QC.QuickCheckTests 500) tests) tests :: Tasty.TestTree tests = @@ -106,6 +145,9 @@ [ testCurrencies , testCurrencyUnits , testExchange + , testRationalToDecimal + , testRationalFromDecimal + , testDiscreteFromDecimal ] testCurrencies :: Tasty.TestTree @@ -127,11 +169,274 @@ , testDiscrete (Proxy :: Proxy "USD") (Proxy :: Proxy "cent") , testDiscrete (Proxy :: Proxy "USD") (Proxy :: Proxy "dollar") , testDiscrete (Proxy :: Proxy "VUV") (Proxy :: Proxy "vatu") - , testDiscrete (Proxy :: Proxy "XAU") (Proxy :: Proxy "micrograin") - , testDiscrete (Proxy :: Proxy "XAU") (Proxy :: Proxy "milligrain") + , testDiscrete (Proxy :: Proxy "XAU") (Proxy :: Proxy "gram") , testDiscrete (Proxy :: Proxy "XAU") (Proxy :: Proxy "grain") ] + +testRationalToDecimal :: Tasty.TestTree +testRationalToDecimal = + Tasty.testGroup "rationalToDecimal" + [ HU.testCase "Round: r1" $ do + render Money.Round r1 @?= + [ "1023004567.90" -- 0 + , "1,023,004,567.90" -- 1 + , "+1023004567.90" -- 2 + , "+1,023,004,567.90" -- 3 + , "1023004568" -- 8 + , "1,023,004,568" -- 9 + , "+1023004568" -- 10 + , "+1,023,004,568" -- 11 + ] + , HU.testCase "Round: negate r1" $ do + render Money.Round (negate r1) @?= + [ "-1023004567.90" -- 0 + , "-1,023,004,567.90" -- 1 + , "-1023004567.90" -- 2 + , "-1,023,004,567.90" -- 3 + , "-1023004568" -- 8 + , "-1,023,004,568" -- 9 + , "-1023004568" -- 10 + , "-1,023,004,568" -- 11 + ] + , HU.testCase "Round: r2" $ do + render Money.Round r2 @?= + [ "1.23" -- 0 + , "1.23" -- 1 + , "+1.23" -- 2 + , "+1.23" -- 3 + , "1" -- 8 + , "1" -- 9 + , "+1" -- 10 + , "+1" -- 11 + ] + , HU.testCase "Round: negate r2" $ do + render Money.Round (negate r2) @?= + [ "-1.23" -- 0 + , "-1.23" -- 1 + , "-1.23" -- 2 + , "-1.23" -- 3 + , "-1" -- 8 + , "-1" -- 9 + , "-1" -- 10 + , "-1" -- 11 + ] + , HU.testCase "Round: r3" $ do + render Money.Round r3 @?= + [ "0.34" -- 0 + , "0.34" -- 1 + , "+0.34" -- 2 + , "+0.34" -- 3 + , "0" -- 8 + , "0" -- 9 + , "0" -- 10 + , "0" -- 11 + ] + , HU.testCase "Round: negate r3" $ do + render Money.Round (negate r3) @?= + [ "-0.34" -- 0 + , "-0.34" -- 1 + , "-0.34" -- 2 + , "-0.34" -- 3 + , "0" -- 8 + , "0" -- 9 + , "0" -- 10 + , "0" -- 11 + ] + , HU.testCase "Floor: r1" $ do + render Money.Floor r1 @?= + [ "1023004567.89" -- 0 + , "1,023,004,567.89" -- 1 + , "+1023004567.89" -- 2 + , "+1,023,004,567.89" -- 3 + , "1023004567" -- 8 + , "1,023,004,567" -- 9 + , "+1023004567" -- 10 + , "+1,023,004,567" -- 11 + ] + , HU.testCase "Floor: negate r1" $ do + render Money.Floor (negate r1) @?= + [ "-1023004567.90" -- 0 + , "-1,023,004,567.90" -- 1 + , "-1023004567.90" -- 2 + , "-1,023,004,567.90" -- 3 + , "-1023004568" -- 8 + , "-1,023,004,568" -- 9 + , "-1023004568" -- 10 + , "-1,023,004,568" -- 11 + ] + , HU.testCase "Floor: r2" $ do + render Money.Floor r2 @?= + [ "1.23" -- 0 + , "1.23" -- 1 + , "+1.23" -- 2 + , "+1.23" -- 3 + , "1" -- 8 + , "1" -- 9 + , "+1" -- 10 + , "+1" -- 11 + ] + , HU.testCase "Floor: negate r2" $ do + render Money.Floor (negate r2) @?= + [ "-1.23" -- 0 + , "-1.23" -- 1 + , "-1.23" -- 2 + , "-1.23" -- 3 + , "-2" -- 8 + , "-2" -- 9 + , "-2" -- 10 + , "-2" -- 11 + ] + , HU.testCase "Floor: r3" $ do + render Money.Floor r3 @?= + [ "0.34" -- 0 + , "0.34" -- 1 + , "+0.34" -- 2 + , "+0.34" -- 3 + , "0" -- 8 + , "0" -- 9 + , "0" -- 10 + , "0" -- 11 + ] + , HU.testCase "Floor: negate r3" $ do + render Money.Floor (negate r3) @?= + [ "-0.35" -- 0 + , "-0.35" -- 1 + , "-0.35" -- 2 + , "-0.35" -- 3 + , "-1" -- 8 + , "-1" -- 9 + , "-1" -- 10 + , "-1" -- 11 + ] + , HU.testCase "Ceiling: r1" $ do + render Money.Ceiling r1 @?= + [ "1023004567.90" -- 0 + , "1,023,004,567.90" -- 1 + , "+1023004567.90" -- 2 + , "+1,023,004,567.90" -- 3 + , "1023004568" -- 8 + , "1,023,004,568" -- 9 + , "+1023004568" -- 10 + , "+1,023,004,568" -- 11 + ] + , HU.testCase "Ceiling: negate r1" $ do + render Money.Ceiling (negate r1) @?= + [ "-1023004567.89" -- 0 + , "-1,023,004,567.89" -- 1 + , "-1023004567.89" -- 2 + , "-1,023,004,567.89" -- 3 + , "-1023004567" -- 8 + , "-1,023,004,567" -- 9 + , "-1023004567" -- 10 + , "-1,023,004,567" -- 11 + ] + , HU.testCase "Ceiling: r2" $ do + render Money.Ceiling r2 @?= + [ "1.23" -- 0 + , "1.23" -- 1 + , "+1.23" -- 2 + , "+1.23" -- 3 + , "2" -- 8 + , "2" -- 9 + , "+2" -- 10 + , "+2" -- 11 + ] + , HU.testCase "Ceiling: negate r2" $ do + render Money.Ceiling (negate r2) @?= + [ "-1.23" -- 0 + , "-1.23" -- 1 + , "-1.23" -- 2 + , "-1.23" -- 3 + , "-1" -- 8 + , "-1" -- 9 + , "-1" -- 10 + , "-1" -- 11 + ] + , HU.testCase "Ceiling: r3" $ do + render Money.Ceiling r3 @?= + [ "0.35" -- 0 + , "0.35" -- 1 + , "+0.35" -- 2 + , "+0.35" -- 3 + , "1" -- 8 + , "1" -- 9 + , "+1" -- 10 + , "+1" -- 11 + ] + , HU.testCase "Ceiling: negate r3" $ do + render Money.Ceiling (negate r3) @?= + [ "-0.34" -- 0 + , "-0.34" -- 1 + , "-0.34" -- 2 + , "-0.34" -- 3 + , "0" -- 8 + , "0" -- 9 + , "0" -- 10 + , "0" -- 11 + ] + + , HU.testCase "Truncate: r1" $ do + render Money.Truncate r1 @?= render Money.Floor r1 + + , HU.testCase "Truncate: negate r1" $ do + render Money.Truncate (negate r1) @?= render Money.Ceiling (negate r1) + + , HU.testCase "Truncate: r2" $ do + render Money.Truncate r2 @?= render Money.Floor r2 + + , HU.testCase "Truncate: negate r2" $ do + render Money.Truncate (negate r2) @?= render Money.Ceiling (negate r2) + + , HU.testCase "Truncate: r3" $ do + render Money.Truncate r3 @?= render Money.Floor r3 + + , HU.testCase "Truncate: negate r3" $ do + render Money.Truncate (negate r3) @?= render Money.Ceiling (negate r3) + ] + where + r1 :: Rational = 1023004567895 % 1000 + r2 :: Rational = 123 % 100 + r3 :: Rational = 345 % 1000 + + render :: Money.Approximation -> Rational -> [String] + render a r = + [ fromJust $ Money.rationalToDecimal a False Nothing '.' 2 r -- 0 + , fromJust $ Money.rationalToDecimal a False (Just ',') '.' 2 r -- 1 + , fromJust $ Money.rationalToDecimal a True Nothing '.' 2 r -- 2 + , fromJust $ Money.rationalToDecimal a True (Just ',') '.' 2 r -- 3 + , fromJust $ Money.rationalToDecimal a False Nothing '.' 0 r -- 8 + , fromJust $ Money.rationalToDecimal a False (Just ',') '.' 0 r -- 9 + , fromJust $ Money.rationalToDecimal a True Nothing '.' 0 r -- 10 + , fromJust $ Money.rationalToDecimal a True (Just ',') '.' 0 r -- 11 + ] + +testRationalFromDecimal :: Tasty.TestTree +testRationalFromDecimal = + Tasty.testGroup "rationalFromDecimal" + [ QC.testProperty "Unsupported separators" $ + let mbadsep :: QC.Gen Char = QC.suchThat QC.arbitrary Char.isDigit + mgoodsep :: QC.Gen Char = QC.suchThat QC.arbitrary (not . Char.isDigit) + in QC.forAll ((,,) <$> mbadsep <*> mbadsep <*> mgoodsep) $ + \(s1 :: Char, s2 :: Char, s3 :: Char) -> + let f = Money.rationalFromDecimal + in (f Nothing s1 (error "untouched") === Nothing) .&&. + (f (Just s1) s2 (error "untouched") === Nothing) .&&. + (f (Just s1) s1 (error "untouched") === Nothing) .&&. + (f (Just s3) s3 (error "untouched") === Nothing) + + , QC.testProperty "Lossy roundtrip" $ + -- We check that the roundtrip results in a close amount with a fractional + -- difference of up to one. + let gen = (,) <$> genDecimalSeps <*> QC.arbitrary + in QC.forAll gen $ \( (yst :: Maybe Char, sd :: Char) + , (r :: Rational, plus :: Bool, digs :: Word8, + aprox :: Money.Approximation) ) -> + let Just dec = Money.rationalToDecimal aprox plus yst sd digs r + Just r' = Money.rationalFromDecimal yst sd dec + in 1 > abs (abs r - abs r') + ] + testDense :: forall currency . KnownSymbol currency @@ -142,16 +447,20 @@ [ QC.testProperty "read . show == id" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> x === read (show x) + , QC.testProperty "read . show . Just == Just " $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> Just x === read (show (Just x)) + , QC.testProperty "fromSomeDense . someDense == Just" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> Just x === Money.fromSomeDense (Money.toSomeDense x) + , QC.testProperty "fromSomeDense works only for same currency" $ QC.forAll QC.arbitrary $ \(dr :: Money.SomeDense) -> (Money.someDenseCurrency dr /= symbolVal pc) ==> isNothing (Money.fromSomeDense dr :: Maybe (Money.Dense currency)) + , QC.testProperty "withSomeDense" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> let dr = Money.toSomeDense x @@ -159,6 +468,45 @@ (show x, dr, Money.toSomeDense (x + 1)) === (show x', Money.toSomeDense x', Money.toSomeDense (x' + 1)) + , QC.testProperty "denseCurrency" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Money.denseCurrency x === symbolVal pc + + , QC.testProperty "denseToDecimal: Same as rationalToDecimal" $ + let gen = (,) <$> genDecimalSeps <*> QC.arbitrary + in QC.forAll gen $ \( (yst :: Maybe Char, sd :: Char) + , (dns :: Money.Dense currency, plus :: Bool, + digs :: Word8, aprox :: Money.Approximation) ) -> + let ydnsd1 = Money.denseToDecimal aprox plus yst sd digs (Proxy :: Proxy '(1,1)) dns + ydnsd100 = Money.denseToDecimal aprox plus yst sd digs (Proxy :: Proxy '(100,1)) dns + yrd1 = Money.rationalToDecimal aprox plus yst sd digs (toRational dns) + yrd100 = Money.rationalToDecimal aprox plus yst sd digs (toRational dns * 100) + in (ydnsd1 === yrd1) .&&. (ydnsd100 === yrd100) + + , QC.testProperty "denseFromDecimal: Same as rationalFromDecimal" $ + QC.forAll genDecimal $ \(dec :: String, yts :: Maybe Char, ds :: Char) -> + let Just r = Money.rationalFromDecimal yts ds dec + Just dns = Money.denseFromDecimal yts ds dec + in r === toRational (dns :: Money.Dense currency) + +#ifdef HAS_vector_space + , HU.testCase "AdditiveGroup: zeroV" $ + (AG.zeroV :: Money.Dense currency) @?= Money.dense' (0%1) + , QC.testProperty "AdditiveGroup: negateV" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + AG.negateV x === negate x + , QC.testProperty "AdditiveGroup: ^+^" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency, y) -> + x AG.^+^ y === x + y + , QC.testProperty "AdditiveGroup: ^-^" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency, y) -> + x AG.^-^ y === x - y + , QC.testProperty "VectorSpace: *^" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency, y) -> + (toRational x VS.*^ y === x * y) .&&. + (toRational y VS.*^ x === x * y) +#endif + #ifdef HAS_aeson , QC.testProperty "Aeson encoding roundtrip" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> @@ -291,6 +639,7 @@ , testExchangeRate (Proxy :: Proxy "XAU") (Proxy :: Proxy "XAU") ] + testDiscrete :: forall (currency :: Symbol) (unit :: Symbol) . ( Money.GoodScale (Money.Scale currency unit) @@ -327,6 +676,28 @@ === (show x', Money.toSomeDiscrete x', Money.toSomeDiscrete (x' + 1)) ) :: QC.Property + , QC.testProperty "discreteCurrency" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Money.discreteCurrency x === symbolVal pc + +#ifdef HAS_vector_space + , HU.testCase "AdditiveGroup: zeroV" $ + (AG.zeroV :: Money.Discrete currency unit) @?= Money.discrete 0 + , QC.testProperty "AdditiveGroup: negateV" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + AG.negateV x === negate x + , QC.testProperty "AdditiveGroup: ^+^" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit, y) -> + x AG.^+^ y === x + y + , QC.testProperty "AdditiveGroup: ^-^" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit, y) -> + x AG.^-^ y === x - y + , QC.testProperty "VectorSpace: *^" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit, y) -> + (toInteger x VS.*^ y === x * y) .&&. + (toInteger y VS.*^ x === x * y) +#endif + #ifdef HAS_aeson , QC.testProperty "Aeson encoding roundtrip" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> @@ -456,14 +827,14 @@ xr === xr . id , QC.testProperty "Category: composition with inverse" $ QC.forAll QC.arbitrary $ \(xr1 :: Money.ExchangeRate src dst) -> - (1 === Money.fromExchangeRate (xr1 . Money.flipExchangeRate xr1)) .&&. - (1 === Money.fromExchangeRate (Money.flipExchangeRate xr1 . xr1)) + (1 === Money.exchangeRateToRational (xr1 . Money.exchangeRateRecip xr1)) .&&. + (1 === Money.exchangeRateToRational (Money.exchangeRateRecip xr1 . xr1)) , QC.testProperty "Category: composition with other" $ QC.forAll QC.arbitrary $ \(xr1 :: Money.ExchangeRate src dst, xr2 :: Money.ExchangeRate dst src) -> - let a = Money.fromExchangeRate xr1 * Money.fromExchangeRate xr2 - in (a === Money.fromExchangeRate (xr1 . xr2)) .&&. - (a === Money.fromExchangeRate (xr2 . xr1)) + let a = Money.exchangeRateToRational xr1 * Money.exchangeRateToRational xr2 + in (a === Money.exchangeRateToRational (xr1 . xr2)) .&&. + (a === Money.exchangeRateToRational (xr2 . xr1)) , QC.testProperty "read . show == id" $ QC.forAll QC.arbitrary $ \(xr :: Money.ExchangeRate src dst) -> @@ -473,25 +844,25 @@ Just xr === read (show (Just xr)) , QC.testProperty "flipExchangeRate . flipExchangeRate == id" $ QC.forAll QC.arbitrary $ \(xr :: Money.ExchangeRate src dst) -> - let xr' = Money.flipExchangeRate xr - in (Money.fromExchangeRate xr /= Money.fromExchangeRate xr') - ==> (xr === Money.flipExchangeRate xr') + let xr' = Money.exchangeRateRecip xr + in (Money.exchangeRateToRational xr /= Money.exchangeRateToRational xr') + ==> (xr === Money.exchangeRateRecip xr') , QC.testProperty "exchange (flipExchangeRate x) . exchange x == id" $ QC.forAll QC.arbitrary $ \( c0 :: Money.Dense src , xr :: Money.ExchangeRate src dst - ) -> c0 === Money.exchange (Money.flipExchangeRate xr) + ) -> c0 === Money.exchange (Money.exchangeRateRecip xr) (Money.exchange xr c0) - , QC.testProperty "x == 1 ===> exchange x == id" $ + , QC.testProperty "x == 1 ==> exchange x == id" $ QC.forAll QC.arbitrary $ \( c0 :: Money.Dense src ) -> let Just xr = Money.exchangeRate 1 in toRational c0 === toRational (Money.exchange xr c0) - , QC.testProperty "x /= 1 ===> exchange x /= id" $ + , QC.testProperty "x /= 1 ==> exchange x /= id" $ QC.forAll QC.arbitrary $ \( c0 :: Money.Dense src , xr :: Money.ExchangeRate src dst - ) -> (Money.fromExchangeRate xr /= 1) + ) -> (Money.exchangeRateToRational xr /= 1 && toRational c0 /= 0) ==> (toRational c0 /= toRational (Money.exchange xr c0)) , QC.testProperty "fromSomeExchangeRate . someExchangeRate == Just" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> @@ -508,6 +879,23 @@ in Money.withSomeExchangeRate dr $ \x' -> (show x, dr) === (show x', Money.toSomeExchangeRate x') + , QC.testProperty "exchangeRateToDecimal: Same as rationalToDecimal" $ + let gen = (,) <$> genDecimalSeps <*> QC.arbitrary + in QC.forAll gen $ \( (yst :: Maybe Char, sd :: Char) + , (xr :: Money.ExchangeRate src dst, digs :: Word8, + aprox :: Money.Approximation ) ) -> + let xrd = Money.exchangeRateToDecimal aprox yst sd digs xr + rd = Money.rationalToDecimal aprox False yst sd digs + (Money.exchangeRateToRational xr) + in xrd === rd + + , QC.testProperty "exchangeRateFromDecimal: Same as rationalFromDecimal" $ + QC.forAll genDecimal $ \(dec :: String, yts :: Maybe Char, ds :: Char) -> + let Just r = Money.rationalFromDecimal yts ds dec + yxr = Money.exchangeRateFromDecimal yts ds dec + :: Maybe (Money.ExchangeRate src dst) + in (r > 0) ==> (Just r === fmap Money.exchangeRateToRational yxr) + #ifdef HAS_aeson , QC.testProperty "Aeson encoding roundtrip" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> @@ -620,6 +1008,59 @@ #endif ] + +testDiscreteFromDecimal :: Tasty.TestTree +testDiscreteFromDecimal = + Tasty.testGroup "discreteFromDecimal" + [ HU.testCase "Too large" $ do + Money.discreteFromDecimal Nothing '.' "0.053" + @?= (Nothing :: Maybe (Money.Discrete "USD" "cent")) + Money.discreteFromDecimal (Just ',') '.' "0.253" + @?= (Nothing :: Maybe (Money.Discrete "USD" "cent")) + + , HU.testCase "USD cent, small, zero" $ do + let dis = 0 :: Money.Discrete "USD" "cent" + f = Money.discreteFromDecimal + f Nothing '.' "0" @?= Just dis + f Nothing '.' "+0" @?= Just dis + f Nothing '.' "-0" @?= Just dis + f (Just ',') '.' "0" @?= Just dis + f (Just ',') '.' "+0" @?= Just dis + f (Just ',') '.' "-0" @?= Just dis + + , HU.testCase "USD cent, small, positive" $ do + let dis = 25 :: Money.Discrete "USD" "cent" + f = Money.discreteFromDecimal + f Nothing '.' "0.25" @?= Just dis + f Nothing '.' "+0.25" @?= Just dis + f (Just ',') '.' "0.25" @?= Just dis + f (Just ',') '.' "+0.25" @?= Just dis + + , HU.testCase "USD cent, small, negative" $ do + let dis = -25 :: Money.Discrete "USD" "cent" + f = Money.discreteFromDecimal + f Nothing '.' "-0.25" @?= Just dis + f Nothing '.' "-0.25" @?= Just dis + f (Just ',') '.' "-0.25" @?= Just dis + f (Just ',') '.' "-0.25" @?= Just dis + + , HU.testCase "USD cent, big, positive" $ do + let dis = 102300456789 :: Money.Discrete "USD" "cent" + f = Money.discreteFromDecimal + f Nothing '.' "1023004567.89" @?= Just dis + f Nothing '.' "+1023004567.89" @?= Just dis + f (Just ',') '.' "1,023,004,567.89" @?= Just dis + f (Just ',') '.' "+1,023,004,567.89" @?= Just dis + + , HU.testCase "USD cent, big, negative" $ do + let dis = -102300456789 :: Money.Discrete "USD" "cent" + f = Money.discreteFromDecimal + f Nothing '.' "-1023004567.89" @?= Just dis + f Nothing '.' "-1023004567.89" @?= Just dis + f (Just ',') '.' "-1,023,004,567.89" @?= Just dis + f (Just ',') '.' "-1,023,004,567.89" @?= Just dis + ] + testRounding :: forall (currency :: Symbol) (unit :: Symbol) . (Money.GoodScale (Money.Scale currency unit), KnownSymbol currency) @@ -628,26 +1069,26 @@ -> Tasty.TestTree testRounding _ _ = Tasty.testGroup "Rounding" - [ QC.testProperty "floor" $ QC.forAll QC.arbitrary (g Money.floor) - , QC.testProperty "ceiling" $ QC.forAll QC.arbitrary (g Money.ceiling) - , QC.testProperty "round" $ QC.forAll QC.arbitrary (g Money.round) - , QC.testProperty "truncate" $ QC.forAll QC.arbitrary (g Money.truncate) - , QC.testProperty "floor no reminder" $ QC.forAll QC.arbitrary (h Money.floor) - , QC.testProperty "ceiling no reminder" $ QC.forAll QC.arbitrary (h Money.ceiling) - , QC.testProperty "round no reminder" $ QC.forAll QC.arbitrary (h Money.round) - , QC.testProperty "truncate no reminder" $ QC.forAll QC.arbitrary (h Money.truncate) + [ QC.testProperty "floor" $ QC.forAll QC.arbitrary (g (Money.discreteFromDense Money.Floor)) + , QC.testProperty "ceiling" $ QC.forAll QC.arbitrary (g (Money.discreteFromDense Money.Ceiling)) + , QC.testProperty "round" $ QC.forAll QC.arbitrary (g (Money.discreteFromDense Money.Round)) + , QC.testProperty "truncate" $ QC.forAll QC.arbitrary (g (Money.discreteFromDense Money.Truncate)) + , QC.testProperty "floor no reminder" $ QC.forAll QC.arbitrary (h (Money.discreteFromDense Money.Floor)) + , QC.testProperty "ceiling no reminder" $ QC.forAll QC.arbitrary (h (Money.discreteFromDense Money.Ceiling)) + , QC.testProperty "round no reminder" $ QC.forAll QC.arbitrary (h (Money.discreteFromDense Money.Round)) + , QC.testProperty "truncate no reminder" $ QC.forAll QC.arbitrary (h (Money.discreteFromDense Money.Truncate)) ] where g :: (Money.Dense currency -> (Money.Discrete' currency (Money.Scale currency unit), Money.Dense currency)) -> Money.Dense currency -> QC.Property - g f = \x -> x === case f x of (y, z) -> Money.fromDiscrete y + z + g f = \x -> x === case f x of (y, z) -> Money.denseFromDiscrete y + z h :: (Money.Dense currency -> (Money.Discrete' currency (Money.Scale currency unit), Money.Dense currency)) -> Money.Discrete currency unit -> QC.Property - h f = \x -> (Money.fromDiscrete x) === case f (Money.fromDiscrete x) of - (y, 0) -> Money.fromDiscrete y + h f = \x -> (Money.denseFromDiscrete x) === case f (Money.denseFromDiscrete x) of + (y, 0) -> Money.denseFromDiscrete y (_, _) -> error "testRounding.h: unexpected" hush :: Either a b -> Maybe b