safe-money 0.1 → 0.2
raw patch · 5 files changed
+141/−40 lines, 5 filesdep ~aesondep ~basedep ~binary
Dependency ranges changed: aeson, base, binary, cereal, constraints, deepseq, hashable, store
Files
- changelog.md +10/−0
- safe-money.cabal +21/−15
- src/Data/Money.hs +5/−4
- src/Data/Money/Internal.hs +60/−20
- tests/Main.hs +45/−1
changelog.md view
@@ -1,3 +1,13 @@+# Version 0.2++* Cabal flags are now manual (`aeson`, `binary`, `bytes`, `cereal`, `deepseq`,+ `hashable`).++* Backwards compatibility with GHC 7.10.++* Fix `Store` instances and test them.++ # Version 0.1 * Initial release.
safe-money.cabal view
@@ -1,5 +1,5 @@ name: safe-money-version: 0.1+version: 0.2 license: BSD3 license-file: LICENSE copyright: Copyright (c) Renzo Carbonara 2016@@ -28,21 +28,21 @@ Data.Money Data.Money.Internal build-depends:- base (>=4.5 && <5.0)- , constraints+ base (>=4.8 && <5.0)+ , constraints (>=0.6 && <0.9) if flag(aeson)- build-depends: aeson+ build-depends: aeson (>=0.9 && <1.1) if flag(binary)- build-depends: binary+ build-depends: binary (>=0.7 && <0.9) if flag(cereal)- build-depends: cereal+ build-depends: cereal (>=0.5 && <0.6) if flag(deepseq)- build-depends: deepseq+ build-depends: deepseq (>=1.4 && <1.5) if flag(hashable)- build-depends: hashable+ build-depends: hashable (>=1.2 && <1.3) if flag(store)- build-depends: store+ build-depends: store (>=0.2 && <0.4) test-suite tests default-language: Haskell2010@@ -63,22 +63,28 @@ , tasty-hunit , tasty-quickcheck --- Provide instances for @aeson@ flag aeson+ description: Provide instances for @aeson@ default: True--- Provide instances for @binary@+ manual: True flag binary+ description: Provide instances for @binary@ default: True--- Provide instances for @cereal@+ manual: True flag cereal+ description: Provide instances for @cereal@ default: True--- Provide instances for @store@+ manual: True flag store+ description: Provide instances for @store@ default: True--- Provide instances for @hashable@+ manual: True flag hashable+ description: Provide instances for @hashable@ default: True--- Provide instances for @deepseq@+ manual: True flag deepseq+ description: Provide instances for @deepseq@ default: True+ manual: True
src/Data/Money.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}@@ -699,7 +700,7 @@ type instance I.Scale "ZWL" "dollar" = '(1, 1) type instance I.Scale "ZWL" "cent" = '(100, 1) --- | Gold+-- | Gold. No canonical smallest unit. Unusable instance. type instance I.Scale "XAU" "XAU" = I.ErrScaleNonCanonical "XAU" type instance I.Scale "XAU" "troy-ounce" = '(1, 1) type instance I.Scale "XAU" "grain" = '(480, 1)@@ -710,7 +711,7 @@ type instance I.Scale "XAU" "milligram" = '(31103477, 1000) type instance I.Scale "XAU" "microgram" = '(31103477, 1) --- | Silver+-- | Silver. No canonical smallest unit. Unusable instance. type instance I.Scale "XAG" "XAG" = I.ErrScaleNonCanonical "XAG" type instance I.Scale "XAG" "troy-ounce" = '(1, 1) type instance I.Scale "XAG" "grain" = '(480, 1)@@ -721,7 +722,7 @@ type instance I.Scale "XAG" "milligram" = '(31103477, 1000) type instance I.Scale "XAG" "microgram" = '(31103477, 1) --- | Palladium+-- | Palladium. No canonical smallest unit. Unusable instance. type instance I.Scale "XPD" "XPD" = I.ErrScaleNonCanonical "XPD" type instance I.Scale "XPD" "troy-ounce" = '(1, 1) type instance I.Scale "XPD" "grain" = '(480, 1)@@ -732,7 +733,7 @@ type instance I.Scale "XPD" "milligram" = '(31103477, 1000) type instance I.Scale "XPD" "microgram" = '(31103477, 1) --- | Platinum+-- | Platinum. No canonical smallest unit. Unusable instance. type instance I.Scale "XPT" "XPT" = I.ErrScaleNonCanonical "XPT" type instance I.Scale "XPT" "troy-ounce" = '(1, 1) type instance I.Scale "XPT" "grain" = '(480, 1)
src/Data/Money/Internal.hs view
@@ -14,7 +14,10 @@ {-# 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 "Data.Money" instead. module Data.Money.Internal@@ -82,7 +85,6 @@ import GHC.TypeLits (Symbol, SomeSymbol(..), Nat, SomeNat(..), CmpNat, KnownSymbol, KnownNat, natVal, someNatVal, symbolVal, someSymbolVal)-import qualified GHC.TypeLits as GHC import Prelude hiding (round, ceiling, floor, truncate) import qualified Prelude import qualified Text.ParserCombinators.ReadPrec as ReadPrec@@ -114,6 +116,10 @@ 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.@@ -200,8 +206,15 @@ -- mentioning the unit scale. newtype Discrete' (currency :: Symbol) (scale :: (Nat, Nat)) = Discrete Integer- deriving (Eq, Ord, Enum, Num, Real, Integral, GHC.Generic) +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@@ -219,6 +232,7 @@ ("Discrete " ++ show c ++ " (" ++ show s ++ ") ") ) Discrete <$> readPrec +#if MIN_VERSION_base(4,9,0) instance ( GHC.TypeError (('GHC.Text "The ") 'GHC.:<>:@@ -231,10 +245,12 @@ ('GHC.ShowType Dense) 'GHC.:$$: ('GHC.Text "value and use the ") 'GHC.:<>: ('GHC.ShowType Fractional) 'GHC.:<>:- ('GHC.Text " features on it instead.")) )- => Fractional (Discrete' currency scale) where+ ('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.@@ -247,14 +263,16 @@ -- | Internal. Used to implement 'round', 'ceiling', 'floor' and 'truncate'. roundf- :: GoodScale scale+ :: 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- !i2 = f (r0 * scale d2) :: Integer- !r2 = fromInteger i2 / scale d2 :: 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@@ -446,7 +464,7 @@ -- represent values such as USD 3.50 or USD 21.87, since they are not exact -- multiples of a dollar. ----- If there exists a cannonical smallest @unit@ that can fully represent the+-- If there exists a canonical smallest @unit@ that can fully represent the -- currency, then an instance @'Scale' currency currency@ exists. -- -- @@@ -479,13 +497,23 @@ -- 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--- cannonical small unit.+-- 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@@ -914,7 +942,7 @@ #ifdef VERSION_hashable instance Hashable (Dense currency) instance Hashable DenseRep-instance Hashable (Discrete' currency scale)+instance GoodScale scale => Hashable (Discrete' currency scale) instance Hashable DiscreteRep instance Hashable (ExchangeRate src dst) instance Hashable ExchangeRateRep@@ -925,7 +953,7 @@ #ifdef VERSION_deepseq instance NFData (Dense currency) instance NFData DenseRep-instance NFData (Discrete' currency scale)+instance GoodScale scale => NFData (Discrete' currency scale) instance NFData DiscreteRep instance NFData (ExchangeRate src dst) instance NFData ExchangeRateRep@@ -1068,33 +1096,45 @@ #ifdef VERSION_store -- | Compatible with 'DenseRep'. instance (KnownSymbol currency) => Store.Store (Dense currency) where+ size = storeContramapSize denseRep Store.size poke = Store.poke . denseRep 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, n, d)- peek = do (c, n, d) <- Store.peek- maybe (fail "peek") pure (mkDenseRep c n d)+ 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 discreteRep Store.size poke = Store.poke . discreteRep 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, n, d, a)- peek = do (c, n, d, a) <- Store.peek- maybe (fail "peek") pure (mkDiscreteRep c n d a)+ 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 exchangeRateRep Store.size poke = Store.poke . exchangeRateRep 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, dst, n, d)- peek = do (src, dst, n, d) <- Store.peek- maybe (fail "peek") pure (mkExchangeRateRep src dst n d)+ 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+{-# INLINE storeContramapSize #-} #endif
tests/Main.hs view
@@ -26,7 +26,9 @@ -------------------------------------------------------------------------------- -instance QC.Arbitrary (Money.Discrete' currency scale) where+instance+ ( Money.GoodScale scale+ ) => QC.Arbitrary (Money.Discrete' currency scale) where arbitrary = fmap fromInteger QC.arbitrary shrink = fmap fromInteger . QC.shrink . toInteger @@ -178,6 +180,20 @@ , QC.testProperty "Cereal encoding roundtrip (DenseRep through Dense)" $ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> Right (Money.denseRep x) === Cereal.decode (Cereal.encode x)++ , 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.forAll QC.arbitrary $ \(x :: Money.Dense currency) ->+ let x' = Money.denseRep x+ in Right x' === Store.decode (Store.encode x')+ , QC.testProperty "Store encoding roundtrip (Dense through DenseRep)" $+ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) ->+ Right x === Store.decode (Store.encode (Money.denseRep x))+ , QC.testProperty "Store encoding roundtrip (DenseRep through Dense)" $+ QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) ->+ Right (Money.denseRep x) === Store.decode (Store.encode x) ] testExchange :: Tasty.TestTree@@ -281,6 +297,20 @@ , QC.testProperty "Cereal encoding roundtrip (DiscreteRep through Discrete)" $ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> Right (Money.discreteRep x) === Cereal.decode (Cereal.encode x)++ , 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.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) ->+ let x' = Money.discreteRep x+ in Right x' === Store.decode (Store.encode x')+ , QC.testProperty "Store encoding roundtrip (Discrete through DiscreteRep)" $+ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) ->+ Right x === Store.decode (Store.encode (Money.discreteRep x))+ , QC.testProperty "Store encoding roundtrip (DiscreteRep through Discrete)" $+ QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) ->+ Right (Money.discreteRep x) === Store.decode (Store.encode x) ] testExchangeRate@@ -379,6 +409,20 @@ , QC.testProperty "Cereal encoding roundtrip (ExchangeRateRep through ExchangeRate)" $ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> Right (Money.exchangeRateRep x) === Cereal.decode (Cereal.encode x)++ , 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.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) ->+ let x' = Money.exchangeRateRep x+ in Right x' === Store.decode (Store.encode x')+ , QC.testProperty "Store encoding roundtrip (ExchangeRate through ExchangeRateRep)" $+ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) ->+ Right x === Store.decode (Store.encode (Money.exchangeRateRep x))+ , QC.testProperty "Store encoding roundtrip (ExchangeRateRep through ExchangeRate)" $+ QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) ->+ Right (Money.exchangeRateRep x) === Store.decode (Store.encode x) ] testRounding