allow 'runSelection' to take Ada from an extra source

  Although, it only does so if at least one input has already been selected. I've adjusted properties accordingly, generating an extra source when it made sense, and leaving it as 'Nothing' for some others.

lib/core/src/Cardano/Wallet/Primitive/CoinSelection/MA/RoundRobin.hs

@@ -101,13 +101,16 @@ data SelectionState = SelectionState
 
 runSelection
     :: forall m. MonadRandom m
-    => UTxOIndex
+    => Maybe Coin
+        -- ^ An extra source of Ada, which can only be used after at least one
+        -- input has been selected.
+    -> UTxOIndex
         -- ^ UTxO entries available for selection
     -> TokenBundle
         -- ^ Minimum balance to cover
     -> m SelectionState
         -- ^ Final selection state
-runSelection available minimumBalance =
+runSelection mExtraSource available minimumBalance =
     runRoundRobinM initialState selectors
   where
     initialState :: SelectionState
@@ -116,6 +119,9 @@ runSelection available minimumBalance =
         , leftover = available
         }
 
+    extraSource :: Natural
+    extraSource = maybe 0 (fromIntegral . unCoin) mExtraSource
+
     selectors :: [SelectionState -> m (Maybe SelectionState)]
     selectors = coinSelector : fmap assetSelector minimumAssetQuantities
       where
@@ -137,7 +143,10 @@ runSelection available minimumBalance =
 
     coinSelectionLens :: SelectionLens m SelectionState
     coinSelectionLens = SelectionLens
