From 7d2d92921c9a5832a347e04f74ae770f507c4d8c Mon Sep 17 00:00:00 2001 From: Johannes Lund Date: Mon, 10 Aug 2020 14:23:49 +0200 Subject: [PATCH] Run coin selection properties with non-zero withdrawal When looking at the testing for coin selection I noticed these properties assumed withdrawal=0. By extending CoinSelProp we can also test what happens when withdrawal /= 0. They pass. I don't think there's a problem here. --- .../CoinSelection/LargestFirstSpec.hs | 17 ++++++-------- .../Primitive/CoinSelection/RandomSpec.hs | 14 +++++------- .../Wallet/Primitive/CoinSelectionSpec.hs | 22 +++++++++++++++---- 3 files changed, 31 insertions(+), 22 deletions(-) diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/LargestFirstSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/LargestFirstSpec.hs index 58ebb4c2ead..63b972dde08 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/LargestFirstSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/LargestFirstSpec.hs @@ -33,8 +33,6 @@ import Data.Functor.Identity ( Identity (runIdentity) ) import Data.List.NonEmpty ( NonEmpty (..) ) -import Data.Quantity - ( Quantity (..) ) import Test.Hspec ( Spec, describe, it, shouldSatisfy ) import Test.QuickCheck @@ -253,29 +251,28 @@ spec = do propDeterministic :: CoinSelProp -> Property -propDeterministic (CoinSelProp utxo txOuts) = do +propDeterministic (CoinSelProp utxo wdrl txOuts) = do let opts = CoinSelectionOptions (const 100) noValidation - let withdraw = Quantity 0 - let resultOne = runIdentity $ runExceptT $ largestFirst opts txOuts withdraw utxo - let resultTwo = runIdentity $ runExceptT $ largestFirst opts txOuts withdraw utxo + let resultOne = runIdentity $ runExceptT $ largestFirst opts txOuts wdrl utxo + let resultTwo = runIdentity $ runExceptT $ largestFirst opts txOuts wdrl utxo resultOne === resultTwo propAtLeast :: CoinSelProp -> Property -propAtLeast (CoinSelProp utxo txOuts) = +propAtLeast (CoinSelProp utxo wdrl txOuts) = isRight selection ==> let Right (s,_) = selection in prop s where prop cs = L.length (inputs cs) `shouldSatisfy` (>= NE.length txOuts) selection = runIdentity $ runExceptT $ do let opts = CoinSelectionOptions (const 100) noValidation - largestFirst opts txOuts (Quantity 0) utxo + largestFirst opts txOuts wdrl utxo propInputDecreasingOrder :: CoinSelProp -> Property -propInputDecreasingOrder (CoinSelProp utxo txOuts) = +propInputDecreasingOrder (CoinSelProp utxo wdrl txOuts) = isRight selection ==> let Right (s,_) = selection in prop s where prop cs = @@ -289,4 +286,4 @@ propInputDecreasingOrder (CoinSelProp utxo txOuts) = getExtremumValue f = f . map (getCoin . coin . snd) selection = runIdentity $ runExceptT $ do let opts = CoinSelectionOptions (const 100) noValidation - largestFirst opts txOuts (Quantity 0) utxo + largestFirst opts txOuts wdrl utxo diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/RandomSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/RandomSpec.hs index 509035158db..fd8bcaf6a1e 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/RandomSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/RandomSpec.hs @@ -35,8 +35,6 @@ import Data.Functor.Identity ( Identity (..) ) import Data.List.NonEmpty ( NonEmpty (..) ) -import Data.Quantity - ( Quantity (..) ) import Test.Hspec ( Spec, before, describe, it, shouldSatisfy ) import Test.QuickCheck @@ -346,7 +344,7 @@ propFragmentation :: SystemDRG -> CoinSelProp -> Property -propFragmentation drg (CoinSelProp utxo txOuts) = do +propFragmentation drg (CoinSelProp utxo wdrl txOuts) = do isRight selection1 && isRight selection2 ==> let (Right (s1,_), Right (s2,_)) = (selection1, selection2) @@ -355,16 +353,16 @@ propFragmentation drg (CoinSelProp utxo txOuts) = do prop (cs1, cs2) = L.length (inputs cs1) `shouldSatisfy` (>= L.length (inputs cs2)) (selection1,_) = withDRG drg - (runExceptT $ random opt txOuts (Quantity 0) utxo) + (runExceptT $ random opt txOuts wdrl utxo) selection2 = runIdentity $ runExceptT $ - largestFirst opt txOuts (Quantity 0) utxo + largestFirst opt txOuts wdrl utxo opt = CoinSelectionOptions (const 100) noValidation propErrors :: SystemDRG -> CoinSelProp -> Property -propErrors drg (CoinSelProp utxo txOuts) = do +propErrors drg (CoinSelProp utxo wdrl txOuts) = do isLeft selection1 && isLeft selection2 ==> let (Left s1, Left s2) = (selection1, selection2) in prop (s1, s2) @@ -372,7 +370,7 @@ propErrors drg (CoinSelProp utxo txOuts) = do prop (err1, err2) = err1 === err2 (selection1,_) = withDRG drg - (runExceptT $ random opt txOuts (Quantity 0) utxo) + (runExceptT $ random opt txOuts wdrl utxo) selection2 = runIdentity $ runExceptT $ - largestFirst opt txOuts (Quantity 0) utxo + largestFirst opt txOuts wdrl utxo opt = (CoinSelectionOptions (const 1) noValidation) diff --git a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs index 49d49a5ee03..fe0145806bb 100644 --- a/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs +++ b/lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs @@ -68,6 +68,7 @@ import Test.QuickCheck , counterexample , cover , elements + , frequency , generate , scale , vector @@ -83,6 +84,8 @@ import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Test.QuickCheck.Monadic as QC +{-# ANN module ("HLint: ignore Use <$>" :: String) #-} + spec :: Spec spec = do describe "Coin selection properties" $ do @@ -227,14 +230,17 @@ data CoinSelectionsSetup = CoinSelectionsSetup data CoinSelProp = CoinSelProp { csUtxO :: UTxO -- ^ Available UTxO for the selection + , csWithdrawal :: Quantity "lovelace" Word64 + -- ^ Available Withdrawal , csOuts :: NonEmpty TxOut -- ^ Requested outputs for the payment } deriving Show instance Buildable CoinSelProp where - build (CoinSelProp utxo outs) = mempty + build (CoinSelProp utxo wdrl outs) = mempty <> build utxo <> nameF "outs" (blockListF outs) + <> nameF "withdrawal" (build wdrl) -- | A fixture for testing the coin selection data CoinSelectionFixture = CoinSelectionFixture @@ -339,9 +345,17 @@ instance Arbitrary a => Arbitrary (NonEmpty a) where NE.fromList <$> vector n instance Arbitrary CoinSelProp where - shrink (CoinSelProp utxo outs) = uncurry CoinSelProp - <$> zip (shrink utxo) (shrink outs) - arbitrary = applyArbitrary2 CoinSelProp + shrink (CoinSelProp utxo wdrl outs) = + [ CoinSelProp utxo' wdrl outs | utxo' <- shrink utxo ] + ++ [ CoinSelProp utxo wdrl' outs | wdrl' <- shrinkWdrl wdrl ] + ++ [ CoinSelProp utxo wdrl outs' | outs' <- shrink outs ] + where + shrinkWdrl = map Quantity . shrink . getQuantity + arbitrary = do + utxo <- arbitrary + wdrl <- Quantity <$> frequency [(65, return 0), (35, arbitrary)] + outs <- arbitrary + return $ CoinSelProp utxo wdrl outs instance Arbitrary CoinSelectionForMigration where arbitrary = do