diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2016, Renzo Carbonara +Copyright (c) 2016-2017, Renzo Carbonara All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,6 @@ The Haskell `safe-money` library offers type-safe and lossless encoding and 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`). diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,38 @@ +# 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. COMPILER WILL COMPLAIN: Changed the `Rep` suffix for a `Some` + prefix Everywhere. For example, `DenseRep` was renamed to `SomeDense`. + +* BREAKING CHANGE. COMPILER WILL COMPLAIN: 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 + `round` functions now return just `0` as a reminder if there's no significant + reminder, instead of `Nothing`. + +* Added instances for `serialise`. + +* Added instances for `xmlbf`. + +* Fixed `Show` instances so that surrounding parentheses are included when + necessary. + +* New currencies: Ripple, Litecoin, Ada, Monero. + + # Version 0.3 * BREAKING CHANGE: The `Data.Money` module was renamed to `Money`. diff --git a/safe-money.cabal b/safe-money.cabal --- a/safe-money.cabal +++ b/safe-money.cabal @@ -1,12 +1,12 @@ name: safe-money -version: 0.3 +version: 0.4 license: BSD3 license-file: LICENSE copyright: Copyright (c) Renzo Carbonara 2016-2017 author: Renzo Carbonara maintainer: renλren!zone stability: Experimental -tested-with: GHC==8.0.1 +tested-with: GHC==8.2.2, GHC==8.0.2, GHCJS homepage: https://github.com/k0001/safe-money bug-reports: https://github.com/k0001/safe-money/issues category: Money @@ -20,8 +20,8 @@ Type-safe and lossless encoding and manipulation of money, fiat currencies, crypto currencies and precious metals. . - Notice that the only mandatory dependencies of this package are @base@ and - @constraints@. The rest of the dependencies are optional but enabled by + NOTICE that the only mandatory dependencies of this package are @base@ and + @constraints@. The rest of the dependencies are OPTIONAL but enabled by default (except @store@ which is also disabled when building with GHCJS), they can be disabled with Cabal flags. @@ -39,16 +39,28 @@ if flag(aeson) build-depends: aeson (>=0.9) + cpp-options: -DHAS_aeson if flag(binary) build-depends: binary (>=0.7) + cpp-options: -DHAS_binary if flag(cereal) build-depends: cereal (>=0.5) + cpp-options: -DHAS_cereal if flag(deepseq) build-depends: deepseq (>=1.4) + cpp-options: -DHAS_deepseq if flag(hashable) build-depends: hashable (>=1.2) + cpp-options: -DHAS_hashable + if flag(serialise) + build-depends: serialise (>=0.2) + cpp-options: -DHAS_serialise if (flag(store) && !impl(ghcjs)) build-depends: store (>=0.2) + cpp-options: -DHAS_store + if flag(xmlbf) + build-depends: xmlbf (>=0.2), text + cpp-options: -DHAS_xmlbf test-suite test default-language: Haskell2010 @@ -56,20 +68,38 @@ hs-source-dirs: test main-is: Main.hs build-depends: - aeson, base, - binary, bytestring, - cereal, constraints, - deepseq, - hashable, safe-money, tasty, tasty-hunit, tasty-quickcheck - if (flag(store) || !impl(ghcjs)) + + if flag(aeson) + build-depends: aeson + cpp-options: -DHAS_aeson + if flag(binary) + build-depends: binary + cpp-options: -DHAS_binary + if flag(cereal) + build-depends: cereal + cpp-options: -DHAS_cereal + if flag(deepseq) + build-depends: deepseq + cpp-options: -DHAS_deepseq + if flag(hashable) + build-depends: hashable + cpp-options: -DHAS_hashable + if flag(serialise) + build-depends: serialise + cpp-options: -DHAS_serialise + if (flag(store) && !impl(ghcjs)) build-depends: store + cpp-options: -DHAS_store + if flag(xmlbf) + build-depends: xmlbf, text + cpp-options: -DHAS_xmlbf flag aeson description: Provide instances for @aeson@ @@ -87,12 +117,20 @@ description: Provide instances for @store@ default: True manual: True +flag deepseq + description: Provide instances for @deepseq@ + default: True + manual: True flag hashable description: Provide instances for @hashable@ default: True manual: True -flag deepseq - description: Provide instances for @deepseq@ +flag serialise + description: Provide instances for @serialise@ + default: True + manual: True +flag xmlbf + description: Provide instances for @xmlbf@ default: True manual: True diff --git a/src/Money.hs b/src/Money.hs --- a/src/Money.hs +++ b/src/Money.hs @@ -37,35 +37,29 @@ , I.flipExchangeRate , I.exchange -- * Serializable representations - , I.DenseRep - , I.toDenseRep - , I.mkDenseRep - , I.fromDenseRep - , I.withDenseRep - , I.denseRepCurrency - , I.denseRepAmount - , I.denseRepAmountNumerator - , I.denseRepAmountDenominator - , I.DiscreteRep - , I.toDiscreteRep - , I.mkDiscreteRep - , I.fromDiscreteRep - , I.withDiscreteRep - , I.discreteRepCurrency - , I.discreteRepScale - , I.discreteRepScaleNumerator - , I.discreteRepScaleDenominator - , I.discreteRepAmount - , I.ExchangeRateRep - , I.toExchangeRateRep - , I.mkExchangeRateRep - , I.fromExchangeRateRep - , I.withExchangeRateRep - , I.exchangeRateRepSrcCurrency - , I.exchangeRateRepDstCurrency - , I.exchangeRateRepRate - , I.exchangeRateRepRateNumerator - , I.exchangeRateRepRateDenominator + , I.SomeDense + , I.toSomeDense + , I.mkSomeDense + , I.fromSomeDense + , I.withSomeDense + , I.someDenseCurrency + , I.someDenseAmount + , I.SomeDiscrete + , I.toSomeDiscrete + , I.mkSomeDiscrete + , I.fromSomeDiscrete + , I.withSomeDiscrete + , I.someDiscreteCurrency + , I.someDiscreteScale + , I.someDiscreteAmount + , I.SomeExchangeRate + , I.toSomeExchangeRate + , I.mkSomeExchangeRate + , I.fromSomeExchangeRate + , I.withSomeExchangeRate + , I.someExchangeRateSrcCurrency + , I.someExchangeRateDstCurrency + , I.someExchangeRateRate ) where import qualified Money.Internal as I @@ -791,3 +785,30 @@ type instance I.Scale "ETH" "finney" = '(1000000000000000, 1) type instance I.Scale "ETH" "milliether" = '(1000000000000000, 1) type instance I.Scale "ETH" "wei" = '(1000000000000000000, 1) + +-- | Ada +type instance I.Scale "ADA" "ADA" = '(1000000, 1) +type instance I.Scale "ADA" "ada" = '(1, 1) +type instance I.Scale "ADA" "lovelace" = '(1000000, 1) + +-- | Litecoin +type instance I.Scale "LTC" "LTC" = '(100000000, 1) +type instance I.Scale "LTC" "litecoin" = '(1, 1) +type instance I.Scale "LTC" "lite" = '(1000, 1) +type instance I.Scale "LTC" "photon" = '(100000000, 1) + +-- | Ripple +type instance I.Scale "XRP" "XRP" = '(1000000, 1) +type instance I.Scale "XRP" "ripple" = '(1, 1) +type instance I.Scale "XRP" "drop" = '(1000000, 1) + +-- | Monero +type instance I.Scale "XMR" "XMR" = '(1000000000000, 1) +type instance I.Scale "XMR" "monero" = '(1, 1) +type instance I.Scale "XMR" "decinero" = '(10, 1) +type instance I.Scale "XMR" "centinero" = '(100, 1) +type instance I.Scale "XMR" "millinero" = '(1000, 1) +type instance I.Scale "XMR" "micronero" = '(1000000, 1) +type instance I.Scale "XMR" "nanonero" = '(1000000000, 1) +type instance I.Scale "XMR" "piconero" = '(1000000000000, 1) + diff --git a/src/Money/Internal.hs b/src/Money/Internal.hs --- a/src/Money/Internal.hs +++ b/src/Money/Internal.hs @@ -7,1182 +7,1495 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} -{-# 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 - , DenseRep - , toDenseRep - , mkDenseRep - , fromDenseRep - , withDenseRep - , denseRepCurrency - , denseRepAmount - , denseRepAmountNumerator - , denseRepAmountDenominator - , DiscreteRep - , toDiscreteRep - , mkDiscreteRep - , fromDiscreteRep - , withDiscreteRep - , discreteRepCurrency - , discreteRepScale - , discreteRepScaleNumerator - , discreteRepScaleDenominator - , discreteRepAmount - , ExchangeRateRep - , toExchangeRateRep - , mkExchangeRateRep - , fromExchangeRateRep - , withExchangeRateRep - , exchangeRateRepSrcCurrency - , exchangeRateRepDstCurrency - , exchangeRateRepRate - , exchangeRateRepRateNumerator - , exchangeRateRepRateDenominator - ) where - -import Control.Applicative (empty) -import Control.Monad ((<=<)) -import Data.Constraint (Dict(Dict)) -import Data.Proxy (Proxy(..)) -import Data.Ratio ((%), numerator, denominator) -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 Text.Read (readPrec) -import Unsafe.Coerce (unsafeCoerce) - -#ifdef VERSION_aeson -import qualified Data.Aeson as Ae -#endif - -#ifdef VERSION_binary -import qualified Data.Binary as Binary -#endif - -#ifdef VERSION_cereal -import qualified Data.Serialize as Cereal -#endif - -#ifdef VERSION_deepseq -import Control.DeepSeq (NFData) -#endif - -#ifdef VERSION_hashable -import Data.Hashable (Hashable) -#endif - -#ifdef VERSION_store -import qualified Data.Store as Store -#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', or --- 'fromInteger' / 'fromIntegral' if that suffices. --- --- /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, Fractional, GHC.Generic) - -instance forall currency. KnownSymbol currency => Show (Dense currency) where - show = \(Dense r0) -> - let c = symbolVal (Proxy :: Proxy currency) - in concat [ "Dense ", show c, " (", show r0, ")" ] - -instance forall currency. KnownSymbol currency => Read (Dense currency) where - readPrec = do - let c = symbolVal (Proxy :: Proxy currency) - _ <- ReadPrec.lift (ReadP.string ("Dense " ++ show c ++ " ")) - maybe empty pure =<< fmap dense 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) --- @ --- --- This function returns 'Nothing' in case the given 'Rational' is 'infinity' or --- 'notANumber'. -dense :: Rational -> Maybe (Dense currency) -dense = \r0 -> - if (infinity == r0 || notANumber == r0) - 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 - show = \d0@(Discrete i0) -> - let c = symbolVal (Proxy :: Proxy currency) - in concat [ "Discrete ", show c, " (", show (scale d0), ") ", show i0 ] - -instance forall currency scale. - ( KnownSymbol currency, GoodScale scale - ) => Read (Discrete' currency scale) where - readPrec = do - let c = symbolVal (Proxy :: Proxy currency) - s = scale (Proxy :: Proxy scale) - _ <- ReadPrec.lift (ReadP.string - ("Discrete " ++ show c ++ " (" ++ show s ++ ") ") ) - Discrete <$> 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, Maybe (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 - !ycrest | r0 == r2 = Nothing - | otherwise = Just (Dense (r0 - r2)) - !d2 = Discrete i2 - in (d2, ycrest) -{-# 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 == (x, 'Nothing') --- @ --- --- 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, 'Nothing') -> y --- (y, 'Just' z) -> y + z --- @ -round - :: GoodScale scale - => Dense currency - -> (Discrete' currency scale, Maybe (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 == (x, 'Nothing') --- @ --- --- Otherwise, if @x@ is not representable in its @currency@'s @unit@ 'Scale', --- then the following holds: --- --- @ --- 'ceiling' x == (y, 'Just' z) --- @ --- --- @ --- x /= y --- @ --- --- @ --- z < 'zero' --- @ --- --- Proof that 'ceiling' doesn't lose money: --- --- @ --- x == case 'ceiling' x of --- (y, 'Nothing') -> y --- (y, 'Just' z) -> y + z --- @ -ceiling - :: GoodScale scale - => Dense currency - -> (Discrete' currency scale, Maybe (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 == (x, 'Nothing') --- @ --- --- Otherwise, if @x@ is not representable in its @currency@'s @unit@ 'Scale', --- then the following holds: --- --- @ --- 'floor' x == (y, 'Just' z) --- @ --- --- @ --- x /= y --- @ --- --- @ --- z > 'zero' --- @ --- --- Proof that 'floor' doesn't lose money: --- --- @ --- x == case 'floor' x of --- (y, 'Nothing') -> y --- (y, 'Just' z) -> y + z --- @ -floor - :: GoodScale scale - => Dense currency - -> (Discrete' currency scale, Maybe (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 == (x, 'Nothing') --- @ --- --- 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, 'Nothing') -> y --- (y, 'Just' z) -> y + z --- @ -truncate - :: GoodScale scale - => Dense currency - -> (Discrete' currency scale, Maybe (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) - -instance forall src dst. - ( KnownSymbol src, KnownSymbol dst - ) => Show (ExchangeRate src dst) where - show = \(ExchangeRate r0) -> - let s = symbolVal (Proxy :: Proxy src) - d = symbolVal (Proxy :: Proxy dst) - in concat [ "ExchangeRate ", show s, " ", show d, " (", show r0, ")" ] - -instance forall src dst. - ( KnownSymbol src, KnownSymbol dst - ) => Read (ExchangeRate (src :: Symbol) (dst :: Symbol)) where - readPrec = 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 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'. --- --- 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 #-} - --------------------------------------------------------------------------------- --- DenseRep - --- | 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 'mkDenseRep' function. --- --- In order to be able to effectively serialize a 'DenseRep' value, you --- need to serialize the following three values (which are the eventual --- arguments to 'mkDenseRep'): --- --- * 'denseRepCurrency' --- * 'denseRepAmountNumerator' --- * 'denseRepAmountDenominator' -data DenseRep = DenseRep - { _denseRepCurrency :: !String - , _denseRepAmountNumerator :: !Integer - , _denseRepAmountDenominator :: !Integer -- ^ Positive, non-zero. - } deriving (Eq, Show, GHC.Generic) - --- | WARNING: This instance does not compare monetary amounts, it just helps you --- sort 'DenseRep' values in case you need to put them in a 'Data.Set.Set' or --- similar. -deriving instance Ord DenseRep - --- | Currency name. -denseRepCurrency :: DenseRep -> String -denseRepCurrency = _denseRepCurrency -{-# INLINABLE denseRepCurrency #-} - --- | Currency unit amount. -denseRepAmount :: DenseRep -> Rational -denseRepAmount = \dr -> - denseRepAmountNumerator dr % denseRepAmountDenominator dr -{-# INLINABLE denseRepAmount #-} - --- | Currency unit amount numerator. -denseRepAmountNumerator :: DenseRep -> Integer -denseRepAmountNumerator = _denseRepAmountNumerator -{-# INLINABLE denseRepAmountNumerator #-} - --- | Currency unit amount denominator. Positive, non-zero. -denseRepAmountDenominator :: DenseRep -> Integer -denseRepAmountDenominator = _denseRepAmountDenominator -{-# INLINABLE denseRepAmountDenominator #-} - --- | Build a 'DenseRep' from raw values. --- --- This function is intended for deserialization purposes. You need to convert --- this 'DenseRep' value to a 'Dense' value in order to do any arithmetic --- operation on the monetary value. -mkDenseRep - :: String -- ^ Currency. ('denseRepCurrency') - -> Integer -- ^ Scale numerator. ('denseRepAmountNumerator') - -> Integer -- ^ Scale denominator (positive, non zero). ('denseRepAmountDenominator') - -> Maybe DenseRep -mkDenseRep = \c n d -> case d > 0 of - False -> Nothing - True -> Just (DenseRep c n d) -{-# INLINABLE mkDenseRep #-} - --- | Convert a 'Dense' to a 'DenseRep' for ease of serialization. -toDenseRep :: KnownSymbol currency => Dense currency -> DenseRep -toDenseRep = \(Dense r0 :: Dense currency) -> - let c = symbolVal (Proxy :: Proxy currency) - in DenseRep c (numerator r0) (denominator r0) -{-# INLINABLE toDenseRep #-} - --- | Attempt to convert a 'DenseRep' to a 'Dense', provided you know the target --- @currency@. -fromDenseRep - :: forall currency - . KnownSymbol currency - => DenseRep - -> Maybe (Dense currency) -- ^ -fromDenseRep = \dr -> - case denseRepCurrency dr == symbolVal (Proxy :: Proxy currency) of - False -> Nothing - True -> Just (Dense (denseRepAmount dr)) -{-# INLINABLE fromDenseRep #-} - --- | Convert a 'DenseRep' 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 'fromDenseRep' directly. -withDenseRep - :: DenseRep - -> (forall currency. KnownSymbol currency => Dense currency -> r) - -> r -- ^ -withDenseRep dr = \f -> - case someSymbolVal (denseRepCurrency dr) of - SomeSymbol (Proxy :: Proxy currency) -> - f (Dense (denseRepAmount dr) :: Dense currency) -{-# INLINABLE withDenseRep #-} - --------------------------------------------------------------------------------- --- DiscreteRep - --- | 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 'mkDiscreteRep' function. --- --- In order to be able to effectively serialize a 'DiscreteRep' value, you need --- to serialize the following four values (which are the eventual arguments to --- 'mkDiscreteRep'): --- --- * 'discreteRepCurrency' --- * 'discreteRepScaleNumerator' --- * 'discreteRepScaleDenominator' --- * 'discreteRepAmount' -data DiscreteRep = DiscreteRep - { _discreteRepCurrency :: !String -- ^ Currency name. - , _discreteRepScaleNumerator :: !Integer -- ^ Positive, non-zero. - , _discreteRepScaleDenominator :: !Integer -- ^ Positive, non-zero. - , _discreteRepAmount :: !Integer -- ^ Amount of unit. - } deriving (Eq, Show, GHC.Generic) - --- | WARNING: This instance does not compare monetary amounts, it just helps you --- sort 'DiscreteRep' values in case you need to put them in a 'Data.Set.Set' or --- similar. -deriving instance Ord DiscreteRep - --- | Currency name. -discreteRepCurrency :: DiscreteRep -> String -discreteRepCurrency = _discreteRepCurrency -{-# INLINABLE discreteRepCurrency #-} - --- | Positive, non-zero. -discreteRepScaleNumerator :: DiscreteRep -> Integer -discreteRepScaleNumerator = _discreteRepScaleNumerator -{-# INLINABLE discreteRepScaleNumerator #-} - --- | Positive, non-zero. -discreteRepScaleDenominator :: DiscreteRep -> Integer -discreteRepScaleDenominator = _discreteRepScaleDenominator -{-# INLINABLE discreteRepScaleDenominator #-} - --- | Amount of currency unit. -discreteRepAmount :: DiscreteRep -> Integer -discreteRepAmount = _discreteRepAmount -{-# INLINABLE discreteRepAmount #-} - --- | Positive, non-zero. -discreteRepScale :: DiscreteRep -> Rational -discreteRepScale = \dr -> - discreteRepScaleNumerator dr % discreteRepScaleDenominator dr -{-# INLINABLE discreteRepScale #-} - - --- | Internal. Build a 'DiscreteRep' from raw values. --- --- This function is intended for deserialization purposes. You need to convert --- this 'DiscreteRep' value to a 'Discrete' vallue in order to do any arithmetic --- operation on the monetary value. -mkDiscreteRep - :: String -- ^ Currency name. ('discreteRepCurrency') - -> Integer -- ^ Scale numerator. Positive, non-zero. ('discreteRepScaleNumerator') - -> Integer -- ^ Scale denominator. Positive, non-zero. ('discreteRepScaleDenominator') - -> Integer -- ^ Amount of unit. ('discreteRepAmount') - -> Maybe DiscreteRep -mkDiscreteRep = \c n d a -> case (n > 0) && (d > 0) of - False -> Nothing - True -> Just (DiscreteRep c n d a) -{-# INLINABLE mkDiscreteRep #-} - --- | Convert a 'Discrete' to a 'DiscreteRep' for ease of serialization. -toDiscreteRep - :: (KnownSymbol currency, GoodScale scale) - => Discrete' currency scale - -> DiscreteRep -- ^ -toDiscreteRep = \(Discrete i0 :: Discrete' currency scale) -> - let c = symbolVal (Proxy :: Proxy currency) - n = natVal (Proxy :: Proxy (Fst scale)) - d = natVal (Proxy :: Proxy (Snd scale)) - in DiscreteRep c n d i0 -{-# INLINABLE toDiscreteRep #-} - --- | Attempt to convert a 'DiscreteRep' to a 'Discrete', provided you know the --- target @currency@ and @unit@. -fromDiscreteRep - :: forall currency scale - . (KnownSymbol currency, GoodScale scale) - => DiscreteRep - -> Maybe (Discrete' currency scale) -- ^ -fromDiscreteRep = \dr -> - if (discreteRepCurrency dr == symbolVal (Proxy :: Proxy currency)) && - (discreteRepScaleNumerator dr == natVal (Proxy :: Proxy (Fst scale))) && - (discreteRepScaleDenominator dr == natVal (Proxy :: Proxy (Snd scale))) - then Just (Discrete (discreteRepAmount dr)) - else Nothing -{-# INLINABLE fromDiscreteRep #-} - --- | Convert a 'DiscreteRep' 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 'fromDiscreteRep' directly. --- --- Notice that you may need to add an explicit type to the result of this --- function in order to keep the compiler happy. -withDiscreteRep - :: forall r - . DiscreteRep - -> ( forall currency scale. - ( KnownSymbol currency - , GoodScale scale - ) => Discrete' currency scale - -> r ) - -> r -- ^ -withDiscreteRep dr = \f -> - case someSymbolVal (discreteRepCurrency dr) of - SomeSymbol (Proxy :: Proxy currency) -> - case someNatVal (discreteRepScaleNumerator dr) of - Nothing -> error "withDiscreteRep: impossible: numerator < 0" - Just (SomeNat (Proxy :: Proxy num)) -> - case someNatVal (discreteRepScaleDenominator dr) of - Nothing -> error "withDiscreteRep: impossible: denominator < 0" - Just (SomeNat (Proxy :: Proxy den)) -> - case mkGoodScale of - Nothing -> error "withDiscreteRep: impossible: mkGoodScale" - Just (Dict :: Dict (GoodScale '(num, den))) -> - f (Discrete (discreteRepAmount dr) - :: Discrete' currency '(num, den)) -{-# INLINABLE withDiscreteRep #-} - --------------------------------------------------------------------------------- --- ExchangeRateRep - --- | 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 'mkExchangeRateRep' function. --- --- In order to be able to effectively serialize an 'ExchangeRateRep' value, you --- need to serialize the following four values (which are the eventual arguments --- to 'mkExchangeRateRep'): --- --- * 'exchangeRateRepSrcCurrency' --- * 'exchangeRateRepDstCurrency' --- * 'exchangeRateRepRateNumerator' --- * 'exchangeRateRepRateDenominator' -data ExchangeRateRep = ExchangeRateRep - { _exchangeRateRepSrcCurrency :: !String - , _exchangeRateRepDstCurrency :: !String - , _exchangeRateRepRateNumerator :: !Integer -- ^ Positive, non-zero. - , _exchangeRateRepRateDenominator :: !Integer -- ^ Positive, non-zero. - } deriving (Eq, Show, GHC.Generic) - --- | WARNING: This instance does not compare monetary amounts, it just helps you --- sort 'ExchangeRateRep' values in case you need to put them in a --- 'Data.Set.Set' or similar. -deriving instance Ord ExchangeRateRep - --- | Source currency name. -exchangeRateRepSrcCurrency :: ExchangeRateRep -> String -exchangeRateRepSrcCurrency = _exchangeRateRepSrcCurrency -{-# INLINABLE exchangeRateRepSrcCurrency #-} - --- | Destination currency name. -exchangeRateRepDstCurrency :: ExchangeRateRep -> String -exchangeRateRepDstCurrency = _exchangeRateRepDstCurrency -{-# INLINABLE exchangeRateRepDstCurrency #-} - --- | Exchange rate. Positive, non-zero. -exchangeRateRepRate :: ExchangeRateRep -> Rational -exchangeRateRepRate = \x -> - exchangeRateRepRateNumerator x % _exchangeRateRepRateDenominator x -{-# INLINABLE exchangeRateRepRate #-} - --- | Exchange rate numerator. Positive, non-zero. -exchangeRateRepRateNumerator :: ExchangeRateRep -> Integer -exchangeRateRepRateNumerator = _exchangeRateRepRateNumerator -{-# INLINABLE exchangeRateRepRateNumerator #-} - --- | Exchange rate denominator. Positive, non-zero. -exchangeRateRepRateDenominator :: ExchangeRateRep -> Integer -exchangeRateRepRateDenominator = _exchangeRateRepRateDenominator -{-# INLINABLE exchangeRateRepRateDenominator #-} - --- | Internal. Build a 'ExchangeRateRep' from raw values. --- --- This function is intended for deserialization purposes. You need to convert --- this 'ExchangeRateRep' value to a 'ExchangeRate' value in order to do any --- arithmetic operation with the exchange rate. -mkExchangeRateRep - :: String -- ^ Source currency name. ('exchangeRateRepSrcCurrency') - -> String -- ^ Destination currency name. ('exchangeRateRepDstCurrency') - -> Integer -- ^ Exchange rate numerator. Positive, non-zero. ('exchangeRateRepRateNumerator') - -> Integer -- ^ Exchange rate denominator. Positive, non-zero. ('exchangeRateRepRateDenominator') - -> Maybe ExchangeRateRep -mkExchangeRateRep = \src dst n d -> case (n > 0) && (d > 0) of - False -> Nothing - True -> Just (ExchangeRateRep src dst n d) -{-# INLINABLE mkExchangeRateRep #-} - --- | Convert a 'ExchangeRate' to a 'DiscreteRep' for ease of serialization. -toExchangeRateRep - :: (KnownSymbol src, KnownSymbol dst) - => ExchangeRate src dst - -> ExchangeRateRep -- ^ -toExchangeRateRep = \(ExchangeRate r0 :: ExchangeRate src dst) -> - let src = symbolVal (Proxy :: Proxy src) - dst = symbolVal (Proxy :: Proxy dst) - in ExchangeRateRep src dst (numerator r0) (denominator r0) -{-# INLINABLE toExchangeRateRep #-} - --- | Attempt to convert a 'ExchangeRateRep' to a 'ExchangeRate', provided you --- know the target @src@ and @dst@ types. -fromExchangeRateRep - :: forall src dst - . (KnownSymbol src, KnownSymbol dst) - => ExchangeRateRep - -> Maybe (ExchangeRate src dst) -- ^ -fromExchangeRateRep = \x -> - if (exchangeRateRepSrcCurrency x == symbolVal (Proxy :: Proxy src)) && - (exchangeRateRepDstCurrency x == symbolVal (Proxy :: Proxy dst)) - then Just (ExchangeRate (exchangeRateRepRate x)) - else Nothing -{-# INLINABLE fromExchangeRateRep #-} - --- | Convert a 'ExchangeRateRep' 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 'fromExchangeRateRep' directly. -withExchangeRateRep - :: ExchangeRateRep - -> ( forall src dst. - ( KnownSymbol src - , KnownSymbol dst - ) => ExchangeRate src dst - -> r ) - -> r -- ^ -withExchangeRateRep x = \f -> - case someSymbolVal (exchangeRateRepSrcCurrency x) of - SomeSymbol (Proxy :: Proxy src) -> - case someSymbolVal (exchangeRateRepDstCurrency x) of - SomeSymbol (Proxy :: Proxy dst) -> - f (ExchangeRate (exchangeRateRepRate x) :: ExchangeRate src dst) -{-# INLINABLE withExchangeRateRep #-} - --------------------------------------------------------------------------------- --- 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 VERSION_hashable -instance Hashable (Dense currency) -instance Hashable DenseRep -instance GoodScale scale => Hashable (Discrete' currency scale) -instance Hashable DiscreteRep -instance Hashable (ExchangeRate src dst) -instance Hashable ExchangeRateRep -#endif - --------------------------------------------------------------------------------- --- Extra instances: deepseq -#ifdef VERSION_deepseq -instance NFData (Dense currency) -instance NFData DenseRep -instance GoodScale scale => NFData (Discrete' currency scale) -instance NFData DiscreteRep -instance NFData (ExchangeRate src dst) -instance NFData ExchangeRateRep -#endif - --------------------------------------------------------------------------------- --- Extra instances: cereal -#ifdef VERSION_cereal --- | Compatible with 'DenseRep'. -instance (KnownSymbol currency) => Cereal.Serialize (Dense currency) where - put = Cereal.put . toDenseRep - get = maybe empty pure =<< fmap fromDenseRep Cereal.get --- | Compatible with 'DiscreteRep'. -instance - ( KnownSymbol currency, GoodScale scale - ) => Cereal.Serialize (Discrete' currency scale) where - put = Cereal.put . toDiscreteRep - get = maybe empty pure =<< fmap fromDiscreteRep Cereal.get --- | Compatible with 'ExchangeRateRep'. -instance - ( KnownSymbol src, KnownSymbol dst - ) => Cereal.Serialize (ExchangeRate src dst) where - put = Cereal.put . toExchangeRateRep - get = maybe empty pure =<< fmap fromExchangeRateRep Cereal.get --- | Compatible with 'Dense'. -instance Cereal.Serialize DenseRep where - put = \(DenseRep c n d) -> Cereal.put c >> Cereal.put n >> Cereal.put d - get = maybe empty pure =<< mkDenseRep - <$> Cereal.get <*> Cereal.get <*> Cereal.get --- | Compatible with 'Discrete'. -instance Cereal.Serialize DiscreteRep where - put = \(DiscreteRep c n d a) -> - Cereal.put c >> Cereal.put n >> Cereal.put d >> Cereal.put a - get = maybe empty pure =<< mkDiscreteRep - <$> Cereal.get <*> Cereal.get <*> Cereal.get <*> Cereal.get --- | Compatible with 'ExchangeRate'. -instance Cereal.Serialize ExchangeRateRep where - put = \(ExchangeRateRep src dst n d) -> - Cereal.put src >> Cereal.put dst >> Cereal.put n >> Cereal.put d - get = maybe empty pure =<< mkExchangeRateRep - <$> Cereal.get <*> Cereal.get <*> Cereal.get <*> Cereal.get -#endif - --------------------------------------------------------------------------------- --- Extra instances: binary -#ifdef VERSION_binary --- | Compatible with 'DenseRep'. -instance (KnownSymbol currency) => Binary.Binary (Dense currency) where - put = Binary.put . toDenseRep - get = maybe empty pure =<< fmap fromDenseRep Binary.get --- | Compatible with 'DiscreteRep'. -instance - ( KnownSymbol currency, GoodScale scale - ) => Binary.Binary (Discrete' currency scale) where - put = Binary.put . toDiscreteRep - get = maybe empty pure =<< fmap fromDiscreteRep Binary.get --- | Compatible with 'ExchangeRateRep'. -instance - ( KnownSymbol src, KnownSymbol dst - ) => Binary.Binary (ExchangeRate src dst) where - put = Binary.put . toExchangeRateRep - get = maybe empty pure =<< fmap fromExchangeRateRep Binary.get --- | Compatible with 'Dense'. -instance Binary.Binary DenseRep where - put = \(DenseRep c n d) -> Binary.put c >> Binary.put n >> Binary.put d - get = maybe empty pure =<< mkDenseRep - <$> Binary.get <*> Binary.get <*> Binary.get --- | Compatible with 'Discrete'. -instance Binary.Binary DiscreteRep where - put = \(DiscreteRep c n d a) -> - Binary.put c >> Binary.put n >> Binary.put d >> Binary.put a - get = maybe empty pure =<< mkDiscreteRep - <$> Binary.get <*> Binary.get <*> Binary.get <*> Binary.get --- | Compatible with 'ExchangeRate'. -instance Binary.Binary ExchangeRateRep where - put = \(ExchangeRateRep src dst n d) -> - Binary.put src >> Binary.put dst >> Binary.put n >> Binary.put d - get = maybe empty pure =<< mkExchangeRateRep - <$> Binary.get <*> Binary.get <*> Binary.get <*> Binary.get -#endif - --------------------------------------------------------------------------------- --- Extra instances: aeson -#ifdef VERSION_aeson --- | Compatible with 'DenseRep' -instance KnownSymbol currency => Ae.ToJSON (Dense currency) where - toJSON = Ae.toJSON . toDenseRep --- | Compatible with 'DenseRep' -instance KnownSymbol currency => Ae.FromJSON (Dense currency) where - parseJSON = maybe empty pure <=< fmap fromDenseRep . Ae.parseJSON --- | Compatible with 'Dense' -instance Ae.ToJSON DenseRep where - toJSON = \(DenseRep c n d) -> Ae.toJSON ("Dense", c, n, d) --- | Compatible with 'Dense' -instance Ae.FromJSON DenseRep where - parseJSON = \v -> do - ("Dense", c, n, d) <- Ae.parseJSON v - maybe empty pure (mkDenseRep c n d) --- | Compatible with 'DiscreteRep' -instance - ( KnownSymbol currency, GoodScale scale - ) => Ae.ToJSON (Discrete' currency scale) where - toJSON = Ae.toJSON . toDiscreteRep --- | Compatible with 'DiscreteRep' -instance - ( KnownSymbol currency, GoodScale scale - ) => Ae.FromJSON (Discrete' currency scale) where - parseJSON = maybe empty pure <=< fmap fromDiscreteRep . Ae.parseJSON --- | Compatible with 'Discrete'' -instance Ae.ToJSON DiscreteRep where - toJSON = \(DiscreteRep c n d a) -> Ae.toJSON ("Discrete", c, n, d, a) --- | Compatible with 'Discrete'' -instance Ae.FromJSON DiscreteRep where - parseJSON = \v -> do - ("Discrete", c, n, d, a) <- Ae.parseJSON v - maybe empty pure (mkDiscreteRep c n d a) --- | Compatible with 'ExchangeRateRep' -instance - ( KnownSymbol src, KnownSymbol dst - ) => Ae.ToJSON (ExchangeRate src dst) where - toJSON = Ae.toJSON . toExchangeRateRep --- | Compatible with 'ExchangeRateRep' -instance - ( KnownSymbol src, KnownSymbol dst - ) => Ae.FromJSON (ExchangeRate src dst) where - parseJSON = maybe empty pure <=< fmap fromExchangeRateRep . Ae.parseJSON --- | Compatible with 'ExchangeRate' -instance Ae.ToJSON ExchangeRateRep where - toJSON = \(ExchangeRateRep src dst n d) -> - Ae.toJSON ("ExchangeRate", src, dst, n, d) --- | Compatible with 'ExchangeRate' -instance Ae.FromJSON ExchangeRateRep where - parseJSON = \v -> do - ("ExchangeRate", src, dst, n, d) <- Ae.parseJSON v - maybe empty pure (mkExchangeRateRep src dst n d) -#endif - --------------------------------------------------------------------------------- --- Extra instances: store -#ifdef VERSION_store --- | Compatible with 'DenseRep'. -instance (KnownSymbol currency) => Store.Store (Dense currency) where - size = storeContramapSize toDenseRep Store.size - poke = Store.poke . toDenseRep - peek = maybe (fail "peek") pure =<< fmap fromDenseRep Store.peek --- | Compatible with 'Dense'. -instance Store.Store DenseRep where - poke = \(DenseRep c n d) -> Store.poke c >> Store.poke n >> Store.poke d - peek = maybe (fail "peek") pure =<< do - mkDenseRep <$> Store.peek <*> Store.peek <*> Store.peek - --- | Compatible with 'DiscreteRep'. -instance - ( KnownSymbol currency, GoodScale scale - ) => Store.Store (Discrete' currency scale) where - size = storeContramapSize toDiscreteRep Store.size - poke = Store.poke . toDiscreteRep - peek = maybe (fail "peek") pure =<< fmap fromDiscreteRep Store.peek --- | Compatible with 'Discrete''. -instance Store.Store DiscreteRep where - poke = \(DiscreteRep c n d a) -> - Store.poke c >> Store.poke n >> Store.poke d >> Store.poke a - peek = maybe (fail "peek") pure =<< do - mkDiscreteRep <$> Store.peek <*> Store.peek <*> Store.peek <*> Store.peek --- | Compatible with 'ExchangeRateRep'. -instance - ( KnownSymbol src, KnownSymbol dst - ) => Store.Store (ExchangeRate src dst) where - size = storeContramapSize toExchangeRateRep Store.size - poke = Store.poke . toExchangeRateRep - peek = maybe (fail "peek") pure =<< fmap fromExchangeRateRep Store.peek --- | Compatible with 'ExchangeRate'. -instance Store.Store ExchangeRateRep where - poke = \(ExchangeRateRep src dst n d) -> - Store.poke src >> Store.poke dst >> Store.poke n >> Store.poke d - peek = maybe (fail "peek") pure =<< mkExchangeRateRep - <$> Store.peek <*> Store.peek <*> Store.peek <*> Store.peek - -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 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.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, 'Just' z) +-- @ +-- +-- @ +-- x /= y +-- @ +-- +-- @ +-- z < 'zero' +-- @ +-- +-- 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, 'Just' z) +-- @ +-- +-- @ +-- x /= y +-- @ +-- +-- @ +-- z > 'zero' +-- @ +-- +-- 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) + +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'. +-- +-- 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 + diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -8,23 +8,41 @@ module Main where +import qualified Data.ByteString.Lazy as BSL +import Data.Maybe (catMaybes, isJust, isNothing) +import Data.Proxy (Proxy(Proxy)) +import Data.Ratio (numerator, denominator) +import GHC.TypeLits (Nat, Symbol, KnownSymbol, symbolVal) import qualified Test.Tasty as Tasty import qualified Test.Tasty.Runners as Tasty -import Test.Tasty.QuickCheck ((===), (==>)) +import Test.Tasty.QuickCheck ((===), (==>), (.&&.)) import qualified Test.Tasty.QuickCheck as QC +#ifdef HAS_aeson import qualified Data.Aeson as Ae +#endif + +#ifdef HAS_binary import qualified Data.Binary as Binary -import qualified Data.ByteString.Lazy as BSL -import Data.Maybe (catMaybes, isJust, isNothing) -import Data.Proxy (Proxy(Proxy)) +#endif + +#ifdef HAS_cereal import qualified Data.Serialize as Cereal -import GHC.TypeLits (Nat, Symbol, KnownSymbol, symbolVal) +#endif -#ifdef VERSION_store +#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 + import qualified Money -------------------------------------------------------------------------------- @@ -35,13 +53,13 @@ arbitrary = fmap fromInteger QC.arbitrary shrink = fmap fromInteger . QC.shrink . toInteger -instance QC.Arbitrary Money.DiscreteRep where +instance QC.Arbitrary Money.SomeDiscrete where arbitrary = do - let md = Money.mkDiscreteRep <$> QC.arbitrary <*> QC.arbitrary - <*> QC.arbitrary <*> QC.arbitrary + let md = Money.mkSomeDiscrete + <$> QC.arbitrary <*> QC.arbitrary <*> QC.arbitrary Just x <- QC.suchThat md isJust pure x - shrink = \x -> Money.withDiscreteRep x (map Money.toDiscreteRep . QC.shrink) + shrink = \x -> Money.withSomeDiscrete x (map Money.toSomeDiscrete . QC.shrink) instance QC.Arbitrary (Money.Dense currency) where arbitrary = do @@ -49,12 +67,12 @@ pure x shrink = catMaybes . fmap Money.dense . QC.shrink . toRational -instance QC.Arbitrary Money.DenseRep where +instance QC.Arbitrary Money.SomeDense where arbitrary = do - let md = Money.mkDenseRep <$> QC.arbitrary <*> QC.arbitrary <*> QC.arbitrary + let md = Money.mkSomeDense <$> QC.arbitrary <*> QC.arbitrary Just x <- QC.suchThat md isJust pure x - shrink = \x -> Money.withDenseRep x (map Money.toDenseRep . QC.shrink) + shrink = \x -> Money.withSomeDense x (map Money.toSomeDense . QC.shrink) instance QC.Arbitrary (Money.ExchangeRate src dst) where arbitrary = do @@ -63,14 +81,14 @@ shrink = catMaybes . fmap Money.exchangeRate . QC.shrink . Money.fromExchangeRate -instance QC.Arbitrary Money.ExchangeRateRep where +instance QC.Arbitrary Money.SomeExchangeRate where arbitrary = do - let md = Money.mkExchangeRateRep <$> QC.arbitrary <*> QC.arbitrary - <*> QC.arbitrary <*> QC.arbitrary + let md = Money.mkSomeExchangeRate + <$> QC.arbitrary <*> QC.arbitrary <*> QC.arbitrary Just x <- QC.suchThat md isJust pure x shrink = \x -> - Money.withExchangeRateRep x (map Money.toExchangeRateRep . QC.shrink) + Money.withSomeExchangeRate x (map Money.toSomeExchangeRate . QC.shrink) -------------------------------------------------------------------------------- @@ -122,83 +140,132 @@ [ QC.testProperty "read . show == id" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> x === read (show x) - , QC.testProperty "fromDenseRep . denseRep == Just" $ + , QC.testProperty "read . show . Just == Just " $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> - Just x === Money.fromDenseRep (Money.toDenseRep x) - , QC.testProperty "fromDenseRep works only for same currency" $ - QC.forAll QC.arbitrary $ \(dr :: Money.DenseRep) -> - (Money.denseRepCurrency dr /= symbolVal pc) - ==> isNothing (Money.fromDenseRep dr :: Maybe (Money.Dense currency)) - , QC.testProperty "withDenseRep" $ + Just x === read (show (Just x)) + , QC.testProperty "fromSomeDense . someDense == Just" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> - let dr = Money.toDenseRep x - in Money.withDenseRep dr $ \x' -> - (show x, dr, Money.toDenseRep (x + 1)) - === (show x', Money.toDenseRep x', Money.toDenseRep (x' + 1)) + 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 + in Money.withSomeDense dr $ \x' -> + (show x, dr, Money.toSomeDense (x + 1)) + === (show x', Money.toSomeDense x', Money.toSomeDense (x' + 1)) +#ifdef HAS_aeson , QC.testProperty "Aeson encoding roundtrip" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> Just x === Ae.decode (Ae.encode x) - , QC.testProperty "Aeson encoding roundtrip (DenseRep)" $ + , QC.testProperty "Aeson encoding roundtrip (SomeDense)" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> - let x' = Money.toDenseRep x + let x' = Money.toSomeDense x in Just x' === Ae.decode (Ae.encode x') - , QC.testProperty "Aeson encoding roundtrip (Dense through DenseRep)" $ + , QC.testProperty "Aeson encoding roundtrip (Dense through SomeDense)" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> - Just x === Ae.decode (Ae.encode (Money.toDenseRep x)) - , QC.testProperty "Aeson encoding roundtrip (DenseRep through Dense)" $ + Just x === Ae.decode (Ae.encode (Money.toSomeDense x)) + , QC.testProperty "Aeson encoding roundtrip (SomeDense through Dense)" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> - Just (Money.toDenseRep x) === Ae.decode (Ae.encode x) + Just (Money.toSomeDense x) === Ae.decode (Ae.encode x) + , QC.testProperty "Aeson decoding of pre-0.4 format (Dense, SomeDense)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + let sx = Money.toSomeDense x + c = Money.someDenseCurrency sx + r = Money.someDenseAmount sx + bs = Ae.encode ("Dense", c, numerator r, denominator r) + in (Just x === Ae.decode bs) .&&. + (Just sx === Ae.decode bs) +#endif +#ifdef HAS_binary , QC.testProperty "Binary encoding roundtrip" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> let Right (_,_,y) = Binary.decodeOrFail (Binary.encode x) in x === y - , QC.testProperty "Binary encoding roundtrip (DenseRep)" $ + , QC.testProperty "Binary encoding roundtrip (SomeDense)" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> - let x' = Money.toDenseRep x + let x' = Money.toSomeDense x bs = Binary.encode x' in Right (mempty, BSL.length bs, x') === Binary.decodeOrFail bs - , QC.testProperty "Binary encoding roundtrip (Dense through DenseRep)" $ + , QC.testProperty "Binary encoding roundtrip (Dense through SomeDense)" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> - let x' = Money.toDenseRep x + let x' = Money.toSomeDense x bs = Binary.encode x' in Right (mempty, BSL.length bs, x) === Binary.decodeOrFail bs - , QC.testProperty "Binary encoding roundtrip (DenseRep through Dense)" $ + , QC.testProperty "Binary encoding roundtrip (SomeDense through Dense)" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> - let x' = Money.toDenseRep x + let x' = Money.toSomeDense x bs = Binary.encode x in Right (mempty, BSL.length bs, x') === Binary.decodeOrFail bs +#endif +#ifdef HAS_cereal , QC.testProperty "Cereal encoding roundtrip" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> Right x === Cereal.decode (Cereal.encode x) - , QC.testProperty "Cereal encoding roundtrip (DenseRep)" $ + , QC.testProperty "Cereal encoding roundtrip (SomeDense)" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> - let x' = Money.toDenseRep x + let x' = Money.toSomeDense x in Right x' === Cereal.decode (Cereal.encode x') - , QC.testProperty "Cereal encoding roundtrip (Dense through DenseRep)" $ + , QC.testProperty "Cereal encoding roundtrip (Dense through SomeDense)" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> - Right x === Cereal.decode (Cereal.encode (Money.toDenseRep x)) - , QC.testProperty "Cereal encoding roundtrip (DenseRep through Dense)" $ + Right x === Cereal.decode (Cereal.encode (Money.toSomeDense x)) + , QC.testProperty "Cereal encoding roundtrip (SomeDense through Dense)" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> - Right (Money.toDenseRep x) === Cereal.decode (Cereal.encode x) + Right (Money.toSomeDense x) === Cereal.decode (Cereal.encode x) +#endif -#ifdef VERSION_store +#ifdef HAS_serialise + , QC.testProperty "Serialise encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Just x === hush (Ser.deserialiseOrFail (Ser.serialise x)) + , QC.testProperty "Serialise encoding roundtrip (SomeDense)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + let x' = Money.toSomeDense x + in Just x' === hush (Ser.deserialiseOrFail (Ser.serialise x')) + , QC.testProperty "Serialise encoding roundtrip (Dense through SomeDense)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Just x === hush (Ser.deserialiseOrFail (Ser.serialise (Money.toSomeDense x))) + , QC.testProperty "Serialise encoding roundtrip (SomeDense through Dense)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Just (Money.toSomeDense x) === hush (Ser.deserialiseOrFail (Ser.serialise x)) +#endif + +#ifdef HAS_store , QC.testProperty "Store encoding roundtrip" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> Right x === Store.decode (Store.encode x) - , QC.testProperty "Store encoding roundtrip (DenseRep)" $ + , QC.testProperty "Store encoding roundtrip (SomeDense)" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> - let x' = Money.toDenseRep x + let x' = Money.toSomeDense x in Right x' === Store.decode (Store.encode x') - , QC.testProperty "Store encoding roundtrip (Dense through DenseRep)" $ + , QC.testProperty "Store encoding roundtrip (Dense through SomeDense)" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> - Right x === Store.decode (Store.encode (Money.toDenseRep x)) - , QC.testProperty "Store encoding roundtrip (DenseRep through Dense)" $ + Right x === Store.decode (Store.encode (Money.toSomeDense x)) + , QC.testProperty "Store encoding roundtrip (SomeDense through Dense)" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> - Right (Money.toDenseRep x) === Store.decode (Store.encode x) + Right (Money.toSomeDense x) === Store.decode (Store.encode x) #endif + +#ifdef HAS_xmlbf + , QC.testProperty "Xmlbf encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Right x === Xmlbf.runParser Xmlbf.fromXml (Xmlbf.toXml x) + , QC.testProperty "Xmlbf encoding roundtrip (SomeDense)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + let x' = Money.toSomeDense x + in Right x' === Xmlbf.runParser Xmlbf.fromXml (Xmlbf.toXml x') + , QC.testProperty "Xmlbf encoding roundtrip (Dense through SomeDense)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Right x === Xmlbf.runParser Xmlbf.fromXml (Xmlbf.toXml (Money.toSomeDense x)) + , QC.testProperty "Xmlbf encoding roundtrip (SomeDense through Dense)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + Right (Money.toSomeDense x) === Xmlbf.runParser Xmlbf.fromXml (Xmlbf.toXml x) +#endif ] testExchange :: Tasty.TestTree @@ -237,87 +304,137 @@ , QC.testProperty "read . show == id" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> x === read (show x) - , QC.testProperty "fromDiscreteRep . discreteRep == Just" $ + , QC.testProperty "read . show . Just == Just" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> - Just x === Money.fromDiscreteRep (Money.toDiscreteRep x) - , QC.testProperty "fromDiscreteRep works only for same currency and scale" $ - QC.forAll QC.arbitrary $ \(dr :: Money.DiscreteRep) -> - ((Money.discreteRepCurrency dr /= symbolVal pc) && - (Money.discreteRepScale dr /= + Just x === read (show (Just x)) + , QC.testProperty "fromSomeDiscrete . someDiscrete == Just" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Just x === Money.fromSomeDiscrete (Money.toSomeDiscrete x) + , QC.testProperty "fromSomeDiscrete works only for same currency and scale" $ + QC.forAll QC.arbitrary $ \(dr :: Money.SomeDiscrete) -> + ((Money.someDiscreteCurrency dr /= symbolVal pc) && + (Money.someDiscreteScale dr /= Money.scale (Proxy :: Proxy (Money.Scale currency unit))) - ) ==> isNothing (Money.fromDiscreteRep dr + ) ==> isNothing (Money.fromSomeDiscrete dr :: Maybe (Money.Discrete currency unit)) - , QC.testProperty "withDiscreteRep" $ + , QC.testProperty "withSomeDiscrete" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> - let dr = Money.toDiscreteRep x - in ( Money.withDiscreteRep dr $ \x' -> - (show x, dr, Money.toDiscreteRep (x + 1)) - === (show x', Money.toDiscreteRep x', Money.toDiscreteRep (x' + 1)) + let dr = Money.toSomeDiscrete x + in ( Money.withSomeDiscrete dr $ \x' -> + (show x, dr, Money.toSomeDiscrete (x + 1)) + === (show x', Money.toSomeDiscrete x', Money.toSomeDiscrete (x' + 1)) ) :: QC.Property +#ifdef HAS_aeson , QC.testProperty "Aeson encoding roundtrip" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> Just x === Ae.decode (Ae.encode x) - , QC.testProperty "Aeson encoding roundtrip (DiscreteRep)" $ + , QC.testProperty "Aeson encoding roundtrip (SomeDiscrete)" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> - let x' = Money.toDiscreteRep x + let x' = Money.toSomeDiscrete x in Just x' === Ae.decode (Ae.encode x') - , QC.testProperty "Aeson encoding roundtrip (Discrete through DiscreteRep)" $ + , QC.testProperty "Aeson encoding roundtrip (Discrete through SomeDiscrete)" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> - Just x === Ae.decode (Ae.encode (Money.toDiscreteRep x)) - , QC.testProperty "Aeson encoding roundtrip (DiscreteRep through Discrete)" $ + Just x === Ae.decode (Ae.encode (Money.toSomeDiscrete x)) + , QC.testProperty "Aeson encoding roundtrip (SomeDiscrete through Discrete)" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> - Just (Money.toDiscreteRep x) === Ae.decode (Ae.encode x) + Just (Money.toSomeDiscrete x) === Ae.decode (Ae.encode x) + , QC.testProperty "Aeson decoding of pre-0.4 format (Discrete, SomeDiscrete)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + let sx = Money.toSomeDiscrete x + c = Money.someDiscreteCurrency sx + r = Money.someDiscreteScale sx + a = Money.someDiscreteAmount sx + bs = Ae.encode ("Discrete", c, numerator r, denominator r, a) + in (Just x === Ae.decode bs) .&&. + (Just sx === Ae.decode bs) +#endif +#ifdef HAS_binary , QC.testProperty "Binary encoding roundtrip" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> let Right (_,_,y) = Binary.decodeOrFail (Binary.encode x) in x === y - , QC.testProperty "Binary encoding roundtrip (DiscreteRep)" $ + , QC.testProperty "Binary encoding roundtrip (SomeDiscrete)" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> - let x' = Money.toDiscreteRep x + let x' = Money.toSomeDiscrete x bs = Binary.encode x' in Right (mempty, BSL.length bs, x') === Binary.decodeOrFail bs - , QC.testProperty "Binary encoding roundtrip (Discrete through DiscreteRep)" $ + , QC.testProperty "Binary encoding roundtrip (Discrete through SomeDiscrete)" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> - let x' = Money.toDiscreteRep x + let x' = Money.toSomeDiscrete x bs = Binary.encode x' in Right (mempty, BSL.length bs, x) === Binary.decodeOrFail bs - , QC.testProperty "Binary encoding roundtrip (DiscreteRep through Discrete)" $ + , QC.testProperty "Binary encoding roundtrip (SomeDiscrete through Discrete)" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> - let x' = Money.toDiscreteRep x + let x' = Money.toSomeDiscrete x bs = Binary.encode x in Right (mempty, BSL.length bs, x') === Binary.decodeOrFail bs +#endif +#ifdef HAS_cereal , QC.testProperty "Cereal encoding roundtrip" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> Right x === Cereal.decode (Cereal.encode x) - , QC.testProperty "Cereal encoding roundtrip (DiscreteRep)" $ + , QC.testProperty "Cereal encoding roundtrip (SomeDiscrete)" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> - let x' = Money.toDiscreteRep x + let x' = Money.toSomeDiscrete x in Right x' === Cereal.decode (Cereal.encode x') - , QC.testProperty "Cereal encoding roundtrip (Discrete through DiscreteRep)" $ + , QC.testProperty "Cereal encoding roundtrip (Discrete through SomeDiscrete)" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> - Right x === Cereal.decode (Cereal.encode (Money.toDiscreteRep x)) - , QC.testProperty "Cereal encoding roundtrip (DiscreteRep through Discrete)" $ + Right x === Cereal.decode (Cereal.encode (Money.toSomeDiscrete x)) + , QC.testProperty "Cereal encoding roundtrip (SomeDiscrete through Discrete)" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> - Right (Money.toDiscreteRep x) === Cereal.decode (Cereal.encode x) + Right (Money.toSomeDiscrete x) === Cereal.decode (Cereal.encode x) +#endif -#ifdef VERSION_store +#ifdef HAS_serialise + , QC.testProperty "Serialise encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Just x === hush (Ser.deserialiseOrFail (Ser.serialise x)) + , QC.testProperty "Serialise encoding roundtrip (SomeDiscrete)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + let x' = Money.toSomeDiscrete x + in Just x' === hush (Ser.deserialiseOrFail (Ser.serialise x')) + , QC.testProperty "Serialise encoding roundtrip (Discrete through SomeDiscrete)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Just x === hush (Ser.deserialiseOrFail (Ser.serialise (Money.toSomeDiscrete x))) + , QC.testProperty "Serialise encoding roundtrip (SomeDiscrete through Discrete)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Just (Money.toSomeDiscrete x) === hush (Ser.deserialiseOrFail (Ser.serialise x)) +#endif + +#ifdef HAS_store , QC.testProperty "Store encoding roundtrip" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> Right x === Store.decode (Store.encode x) - , QC.testProperty "Store encoding roundtrip (DiscreteRep)" $ + , QC.testProperty "Store encoding roundtrip (SomeDiscrete)" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> - let x' = Money.toDiscreteRep x + let x' = Money.toSomeDiscrete x in Right x' === Store.decode (Store.encode x') - , QC.testProperty "Store encoding roundtrip (Discrete through DiscreteRep)" $ + , QC.testProperty "Store encoding roundtrip (Discrete through SomeDiscrete)" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> - Right x === Store.decode (Store.encode (Money.toDiscreteRep x)) - , QC.testProperty "Store encoding roundtrip (DiscreteRep through Discrete)" $ + Right x === Store.decode (Store.encode (Money.toSomeDiscrete x)) + , QC.testProperty "Store encoding roundtrip (SomeDiscrete through Discrete)" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> - Right (Money.toDiscreteRep x) === Store.decode (Store.encode x) + Right (Money.toSomeDiscrete x) === Store.decode (Store.encode x) #endif + +#ifdef HAS_xmlbf + , QC.testProperty "Xmlbf encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Right x === Xmlbf.runParser Xmlbf.fromXml (Xmlbf.toXml x) + , QC.testProperty "Xmlbf encoding roundtrip (SomeDiscrete)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + let x' = Money.toSomeDiscrete x + in Right x' === Xmlbf.runParser Xmlbf.fromXml (Xmlbf.toXml x') + , QC.testProperty "Xmlbf encoding roundtrip (Discrete through SomeDiscrete)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Right x === Xmlbf.runParser Xmlbf.fromXml (Xmlbf.toXml (Money.toSomeDiscrete x)) + , QC.testProperty "Xmlbf encoding roundtrip (SomeDiscrete through Discrete)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + Right (Money.toSomeDiscrete x) === Xmlbf.runParser Xmlbf.fromXml (Xmlbf.toXml x) +#endif ] testExchangeRate @@ -332,6 +449,9 @@ [ QC.testProperty "read . show == id" $ QC.forAll QC.arbitrary $ \(xr :: Money.ExchangeRate src dst) -> xr === read (show xr) + , QC.testProperty "read . show . Just == Just" $ + QC.forAll QC.arbitrary $ \(xr :: Money.ExchangeRate src dst) -> + 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 @@ -354,84 +474,131 @@ , xr :: Money.ExchangeRate src dst ) -> (Money.fromExchangeRate xr /= 1) ==> (toRational c0 /= toRational (Money.exchange xr c0)) - , QC.testProperty "fromExchangeRateRep . exchangeRateRep == Just" $ + , QC.testProperty "fromSomeExchangeRate . someExchangeRate == Just" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> - Just x === Money.fromExchangeRateRep (Money.toExchangeRateRep x) - , QC.testProperty "fromExchangeRateRep works only for same currencies" $ - QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRateRep) -> - ((Money.exchangeRateRepSrcCurrency x /= symbolVal ps) && - (Money.exchangeRateRepDstCurrency x /= symbolVal pd)) - ==> isNothing (Money.fromExchangeRateRep x + Just x === Money.fromSomeExchangeRate (Money.toSomeExchangeRate x) + , QC.testProperty "fromSomeExchangeRate works only for same currencies" $ + QC.forAll QC.arbitrary $ \(x :: Money.SomeExchangeRate) -> + ((Money.someExchangeRateSrcCurrency x /= symbolVal ps) && + (Money.someExchangeRateDstCurrency x /= symbolVal pd)) + ==> isNothing (Money.fromSomeExchangeRate x :: Maybe (Money.ExchangeRate src dst)) - , QC.testProperty "withExchangeRateRep" $ + , QC.testProperty "withSomeExchangeRate" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> - let dr = Money.toExchangeRateRep x - in Money.withExchangeRateRep dr $ \x' -> - (show x, dr) === (show x', Money.toExchangeRateRep x') + let dr = Money.toSomeExchangeRate x + in Money.withSomeExchangeRate dr $ \x' -> + (show x, dr) === (show x', Money.toSomeExchangeRate x') +#ifdef HAS_aeson , QC.testProperty "Aeson encoding roundtrip" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> Just x === Ae.decode (Ae.encode x) - , QC.testProperty "Aeson encoding roundtrip (ExchangeRateRep)" $ + , QC.testProperty "Aeson encoding roundtrip (SomeExchangeRate)" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> - let x' = Money.toExchangeRateRep x + let x' = Money.toSomeExchangeRate x in Just x' === Ae.decode (Ae.encode x') - , QC.testProperty "Aeson encoding roundtrip (ExchangeRate through ExchangeRateRep)" $ + , QC.testProperty "Aeson encoding roundtrip (ExchangeRate through SomeExchangeRate)" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> - Just x === Ae.decode (Ae.encode (Money.toExchangeRateRep x)) - , QC.testProperty "Aeson encoding roundtrip (ExchangeRateRep through ExchangeRate)" $ + Just x === Ae.decode (Ae.encode (Money.toSomeExchangeRate x)) + , QC.testProperty "Aeson encoding roundtrip (SomeExchangeRate through ExchangeRate)" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> - Just (Money.toExchangeRateRep x) === Ae.decode (Ae.encode x) + Just (Money.toSomeExchangeRate x) === Ae.decode (Ae.encode x) + , QC.testProperty "Aeson decoding of pre-0.4 format (ExchangeRate, SomeExchangeRate)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + let sx = Money.toSomeExchangeRate x + src = Money.someExchangeRateSrcCurrency sx + dst = Money.someExchangeRateDstCurrency sx + r = Money.someExchangeRateRate sx + bs = Ae.encode ("ExchangeRate", src, dst, numerator r, denominator r) + in (Just x === Ae.decode bs) .&&. + (Just sx === Ae.decode bs) +#endif +#ifdef HAS_binary , QC.testProperty "Binary encoding roundtrip" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> let Right (_,_,y) = Binary.decodeOrFail (Binary.encode x) in x === y - , QC.testProperty "Binary encoding roundtrip (ExchangeRateRep)" $ + , QC.testProperty "Binary encoding roundtrip (SomeExchangeRate)" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> - let x' = Money.toExchangeRateRep x + let x' = Money.toSomeExchangeRate x bs = Binary.encode x' in Right (mempty, BSL.length bs, x') === Binary.decodeOrFail bs - , QC.testProperty "Binary encoding roundtrip (ExchangeRate through ExchangeRateRep)" $ + , QC.testProperty "Binary encoding roundtrip (ExchangeRate through SomeExchangeRate)" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> - let x' = Money.toExchangeRateRep x + let x' = Money.toSomeExchangeRate x bs = Binary.encode x' in Right (mempty, BSL.length bs, x) === Binary.decodeOrFail bs - , QC.testProperty "Binary encoding roundtrip (ExchangeRateRep through ExchangeRate)" $ + , QC.testProperty "Binary encoding roundtrip (SomeExchangeRate through ExchangeRate)" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> - let x' = Money.toExchangeRateRep x + let x' = Money.toSomeExchangeRate x bs = Binary.encode x in Right (mempty, BSL.length bs, x') === Binary.decodeOrFail bs +#endif +#ifdef HAS_cereal , QC.testProperty "Cereal encoding roundtrip" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> Right x === Cereal.decode (Cereal.encode x) - , QC.testProperty "Cereal encoding roundtrip (ExchangeRateRep)" $ + , QC.testProperty "Cereal encoding roundtrip (SomeExchangeRate)" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> - let x' = Money.toExchangeRateRep x + let x' = Money.toSomeExchangeRate x in Right x' === Cereal.decode (Cereal.encode x') - , QC.testProperty "Cereal encoding roundtrip (ExchangeRate through ExchangeRateRep)" $ + , QC.testProperty "Cereal encoding roundtrip (ExchangeRate through SomeExchangeRate)" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> - Right x === Cereal.decode (Cereal.encode (Money.toExchangeRateRep x)) - , QC.testProperty "Cereal encoding roundtrip (ExchangeRateRep through ExchangeRate)" $ + Right x === Cereal.decode (Cereal.encode (Money.toSomeExchangeRate x)) + , QC.testProperty "Cereal encoding roundtrip (SomeExchangeRate through ExchangeRate)" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> - Right (Money.toExchangeRateRep x) === Cereal.decode (Cereal.encode x) + Right (Money.toSomeExchangeRate x) === Cereal.decode (Cereal.encode x) +#endif -#ifdef VERSION_store +#ifdef HAS_serialise + , QC.testProperty "Serialise encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + Just x === hush (Ser.deserialiseOrFail (Ser.serialise x)) + , QC.testProperty "Serialise encoding roundtrip (SomeExchangeRate)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + let x' = Money.toSomeExchangeRate x + in Just x' === hush (Ser.deserialiseOrFail (Ser.serialise x')) + , QC.testProperty "Serialise encoding roundtrip (ExchangeRate through SomeExchangeRate)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + Just x === hush (Ser.deserialiseOrFail (Ser.serialise (Money.toSomeExchangeRate x))) + , QC.testProperty "Serialise encoding roundtrip (SomeExchangeRate through ExchangeRate)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + Just (Money.toSomeExchangeRate x) === hush (Ser.deserialiseOrFail (Ser.serialise x)) +#endif + +#ifdef HAS_store , QC.testProperty "Store encoding roundtrip" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> Right x === Store.decode (Store.encode x) - , QC.testProperty "Store encoding roundtrip (ExchangeRateRep)" $ + , QC.testProperty "Store encoding roundtrip (SomeExchangeRate)" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> - let x' = Money.toExchangeRateRep x + let x' = Money.toSomeExchangeRate x in Right x' === Store.decode (Store.encode x') - , QC.testProperty "Store encoding roundtrip (ExchangeRate through ExchangeRateRep)" $ + , QC.testProperty "Store encoding roundtrip (ExchangeRate through SomeExchangeRate)" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> - Right x === Store.decode (Store.encode (Money.toExchangeRateRep x)) - , QC.testProperty "Store encoding roundtrip (ExchangeRateRep through ExchangeRate)" $ + Right x === Store.decode (Store.encode (Money.toSomeExchangeRate x)) + , QC.testProperty "Store encoding roundtrip (SomeExchangeRate through ExchangeRate)" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> - Right (Money.toExchangeRateRep x) === Store.decode (Store.encode x) + Right (Money.toSomeExchangeRate x) === Store.decode (Store.encode x) #endif + +#ifdef HAS_xmlbf + , QC.testProperty "Xmlbf encoding roundtrip" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + Right x === Xmlbf.runParser Xmlbf.fromXml (Xmlbf.toXml x) + , QC.testProperty "Xmlbf encoding roundtrip (SomeExchangeRate)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + let x' = Money.toSomeExchangeRate x + in Right x' === Xmlbf.runParser Xmlbf.fromXml (Xmlbf.toXml x') + , QC.testProperty "Xmlbf encoding roundtrip (ExchangeRate through SomeExchangeRate)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + Right x === Xmlbf.runParser Xmlbf.fromXml (Xmlbf.toXml (Money.toSomeExchangeRate x)) + , QC.testProperty "Xmlbf encoding roundtrip (SomeExchangeRate through ExchangeRate)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + Right (Money.toSomeExchangeRate x) === Xmlbf.runParser Xmlbf.fromXml (Xmlbf.toXml x) +#endif ] testRounding @@ -446,8 +613,25 @@ , 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) ] where - g f = \(x :: Money.Dense currency) -> x === case f x of - (y, Nothing) -> Money.fromDiscrete (y :: Money.Discrete currency unit) - (y, Just z) -> Money.fromDiscrete y + z + 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 + + 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 + (_, _) -> error "testRounding.h: unexpected" + +hush :: Either a b -> Maybe b +hush (Left _ ) = Nothing +hush (Right b) = Just b +