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.
cardano-foundation · Aug 10, 2020 · da30d07 · da30d07
1 parent a7670ed
commit da30d07
Show file tree

Hide file tree

Showing 3 changed files with 26 additions and 14 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
@@ -253,7 +253,7 @@ 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
@@ -263,19 +263,19 @@ propDeterministic (CoinSelProp utxo txOuts) = do
 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 (Quantity 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 +289,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 (Quantity 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
@@ -346,7 +346,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)
@@ -357,22 +357,22 @@ propFragmentation drg (CoinSelProp utxo txOuts) = do
     (selection1,_) = withDRG drg
         (runExceptT $ random opt txOuts (Quantity 0) utxo)
     selection2 = runIdentity $ runExceptT $
-        largestFirst opt txOuts (Quantity 0) utxo
+        largestFirst opt txOuts (Quantity 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)
   where
     prop (err1, err2) =
         err1 === err2
     (selection1,_) = withDRG drg
-        (runExceptT $ random opt txOuts (Quantity 0) utxo)
+        (runExceptT $ random opt txOuts (Quantity wdrl) utxo)
     selection2 = runIdentity $ runExceptT $
-        largestFirst opt txOuts (Quantity 0) utxo
+        largestFirst opt txOuts (Quantity 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
@@ -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 :: Word64
+    -- ^ Availible 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,15 @@ 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' <- shrink wdrl ]
+        ++ [ CoinSelProp utxo wdrl outs' | outs' <- shrink outs ]
+    arbitrary = do
+        utxo <- arbitrary
+        wdrl <- frequency [(65, return 0), (35, arbitrary)]
+        outs <- arbitrary
+        return $ CoinSelProp utxo wdrl outs
 
 instance Arbitrary CoinSelectionForMigration where
     arbitrary = do