-        { currentQuantity = coinQuantity . selected
+        { currentQuantity = \s ->
+            coinQuantity (selected s)
+            +
+            if UTxOIndex.null (selected s) then 0 else extraSource
         , minimumQuantity = fromIntegral $ unCoin minimumCoinQuantity
         , selectQuantity = selectMatchingQuantity
             [ WithAdaOnly

lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelection/MA/RoundRobinSpec.hs

@@ -29,6 +29,8 @@ import Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobin
     )
 import Cardano.Wallet.Primitive.Types.Coin
     ( Coin (..) )
+import Cardano.Wallet.Primitive.Types.Coin.Gen
+    ( genCoinSmallPositive, shrinkCoinSmallPositive )
 import Cardano.Wallet.Primitive.Types.TokenBundle
     ( TokenBundle )
 import Cardano.Wallet.Primitive.Types.TokenBundle.Gen
@@ -128,6 +130,8 @@ spec = describe "Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobinSpec" $
             property prop_runSelection_UTxO_notEnough
         it "prop_runSelection_UTxO_exactlyEnough" $
             property prop_runSelection_UTxO_exactlyEnough
+        it "prop_runSelection_UTxO_extraSourceUsed" $
+            property prop_runSelection_UTxO_extraSourceUsed
         it "prop_runSelection_UTxO_moreThanEnough" $
             property prop_runSelection_UTxO_moreThanEnough
         it "prop_runSelection_UTxO_muchMoreThanEnough" $
@@ -234,20 +238,23 @@ prop_Large_UTxOIndex_coverage (Large index) =
 --------------------------------------------------------------------------------
 
 prop_runSelection_UTxO_empty
-    :: TokenBundle -> Property
-prop_runSelection_UTxO_empty balanceRequested = monadicIO $ do
+    :: Maybe Coin
+    -> TokenBundle
+    -> Property
+prop_runSelection_UTxO_empty extraSource balanceRequested = monadicIO $ do
     SelectionState {selected, leftover} <-
-        run $ runSelection UTxOIndex.empty balanceRequested
+        run $ runSelection extraSource UTxOIndex.empty balanceRequested
     let balanceSelected = view #balance selected
     let balanceLeftover = view #balance leftover
     assert $ balanceSelected == TokenBundle.empty
     assert $ balanceLeftover == TokenBundle.empty
 
 prop_runSelection_UTxO_notEnough
-    :: Small UTxOIndex -> Property
+    :: Small UTxOIndex
+    -> Property
 prop_runSelection_UTxO_notEnough (Small index) = monadicIO $ do
     SelectionState {selected, leftover} <-
-        run $ runSelection index balanceRequested
+        run $ runSelection Nothing index balanceRequested
     let balanceSelected = view #balance selected
     let balanceLeftover = view #balance leftover
     assert $ balanceSelected == balanceAvailable
@@ -257,30 +264,71 @@ prop_runSelection_UTxO_notEnough (Small index) = monadicIO $ do
     balanceRequested = adjustAllQuantities (* 2) balanceAvailable
 
 prop_runSelection_UTxO_exactlyEnough
-    :: Small UTxOIndex -> Property
+    :: Small UTxOIndex
+    -> Property
 prop_runSelection_UTxO_exactlyEnough (Small index) = monadicIO $ do
     SelectionState {selected, leftover} <-
-        run $ runSelection index balanceRequested
+        run $ runSelection Nothing index balanceRequested
     let balanceSelected = view #balance selected
     let balanceLeftover = view #balance leftover
     assert $ balanceSelected == balanceRequested
     assert $ balanceLeftover == TokenBundle.empty
   where
     balanceRequested = view #balance index
 
+prop_runSelection_UTxO_extraSourceUsed
+    :: Maybe Coin
+    -> Small UTxOIndex
+    -> Property
+prop_runSelection_UTxO_extraSourceUsed extraSource (Small index) =
+    monadicIO $ case almostEverything of
+        Nothing ->
+            assert True
+        Just balanceRequested | balanceRequested == TokenBundle.empty -> do
+            SelectionState {selected,leftover} <-
+                run $ runSelection extraSource index balanceRequested
+            let balanceSelected = view #balance selected
+            let balanceLeftover = view #balance leftover
+            assert $ balanceLeftover == view #balance index
+            assert $ balanceSelected == TokenBundle.empty
+        Just balanceRequested -> do
+            monitor (cover 80 True "sometimes there are Ada")
+            SelectionState {selected} <-
+                run $ runSelection extraSource index balanceRequested
+            let balanceSelected = view #balance selected
+            let coinSelected = TokenBundle.coin $
+                    addExtraSource extraSource balanceSelected
+            monitor $ counterexample $ unlines
+                [ "balance selected: " <> show balanceSelected
+                ]
+            assert $ coinSelected >= TokenBundle.coin balanceRequested
+            assert $ balanceSelected /= TokenBundle.empty
+  where
+    almostEverything = TokenBundle.subtract
+        (view #balance index)
+        (TokenBundle.fromCoin (Coin 1))
+
 prop_runSelection_UTxO_moreThanEnough
-    :: Small UTxOIndex -> Property
-prop_runSelection_UTxO_moreThanEnough (Small index) = monadicIO $ do
+    :: Maybe Coin
+    -> Small UTxOIndex
+    -> Property
+prop_runSelection_UTxO_moreThanEnough extraSource (Small index) = monadicIO $ do
     SelectionState {selected, leftover} <-
-        run $ runSelection index balanceRequested
+        run $ runSelection extraSource index balanceRequested
     let balanceSelected = view #balance selected
     let balanceLeftover = view #balance leftover
     monitor $ cover 80
         (assetsRequested `Set.isProperSubsetOf` assetsAvailable)
         "assetsRequested ⊂ assetsAvailable"
     monitor $ cover 50 (Set.size assetsRequested >= 4)
         "size assetsRequested >= 4"
-    assert $ balanceRequested `leq` balanceSelected
+    monitor $ counterexample $ unlines
+        [ "balance available: " <> show balanceAvailable
+        , "balance requested: " <> show balanceRequested
+        , "balance selected:  " <> show balanceSelected
+        , "balance leftover:  " <> show balanceLeftover
+        ]
+    assert $ balanceRequested `leq` addExtraSource extraSource balanceSelected
     assert $ balanceAvailable == balanceSelected <> balanceLeftover
   where
     assetsAvailable = TokenBundle.getAssets balanceAvailable
@@ -290,22 +338,30 @@ prop_runSelection_UTxO_moreThanEnough (Small index) = monadicIO $ do
         cutAssetSetSizeInHalf balanceAvailable
 
 prop_runSelection_UTxO_muchMoreThanEnough
-    :: Blind (Large UTxOIndex) -> Property
-prop_runSelection_UTxO_muchMoreThanEnough (Blind (Large index)) =
+    :: Maybe Coin
+    -> Blind (Large UTxOIndex)
+    -> Property
+prop_runSelection_UTxO_muchMoreThanEnough extraSource (Blind (Large index)) =
     -- Generation of large UTxO sets takes longer, so limit the number of runs:
     withMaxSuccess 100 $
     checkCoverage $
     monadicIO $ do
         SelectionState {selected, leftover} <-
-            run $ runSelection index balanceRequested
+            run $ runSelection extraSource index balanceRequested
         let balanceSelected = view #balance selected
         let balanceLeftover = view #balance leftover
         monitor $ cover 80
             (assetsRequested `Set.isProperSubsetOf` assetsAvailable)
             "assetsRequested ⊂ assetsAvailable"
         monitor $ cover 50 (Set.size assetsRequested >= 4)
             "size assetsRequested >= 4"
-        assert $ balanceRequested `leq` balanceSelected
+        monitor $ counterexample $ unlines
+            [ "balance available: " <> show balanceAvailable
+            , "balance requested: " <> show balanceRequested
+            , "balance selected:  " <> show balanceSelected
+            , "balance leftover:  " <> show balanceLeftover
+            ]
+        assert $ balanceRequested `leq` addExtraSource extraSource balanceSelected
         assert $ balanceAvailable == balanceSelected <> balanceLeftover
   where
     assetsAvailable = TokenBundle.getAssets balanceAvailable
@@ -671,6 +727,11 @@ consecutivePairs xs = case tailMay xs of
 inAscendingPartialOrder :: (Foldable f, PartialOrd a) => f a -> Bool
 inAscendingPartialOrder = all (uncurry leq) . consecutivePairs . F.toList
 
+addExtraSource :: Maybe Coin -> TokenBundle -> TokenBundle
+addExtraSource extraSource =
+    TokenBundle.add
+        (maybe TokenBundle.empty TokenBundle.fromCoin extraSource)
+
 --------------------------------------------------------------------------------
 -- Arbitraries
 --------------------------------------------------------------------------------
@@ -713,3 +774,7 @@ instance Arbitrary (Large UTxOIndex) where
 instance Arbitrary (Small UTxOIndex) where
     arbitrary = Small <$> genUTxOIndexSmall
     shrink = fmap Small . shrinkUTxOIndexSmall . getSmall
+
+instance Arbitrary Coin where
+    arbitrary = genCoinSmallPositive
+    shrink = shrinkCoinSmallPositive