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 11, 2020 · 7d2d929 · 7d2d929
1 parent a7670ed
commit 7d2d929
Show file tree

Hide file tree

Showing 3 changed files with 31 additions and 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
@@ -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
@@ -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,24 +353,24 @@ 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)
   where
     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
@@ -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