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 `FromXml` and `ToXml` instances (from the `xmlbf` +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-xmlbf@ includes the same @xmlbf@ + support and tests that were present in @safe-money-0.6@. diff --git a/safe-money-xmlbf.cabal b/safe-money-xmlbf.cabal new file mode 100644 --- /dev/null +++ b/safe-money-xmlbf.cabal @@ -0,0 +1,56 @@ +name: safe-money-xmlbf +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 xmlbf library for the safe-money library. +description: + This library exports @FromXml@ and @ToXml@ instances (from the @xmlbf@ + 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), + safe-money, + text, + xmlbf + exposed-modules: + Money.Xmlbf + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base, + bytestring, + safe-money, + safe-money-xmlbf, + tasty, + tasty-hunit, + tasty-quickcheck, + text, + xmlbf + diff --git a/src/Money/Xmlbf.hs b/src/Money/Xmlbf.hs new file mode 100644 --- /dev/null +++ b/src/Money/Xmlbf.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | This module only exports orphan 'Ae.FromXml' and 'Ae.ToXml' instances. +-- Import as: +-- +-- @ +-- import "Money.Xmlbf" () +-- @ +module Money.Xmlbf () where + +import Control.Applicative (empty) +import Control.Monad (when) +import Data.Ratio ((%), numerator, denominator) +import qualified Data.Text as T +import GHC.Exts (fromList) +import GHC.TypeLits (KnownSymbol) +import qualified Money +import qualified Xmlbf + +-------------------------------------------------------------------------------- + +-- | Compatible with 'Money.SomeDense' +-- +-- Example rendering @'Money.dense' (2 '%' 3) :: 'Money.Dense' \"BTC\"@: +-- +-- @ +-- \ +-- @ +instance KnownSymbol currency => Xmlbf.ToXml (Money.Dense currency) where + toXml = Xmlbf.toXml . Money.toSomeDense + +-- | Compatible with 'Money.SomeDense' +instance KnownSymbol currency => Xmlbf.FromXml (Money.Dense currency) where + fromXml = maybe empty pure =<< fmap Money.fromSomeDense Xmlbf.fromXml + +-- | Compatible with 'Money.Dense' +instance Xmlbf.ToXml Money.SomeDense where + toXml = \sd -> + let r = Money.someDenseAmount sd + as = [ (T.pack "c", Money.someDenseCurrency sd) + , (T.pack "n", T.pack (show (numerator r))) + , (T.pack "d", T.pack (show (denominator r))) ] + in [ Xmlbf.element' (T.pack "money-dense") (fromList as) [] ] + +-- | Compatible with 'Money.Dense'. +instance Xmlbf.FromXml Money.SomeDense where + fromXml = Xmlbf.pElement (T.pack "money-dense") $ do + c <- 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 (Money.mkSomeDense c (n % d)) + +-- | Compatible with 'Money.SomeDiscrete' +-- +-- Example rendering @'Money.discrete' 43 :: 'Money.Discrete' \"BTC\" \"satoshi\"@: +-- +-- @ +-- \ +-- @ +instance + ( KnownSymbol currency, Money.GoodScale scale + ) => Xmlbf.ToXml (Money.Discrete' currency scale) where + toXml = Xmlbf.toXml . Money.toSomeDiscrete + +-- | Compatible with 'Money.SomeDiscrete' +instance + ( KnownSymbol currency, Money.GoodScale scale + ) => Xmlbf.FromXml (Money.Discrete' currency scale) where + fromXml = maybe empty pure =<< fmap Money.fromSomeDiscrete Xmlbf.fromXml + +-- | Compatible with 'Money.Discrete'' +instance Xmlbf.ToXml Money.SomeDiscrete where + toXml = \sd -> + let r = Money.someDiscreteScale sd + as = [ ("c", Money.someDiscreteCurrency sd) + , ("n", T.pack (show (numerator r))) + , ("d", T.pack (show (denominator r))) + , ("a", T.pack (show (Money.someDiscreteAmount sd))) ] + in [ Xmlbf.element' (T.pack "money-discrete") (fromList as) [] ] + +-- | Compatible with 'Money.Discrete'' +instance Xmlbf.FromXml Money.SomeDiscrete where + fromXml = Xmlbf.pElement (T.pack "money-discrete") $ do + c <- 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 (Money.mkSomeDiscrete c (n % d) a) + +-- | Compatible with 'Money..SomeExchangeRate' +-- +-- Example rendering an 'Money.ExchangeRate' constructed with +-- @'Money.exchangeRate' (5 '%' 7) :: 'Money.ExchangeRate' \"USD\" \"JPY\"@ +-- +-- @ +-- \ +-- @ +instance + ( KnownSymbol src, KnownSymbol dst + ) => Xmlbf.ToXml (Money.ExchangeRate src dst) where + toXml = Xmlbf.toXml . Money.toSomeExchangeRate + +-- | Compatible with 'Money.SomeExchangeRate' +instance + ( KnownSymbol src, KnownSymbol dst + ) => Xmlbf.FromXml (Money.ExchangeRate src dst) where + fromXml = maybe empty pure =<< fmap Money.fromSomeExchangeRate Xmlbf.fromXml + +-- | Compatible with 'Money.ExchangeRate' +instance Xmlbf.ToXml Money.SomeExchangeRate where + toXml = \ser -> + let r = Money.someExchangeRateRate ser + as = [ ("src", Money.someExchangeRateSrcCurrency ser) + , ("dst", Money.someExchangeRateDstCurrency ser) + , ("n", T.pack (show (numerator r))) + , ("d", T.pack (show (denominator r))) ] + in [ Xmlbf.element' (T.pack "exchange-rate") (fromList as) [] ] + +-- | Compatible with 'Money.ExchangeRate' +instance Xmlbf.FromXml Money.SomeExchangeRate where + fromXml = Xmlbf.pElement (T.pack "exchange-rate") $ do + src <- Xmlbf.pAttr "src" + dst <- 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 (Money.mkSomeExchangeRate src dst (n % d)) + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,208 @@ +{-# 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 Data.Proxy (Proxy(Proxy)) +import Data.Ratio ((%), numerator, denominator) +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 qualified Xmlbf + +import Money.Xmlbf () + +-------------------------------------------------------------------------------- + +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 "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) + ] + +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 "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) + ] + +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 "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) + ] + +-------------------------------------------------------------------------------- +-- Raw parsing "golden tests" + +testRawSerializations :: Tasty.TestTree +testRawSerializations = + Tasty.testGroup "Raw serializations" + [ Tasty.testGroup "xmlbf" + [ Tasty.testGroup "decode" + [ HU.testCase "Dense" $ do + Right rawDns0 @=? Xmlbf.runParser Xmlbf.fromXml rawDns0_xmlbf + , HU.testCase "Discrete" $ do + Right rawDis0 @=? Xmlbf.runParser Xmlbf.fromXml rawDis0_xmlbf + , HU.testCase "ExchangeRate" $ do + Right rawXr0 @=? Xmlbf.runParser Xmlbf.fromXml rawXr0_xmlbf + ] + , Tasty.testGroup "encode" + [ HU.testCase "Dense" $ rawDns0_xmlbf @=? Xmlbf.toXml rawDns0 + , HU.testCase "Discrete" $ rawDis0_xmlbf @=? Xmlbf.toXml rawDis0 + , HU.testCase "ExchangeRate" $ rawXr0_xmlbf @=? Xmlbf.toXml 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) + +rawDns0_xmlbf :: [Xmlbf.Node] +rawDns0_xmlbf = -- "" + [ Xmlbf.element' "money-dense" (fromList [("n","26"), ("d","1"), ("c","USD")]) [] ] +rawDis0_xmlbf :: [Xmlbf.Node] +rawDis0_xmlbf = -- "" + [ Xmlbf.element' "money-discrete" (fromList [("n","100"), ("d","1"), ("c","USD"), ("a","4")]) [] ] +rawXr0_xmlbf :: [Xmlbf.Node] +rawXr0_xmlbf = -- "" + [ Xmlbf.element' "exchange-rate" (fromList [("n","3"), ("d","2"), ("src","USD"), ("dst","BTC")]) [] ] + +