Add function performSelection.

This top-level function performs a complete coin selection and generates
coin bundles in one step.

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

@@ -7,8 +7,15 @@
 
 module Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobin
     (
-    -- * Running a selection
-      runSelection
+    -- * Performing a selection
+      performSelection
+    , SelectionCriteria (..)
+    , SelectionResult (..)
+    , SelectionError (..)
+    , BalanceInsufficientError (..)
+
+    -- * Running a selection (without making change)
+    , runSelection
     , SelectionState (..)
 
     -- * Running a selection step
@@ -53,6 +60,8 @@ import Cardano.Wallet.Primitive.Types.TokenMap
     ( AssetId, TokenMap )
 import Cardano.Wallet.Primitive.Types.TokenQuantity
     ( TokenQuantity (..) )
+import Cardano.Wallet.Primitive.Types.Tx
+    ( TxIn, TxOut )
 import Cardano.Wallet.Primitive.Types.UTxOIndex
     ( SelectionFilter (..), UTxOIndex (..) )
 import Control.Monad.Random.Class
@@ -88,7 +97,109 @@ import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 
 --------------------------------------------------------------------------------
--- Running a selection
+-- Performing a selection
+--------------------------------------------------------------------------------
+
+-- | Criteria for performing a selection.
+--
+data SelectionCriteria = SelectionCriteria
+    { outputsToCover
+        :: NonEmpty TxOut
+    , utxoAvailable
+        :: !UTxOIndex
+    }
+    deriving (Eq, Show)
+
+-- | The result of performing a successful selection.
+--
+data SelectionResult = SelectionResult
+    { inputsSelected
+        :: !(NonEmpty (TxIn, TxOut))
+    , changeGenerated
+        :: !(NonEmpty TokenBundle)
+    , utxoRemaining
+        :: !UTxOIndex
+    }
+    deriving (Eq, Show)
+
+-- | Represents the set of errors that may occur while performing a selection.
+--
+newtype SelectionError
+    = BalanceInsufficient BalanceInsufficientError
+
+-- | Indicates that the balance of 'utxoAvailable' is insufficient to cover the
+--   balance of 'outputsToCover'.
+--
+data BalanceInsufficientError = BalanceInsufficientError
+    { balanceAvailable
+        :: TokenBundle
+      -- ^ The balance of 'utxoAvailable'.
+    , balanceRequired
+        :: TokenBundle
+      -- ^ The balance of 'outputsToCover'.
+    }
+
+-- | Performs a coin selection and generates change bundles in one step.
+--
+-- Returns 'BalanceInsufficient' if the total balance of 'utxoAvailable' is not
+-- strictly greater than or equal to the total balance of 'outputsToCover'.
+--
+-- Provided that the total balance of 'utxoAvailable' is sufficient to cover
+-- the total balance of 'outputsToCover', this function guarantees to return
+-- an 'inputsSelected' value that satisfies:
+--
+--    balance inputsSelected >= balance outputsToCover
+--    balance inputsSelected == balance outputsToCover + balance changeGenerated
+--
+-- Finally, this function guarantees that:
+--
+--    inputsSelected ∪ utxoRemaining == utxoAvailable
+--    inputsSelected ∩ utxoRemaining == ∅
+--
+performSelection
+    :: forall m. (HasCallStack, MonadRandom m)
+    => SelectionCriteria
+    -> m (Either SelectionError SelectionResult)
+performSelection SelectionCriteria {outputsToCover, utxoAvailable}
+    | not (balanceRequired `leq` balanceAvailable) =
+        pure $ Left $ BalanceInsufficient $ BalanceInsufficientError
+            {balanceAvailable, balanceRequired}
+    | otherwise =
+        Right . mkResult <$> runSelection utxoAvailable balanceRequired
+  where
+    balanceAvailable :: TokenBundle
+    balanceAvailable = view #balance utxoAvailable
+
+    balanceRequired :: TokenBundle
+    balanceRequired = F.foldMap (view #tokens) outputsToCover
+
+    mkResult :: SelectionState -> SelectionResult
+    mkResult SelectionState {selected, leftover} =
+        case NE.nonEmpty (UTxOIndex.toList selected) of
+            Nothing ->
+                unableToSelectAnyInputsError
+            Just inputsSelected ->
+                SelectionResult
+                    { inputsSelected
+                    , utxoRemaining = leftover
+                    , changeGenerated = makeChange
+                        (view #tokens . snd <$> inputsSelected)
+                        (view #tokens <$> outputsToCover)
+                    }
+
+    unableToSelectAnyInputsError =
+        -- This should be impossible, as we have already determined
+        -- that the UTxO balance is sufficient to cover the outputs.
+        error $ unlines
+            [ "performSelection: unable to select any inputs!"
+            , "balance required:"
+            , show balanceRequired
+            , "balance available:"
+            , show balanceAvailable
+            ]
+
+--------------------------------------------------------------------------------
+-- Running a selection (without making change)
 --------------------------------------------------------------------------------
 
 data SelectionState = SelectionState

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

@@ -1,5 +1,6 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLabels #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -17,11 +18,16 @@ import Prelude
 import Algebra.PartialOrd
     ( PartialOrd (..) )
 import Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobin
-    ( SelectionLens (..)
+    ( BalanceInsufficientError (..)
+    , SelectionCriteria (..)
+    , SelectionError (..)
+    , SelectionLens (..)
+    , SelectionResult (..)
     , SelectionState (..)
     , groupByKey
     , makeChange
     , makeChangeForSurplusAssets
+    , performSelection
     , runRoundRobin
     , runSelection
     , runSelectionStep
@@ -45,6 +51,10 @@ import Cardano.Wallet.Primitive.Types.TokenQuantity
     ( TokenQuantity (..) )
 import Cardano.Wallet.Primitive.Types.TokenQuantity.Gen
     ( genTokenQuantitySmallPositive, shrinkTokenQuantitySmallPositive )
+import Cardano.Wallet.Primitive.Types.Tx
+    ( TxOut )
+import Cardano.Wallet.Primitive.Types.Tx.Gen
+    ( genTxOutSmallRange, shrinkTxOutSmallRange )
 import Cardano.Wallet.Primitive.Types.UTxOIndex
     ( UTxOIndex )
 import Cardano.Wallet.Primitive.Types.UTxOIndex.Gen
@@ -81,6 +91,7 @@ import Test.Hspec.Core.QuickCheck
     ( modifyMaxSuccess )
 import Test.QuickCheck
     ( Arbitrary (..)
+    , Blind (..)
     , Gen
     , Positive (..)
     , Property
@@ -119,7 +130,12 @@ spec = describe "Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobinSpec" $
         it "prop_Large_UTxOIndex_coverage" $
             property prop_Large_UTxOIndex_coverage
 
-    parallel $ describe "Running a selection" $ do
+    parallel $ describe "Performing a selection" $ do
+
+        it "prop_performSelection" $
+            property prop_performSelection
+
+    parallel $ describe "Running a selection (without making change)" $ do
 
         it "prop_runSelection_UTxO_empty" $
             property prop_runSelection_UTxO_empty
@@ -229,7 +245,63 @@ prop_Large_UTxOIndex_coverage (Large index) =
     entryCount = UTxOIndex.size index
 
 --------------------------------------------------------------------------------
--- Running a selection
+-- Performing a selection
+--------------------------------------------------------------------------------
+
+prop_performSelection
+    :: Blind (NonEmpty TxOut)
+    -> Blind (Large UTxOIndex)
+    -> Property
+prop_performSelection (Blind outputsToCover) (Blind (Large utxoAvailable)) =
+    -- Generation of large UTxO sets takes longer, so limit the number of runs:
+    withMaxSuccess 100 $
+    checkCoverage $
+    -- TODO: Increase coverage of this case:
+    cover 0 (not balanceSufficient)
+        "balance insufficient" $
+    cover 50 balanceSufficient
+        "balance sufficient" $
+    monadicIO $
+        either onFailure onSuccess =<< run (performSelection criteria)
+  where
+    onSuccess result = do
+        monitor $ counterexample $ unlines
+            [ "selected balance: " <> show balanceSelected
+            , "required balance: " <> show balanceRequired
+            , "  change balance: " <> show balanceChange
+            ]
+        assert $ balanceRequired `leq` balanceSelected
+        assert $ balanceSelected == balanceRequired <> balanceChange
+        assert $ utxoAvailable
+            == UTxOIndex.insertMany inputsSelected utxoRemaining
+        assert $ utxoRemaining
+            == UTxOIndex.deleteMany (fst <$> inputsSelected) utxoAvailable
+      where
+        SelectionResult
+            {inputsSelected, changeGenerated, utxoRemaining} = result
+        balanceSelected =
+            F.foldMap (view #tokens . snd) inputsSelected
+        balanceChange =
+            F.fold changeGenerated
+
+    onFailure = \case
+        BalanceInsufficient e -> onBalanceInsufficient e
+
+    onBalanceInsufficient e = do
+        assert $ not (balanceRequired `leq` balanceAvailable)
+        assert $ balanceAvailable == balanceAvailable'
+        assert $ balanceRequired  == balanceRequired'
+      where
+        BalanceInsufficientError balanceAvailable' balanceRequired' = e
+
+    criteria = SelectionCriteria {outputsToCover, utxoAvailable}
+
+    balanceSufficient = balanceRequired `leq` balanceAvailable
+    balanceRequired = F.foldMap (view #tokens) outputsToCover
+    balanceAvailable = UTxOIndex.balance utxoAvailable
+
+--------------------------------------------------------------------------------
+-- Running a selection (without making change)
 --------------------------------------------------------------------------------
 
 prop_runSelection_UTxO_empty
@@ -697,6 +769,10 @@ instance Arbitrary TokenQuantity where
     arbitrary = genTokenQuantitySmallPositive
     shrink = shrinkTokenQuantitySmallPositive
 
+instance Arbitrary TxOut where
+    arbitrary = genTxOutSmallRange
+    shrink = shrinkTxOutSmallRange
+
 newtype Large a = Large
     { getLarge :: a }
     deriving (Eq, Show)