diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016-2018, Renzo Carbonara + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Renzo Carbonara nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +This library exports `Store` instances (from the `store` library) +for many of the types exported by the `safe-money` library. + +Note: The code in this library used to be part of the `safe-money` +library itself, so these instances are intended to be backwards +compatible with older versions of `safe-money`. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,4 @@ +#! /usr/bin/env nix-shell +#! nix-shell ./shell.nix -i runghc +import Distribution.Simple +main = defaultMain diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,4 @@ +# Version 0.1 + +* This first release of @safe-money-store@ includes the same @store@ support + and tests that were present in @safe-money-0.6@. diff --git a/safe-money-store.cabal b/safe-money-store.cabal new file mode 100644 --- /dev/null +++ b/safe-money-store.cabal @@ -0,0 +1,56 @@ +name: safe-money-store +version: 0.1 +license: BSD3 +license-file: LICENSE +copyright: Copyright (c) Renzo Carbonara 2016-2018 +author: Renzo Carbonara +maintainer: renĪ»ren!zone +stability: Experimental +tested-with: GHC==8.4.1 +homepage: https://github.com/k0001/safe-money +bug-reports: https://github.com/k0001/safe-money/issues +category: Money +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md changelog.md +synopsis: Instances from the store library for the safe-money library. +description: + This library exports @Store@ instances (from the @store@ library) + for many of the types exported by the @safe-money@ library. + . + Note: The code in this library used to be part of the @safe-money@ + library itself, so these instances are intended to be backwards + compatible with older versions of @safe-money@. + +source-repository head + type: git + location: https://github.com/k0001/safe-money + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall -O2 + build-depends: + base >=4.8 && <5.0, + bytestring, + safe-money, + store >=0.2 + exposed-modules: + Money.Store + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base, + store, + bytestring, + safe-money, + safe-money-store, + store, + tasty, + tasty-hunit, + tasty-quickcheck, + text diff --git a/src/Money/Store.hs b/src/Money/Store.hs new file mode 100644 --- /dev/null +++ b/src/Money/Store.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | This module only exports orphan 'Store.Store' instances. Import as: +-- +-- @ +-- import "Money.Store" () +-- @ +module Money.Store () where + +import Control.Monad (when) +import Data.Ratio ((%), numerator, denominator) +import GHC.TypeLits (KnownSymbol) +import qualified Data.Store as Store +import qualified Money +import qualified Money.Internal as MoneyI + +-------------------------------------------------------------------------------- + +-- | Compatible with 'Money.SomeDense'. +instance (KnownSymbol currency) => Store.Store (Money.Dense currency) where + size = storeContramapSize Money.toSomeDense Store.size + poke = Store.poke . Money.toSomeDense + peek = maybe (fail "peek") pure =<< fmap Money.fromSomeDense Store.peek + +-- | Compatible with 'Money.Dense'. +instance Store.Store Money.SomeDense where + poke = \sd -> do + Store.poke (MoneyI.someDenseCurrency' sd) + let r = Money.someDenseAmount sd + 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 (MoneyI.mkSomeDense' c (n % d)) + +-- | Compatible with 'Money.SomeDiscrete'. +instance + ( KnownSymbol currency, Money.GoodScale scale + ) => Store.Store (Money.Discrete' currency scale) where + size = storeContramapSize Money.toSomeDiscrete Store.size + poke = Store.poke . Money.toSomeDiscrete + peek = maybe (fail "peek") pure =<< fmap Money.fromSomeDiscrete Store.peek + +-- | Compatible with 'Money.Discrete''. +instance Store.Store Money.SomeDiscrete where + poke = \sd -> do + Store.poke (MoneyI.someDiscreteCurrency' sd) + let r = Money.someDiscreteScale sd + Store.poke (numerator r) + Store.poke (denominator r) + Store.poke (Money.someDiscreteAmount sd) + peek = maybe (fail "peek") pure =<< do + -- We go through String for backwards compatibility. + c :: String <- Store.peek + n :: Integer <- Store.peek + d :: Integer <- Store.peek + when (d == 0) (fail "denominator is zero") + a :: Integer <- Store.peek + pure (MoneyI.mkSomeDiscrete' c (n % d) a) + +-- | Compatible with 'Money.SomeExchangeRate'. +instance + ( KnownSymbol src, KnownSymbol dst + ) => Store.Store (Money.ExchangeRate src dst) where + size = storeContramapSize Money.toSomeExchangeRate Store.size + poke = Store.poke . Money.toSomeExchangeRate + peek = maybe (fail "peek") pure =<< fmap Money.fromSomeExchangeRate Store.peek + +-- | Compatible with 'ExchangeRate'. +instance Store.Store Money.SomeExchangeRate where + poke = \ser -> do + Store.poke (MoneyI.someExchangeRateSrcCurrency' ser) + Store.poke (MoneyI.someExchangeRateDstCurrency' ser) + let r = Money.someExchangeRateRate ser + Store.poke (numerator r) + Store.poke (denominator r) + peek = maybe (fail "peek") pure =<< do + src :: String <- Store.peek + dst :: String <- Store.peek + n :: Integer <- Store.peek + d :: Integer <- Store.peek + when (d == 0) (fail "denominator is zero") + pure (MoneyI.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 #-} + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeApplications #-} + +module Main where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Char as Char +import Data.Proxy (Proxy(Proxy)) +import Data.Ratio ((%), numerator, denominator) +import qualified Data.Store as Store +import qualified Data.Text as T +import Data.Word (Word8) +import GHC.Exts (fromList) +import GHC.TypeLits (Nat, Symbol, KnownSymbol, symbolVal) +import qualified Money +import qualified Test.Tasty as Tasty +import Test.Tasty.HUnit ((@?=), (@=?)) +import qualified Test.Tasty.HUnit as HU +import qualified Test.Tasty.Runners as Tasty +import Test.Tasty.QuickCheck ((===), (==>), (.&&.)) +import qualified Test.Tasty.QuickCheck as QC + +import Money.Store () + +-------------------------------------------------------------------------------- + +main :: IO () +main = Tasty.defaultMainWithIngredients + [ Tasty.consoleTestReporter + , Tasty.listingTests + ] (Tasty.localOption (QC.QuickCheckTests 100) tests) + +tests :: Tasty.TestTree +tests = + Tasty.testGroup "root" + [ testCurrencies + , testCurrencyUnits + , testExchange + , testRawSerializations + ] + +testCurrencies :: Tasty.TestTree +testCurrencies = + Tasty.testGroup "Currency" + [ testDense (Proxy :: Proxy "BTC") -- A cryptocurrency. + , testDense (Proxy :: Proxy "USD") -- A fiat currency with decimal fractions. + , testDense (Proxy :: Proxy "VUV") -- A fiat currency with non-decimal fractions. + , testDense (Proxy :: Proxy "XAU") -- A precious metal. + ] + +testCurrencyUnits :: Tasty.TestTree +testCurrencyUnits = + Tasty.testGroup "Currency units" + [ testDiscrete (Proxy :: Proxy "BTC") (Proxy :: Proxy "BTC") + , testDiscrete (Proxy :: Proxy "BTC") (Proxy :: Proxy "satoshi") + , testDiscrete (Proxy :: Proxy "BTC") (Proxy :: Proxy "bitcoin") + , testDiscrete (Proxy :: Proxy "USD") (Proxy :: Proxy "USD") + , testDiscrete (Proxy :: Proxy "USD") (Proxy :: Proxy "cent") + , testDiscrete (Proxy :: Proxy "USD") (Proxy :: Proxy "dollar") + , testDiscrete (Proxy :: Proxy "VUV") (Proxy :: Proxy "vatu") + , testDiscrete (Proxy :: Proxy "XAU") (Proxy :: Proxy "gram") + , testDiscrete (Proxy :: Proxy "XAU") (Proxy :: Proxy "grain") + ] + +testDense + :: forall currency + . KnownSymbol currency + => Proxy currency + -> Tasty.TestTree +testDense pc = + Tasty.testGroup ("Dense " ++ show (symbolVal pc)) + [ 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 (SomeDense)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + let x' = Money.toSomeDense x + in Right x' === Store.decode (Store.encode x') + , QC.testProperty "Store encoding roundtrip (Dense through SomeDense)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Dense currency) -> + 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.toSomeDense x) === Store.decode (Store.encode x) + ] + +testExchange :: Tasty.TestTree +testExchange = + Tasty.testGroup "Exchange" + [ testExchangeRate (Proxy :: Proxy "BTC") (Proxy :: Proxy "BTC") + , testExchangeRate (Proxy :: Proxy "BTC") (Proxy :: Proxy "USD") + , testExchangeRate (Proxy :: Proxy "BTC") (Proxy :: Proxy "VUV") + , testExchangeRate (Proxy :: Proxy "BTC") (Proxy :: Proxy "XAU") + , testExchangeRate (Proxy :: Proxy "USD") (Proxy :: Proxy "BTC") + , testExchangeRate (Proxy :: Proxy "USD") (Proxy :: Proxy "USD") + , testExchangeRate (Proxy :: Proxy "USD") (Proxy :: Proxy "VUV") + , testExchangeRate (Proxy :: Proxy "USD") (Proxy :: Proxy "XAU") + , testExchangeRate (Proxy :: Proxy "VUV") (Proxy :: Proxy "BTC") + , testExchangeRate (Proxy :: Proxy "VUV") (Proxy :: Proxy "USD") + , testExchangeRate (Proxy :: Proxy "VUV") (Proxy :: Proxy "VUV") + , testExchangeRate (Proxy :: Proxy "VUV") (Proxy :: Proxy "XAU") + , testExchangeRate (Proxy :: Proxy "XAU") (Proxy :: Proxy "BTC") + , testExchangeRate (Proxy :: Proxy "XAU") (Proxy :: Proxy "USD") + , testExchangeRate (Proxy :: Proxy "XAU") (Proxy :: Proxy "VUV") + , testExchangeRate (Proxy :: Proxy "XAU") (Proxy :: Proxy "XAU") + ] + + +testDiscrete + :: forall (currency :: Symbol) (unit :: Symbol) + . ( Money.GoodScale (Money.Scale currency unit) + , KnownSymbol currency + , KnownSymbol unit ) + => Proxy currency + -> Proxy unit + -> Tasty.TestTree +testDiscrete pc pu = + Tasty.testGroup ("Discrete " ++ show (symbolVal pc) ++ " " + ++ show (symbolVal pu)) + [ 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 (SomeDiscrete)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + let x' = Money.toSomeDiscrete x + in Right x' === Store.decode (Store.encode x') + , QC.testProperty "Store encoding roundtrip (Discrete through SomeDiscrete)" $ + QC.forAll QC.arbitrary $ \(x :: Money.Discrete currency unit) -> + 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.toSomeDiscrete x) === Store.decode (Store.encode x) + ] + +testExchangeRate + :: forall (src :: Symbol) (dst :: Symbol) + . (KnownSymbol src, KnownSymbol dst) + => Proxy src + -> Proxy dst + -> Tasty.TestTree +testExchangeRate ps pd = + Tasty.testGroup ("ExchangeRate " ++ show (symbolVal ps) ++ " " + ++ show (symbolVal pd)) + [ 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 (SomeExchangeRate)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + let x' = Money.toSomeExchangeRate x + in Right x' === Store.decode (Store.encode x') + , QC.testProperty "Store encoding roundtrip (ExchangeRate through SomeExchangeRate)" $ + QC.forAll QC.arbitrary $ \(x :: Money.ExchangeRate src dst) -> + 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.toSomeExchangeRate x) === Store.decode (Store.encode x) + ] + +-------------------------------------------------------------------------------- +-- Raw parsing "golden tests" + +testRawSerializations :: Tasty.TestTree +testRawSerializations = + Tasty.testGroup "Raw serializations" + [ Tasty.testGroup "store" + [ Tasty.testGroup "decode" + [ HU.testCase "Dense" $ do + Right rawDns0 @=? Store.decode rawDns0_store + , HU.testCase "Discrete" $ do + Right rawDis0 @=? Store.decode rawDis0_store + , HU.testCase "ExchangeRate" $ do + Right rawXr0 @=? Store.decode rawXr0_store + ] + , Tasty.testGroup "encode" + [ HU.testCase "Dense" $ rawDns0_store @=? Store.encode rawDns0 + , HU.testCase "Discrete" $ rawDis0_store @=? Store.encode rawDis0 + , HU.testCase "ExchangeRate" $ rawXr0_store @=? Store.encode rawXr0 + ] + ] + ] + +rawDns0 :: Money.Dense "USD" +rawDns0 = Money.dense' (26%1) + +rawDis0 :: Money.Discrete "USD" "cent" +rawDis0 = Money.discrete 4 + +rawXr0 :: Money.ExchangeRate "USD" "BTC" +Just rawXr0 = Money.exchangeRate (3%2) + + +-- Such a waste of space these many bytes! Can we shrink this and maintain +-- backwards compatibility? +rawDns0_store :: B.ByteString +rawDns0_store = "\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NULU\NUL\NUL\NULS\NUL\NUL\NULD\NUL\NUL\NUL\NUL\SUB\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL" +rawDis0_store :: B.ByteString +rawDis0_store = "\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NULU\NUL\NUL\NULS\NUL\NUL\NULD\NUL\NUL\NUL\NULd\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\EOT\NUL\NUL\NUL\NUL\NUL\NUL\NUL" +rawXr0_store :: B.ByteString +rawXr0_store = "\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NULU\NUL\NUL\NULS\NUL\NUL\NULD\NUL\NUL\NUL\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NULB\NUL\NUL\NULT\NUL\NUL\NULC\NUL\NUL\NUL\NUL\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\STX\NUL\NUL\NUL\NUL\NUL\NUL\NUL"