Merge #2968

2968: Unify success post-condition for `performSelection`. r=jonathanknowles a=jonathanknowles

## Issue Number

ADP-1037

## Summary

This PR:
- adds coverage to verify that selections returned by `performSelection` respect the `SelectionLimit` returned by `computeSelectionLimit`.
- unifies the various post conditions for `performSelection` into a single post condition.

## Details

This PR follows the [pattern](https://github.com/input-output-hk/cardano-wallet/blob/24cd824fa3bb17a913e17756cb94a59b788de7c4/lib/core/src/Cardano/Wallet/Primitive/Migration/Selection.hs#L648) used in the [`Migration.Selection`](https://github.com/input-output-hk/cardano-wallet/blob/24cd824fa3bb17a913e17756cb94a59b788de7c4/lib/core/src/Cardano/Wallet/Primitive/Migration/Selection.hs) module:

- all post conditions are unified into a single post condition:
    ```>>> verifySelection cs ps s == SelectionCorrect```
- the comment for `performSelection` refers to this single post condition.

This pattern has the following advantages:
- we can avoid a violation of the [DRY principle](https://en.wikipedia.org/wiki/Don%27t_repeat_yourself): we only need to state the properties we expect of a `Selection` **in a single place**. (The alternative is to repeat these properties in both the comment for `performSelection` and within `CoinSelectionSpec` itself.)
- every failure condition has a record type that includes a detailed description of why the failure has occurred. 
- every failure condition is automatically pretty-printed by the test suite.

## Example Test Failure

![example-test-failure](https://user-images.githubusercontent.com/206319/136889194-c2f7b16e-b709-4d95-84c1-84ce26fe2aea.png)




Co-authored-by: Jonathan Knowles <jonathan.knowles@iohk.io>

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

@@ -38,6 +38,10 @@ module Cardano.Wallet.Primitive.CoinSelection
     , SelectionOutputSizeExceedsLimitError (..)
     , SelectionOutputTokenQuantityExceedsLimitError (..)
 
+    -- * Selection correctness
+    , SelectionCorrectness (..)
+    , verifySelection
+
     -- * Selection deltas
     , SelectionDelta (..)
     , selectionDelta
@@ -97,11 +101,13 @@ import Control.Monad.Trans.Except
 import Data.Function
     ( (&) )
 import Data.Generics.Internal.VL.Lens
-    ( over, set, view )
+    ( over, set, view, (^.) )
 import Data.Generics.Labels
     ()
 import Data.List.NonEmpty
     ( NonEmpty (..) )
+import Data.Maybe
+    ( isNothing )
 import Data.Ratio
     ( (%) )
 import Data.Semigroup
@@ -142,10 +148,9 @@ type PerformSelection m a =
 --
 -- This function guarantees that if it successfully creates a 'Selection' @s@,
 -- given a set of 'SelectionConstraints' @cs@ and 'SelectionParameters' @ps@,
--- then the following properties will hold:
+-- then the following property will hold:
 --
---    >>> selectionHasValidSurplus         cs ps s
---    >>> selectionHasSufficientCollateral cs ps s
+--    >>> verifySelection cs ps s == SelectionCorrect
 --
 performSelection
     :: (HasCallStack, MonadRandom m) => PerformSelection m Selection
@@ -338,6 +343,169 @@ toBalanceResult selection = Balance.SelectionResult
     , extraCoinSink = view #extraCoinSink selection
     }
 
+--------------------------------------------------------------------------------
+-- Selection correctness
+--------------------------------------------------------------------------------
+
+-- | Indicates whether or not a selection is correct.
+--
+data SelectionCorrectness
+    = SelectionCorrect
+    | SelectionIncorrect SelectionCorrectnessError
+    deriving (Eq, Show)
+
+-- | Indicates that a selection is incorrect.
+--
+data SelectionCorrectnessError
+    = SelectionCollateralInsufficient
+      SelectionCollateralInsufficientError
+    | SelectionCollateralUnsuitable
+      SelectionCollateralUnsuitableError
+    | SelectionDeltaInvalid
+      SelectionDeltaInvalidError
+    | SelectionLimitExceeded
+      SelectionLimitExceededError
+    deriving (Eq, Show)
+
+-- | The type of all selection property verification functions.
+--
+type VerifySelectionProperty error =
+    SelectionConstraints ->
+    SelectionParams ->
+    Selection ->
+    Maybe error
+
+-- | Verifies a selection for correctness.
+--
+-- This function is provided primarily as a convenience for testing. As such,
+-- it's not usually necessary to call this function from ordinary application
+-- code, unless you suspect that a selection is incorrect in some way.
+--
+verifySelection
+    :: SelectionConstraints
+    -> SelectionParams
+    -> Selection
+    -> SelectionCorrectness
+verifySelection cs ps selection =
+    either SelectionIncorrect (const SelectionCorrect) verifyAll
+  where
+    verifyAll :: Either SelectionCorrectnessError ()
+    verifyAll = do
+        verifySelectionCollateralSufficiency cs ps selection
+            `failWith` SelectionCollateralInsufficient
+        verifySelectionCollateralSuitability cs ps selection
+            `failWith` SelectionCollateralUnsuitable
+        verifySelectionDelta cs ps selection
+            `failWith` SelectionDeltaInvalid
+        verifySelectionLimit cs ps selection
+            `failWith` SelectionLimitExceeded
+
+    failWith :: Maybe e1 -> (e1 -> e2) -> Either e2 ()
+    onError `failWith` thisError = maybe (Right ()) (Left . thisError) onError
+
+--------------------------------------------------------------------------------
+-- Selection correctness: collateral sufficiency
+--------------------------------------------------------------------------------
+
+data SelectionCollateralInsufficientError = SelectionCollateralInsufficientError
+    { collateralSelected :: Coin
+    , collateralRequired :: Coin
+    }
+    deriving (Eq, Show)
+
+verifySelectionCollateralSufficiency
+    :: VerifySelectionProperty SelectionCollateralInsufficientError
+verifySelectionCollateralSufficiency cs ps selection
+    | collateralSelected >= collateralRequired =
+        Nothing
+    | otherwise =
+        Just SelectionCollateralInsufficientError
+            {collateralSelected, collateralRequired}
+  where
+    collateralSelected = selectionCollateral selection
+    collateralRequired = selectionMinimumCollateral cs ps selection
+
+--------------------------------------------------------------------------------
+-- Selection correctness: collateral suitability
+--------------------------------------------------------------------------------
+
+data SelectionCollateralUnsuitableError = SelectionCollateralUnsuitableError
+    { collateralSelected
+        :: [(TxIn, TxOut)]
+    , collateralSelectedButUnsuitable
+        :: [(TxIn, TxOut)]
+    }
+    deriving (Eq, Show)
+
+verifySelectionCollateralSuitability
+    :: VerifySelectionProperty SelectionCollateralUnsuitableError
+verifySelectionCollateralSuitability cs _ps selection
+    | null collateralSelectedButUnsuitable =
+        Nothing
+    | otherwise =
+        Just SelectionCollateralUnsuitableError
+            {collateralSelected, collateralSelectedButUnsuitable}
+  where
+    collateralSelected =
+        selection ^. #collateral
+    collateralSelectedButUnsuitable =
+        filter utxoUnsuitableForCollateral collateralSelected
+
+    utxoUnsuitableForCollateral :: (TxIn, TxOut) -> Bool
+    utxoUnsuitableForCollateral = isNothing . (cs ^. #utxoSuitableForCollateral)
+
+--------------------------------------------------------------------------------
+-- Selection correctness: delta validity
+--------------------------------------------------------------------------------
+
+data SelectionDeltaInvalidError = SelectionDeltaInvalidError
+    { delta
+        :: SelectionDelta TokenBundle
+    , minimumCost
+        :: Coin
+    }
+    deriving (Eq, Show)
+
+verifySelectionDelta
+    :: VerifySelectionProperty SelectionDeltaInvalidError
+verifySelectionDelta cs ps selection
+    | selectionHasValidSurplus cs ps selection =
+        Nothing
+    | otherwise =
+        Just SelectionDeltaInvalidError {..}
+  where
+    delta = selectionDeltaAllAssets selection
+    minimumCost = selectionMinimumCost cs ps selection
+
+--------------------------------------------------------------------------------
+-- Selection correctness: selection limit
+--------------------------------------------------------------------------------
+
+data SelectionLimitExceededError = SelectionLimitExceededError
+    { collateralInputCount
+        :: Int
+    , ordinaryInputCount
+        :: Int
+    , totalInputCount
+        :: Int
+    , selectionLimit
+        :: SelectionLimit
+    }
+    deriving (Eq, Show)
+
+verifySelectionLimit
+    :: VerifySelectionProperty SelectionLimitExceededError
+verifySelectionLimit cs _ps selection
+    | Balance.MaximumInputLimit totalInputCount <= selectionLimit =
+        Nothing
+    | otherwise =
+        Just SelectionLimitExceededError {..}
+  where
+    collateralInputCount = length (selection ^. #collateral)
+    ordinaryInputCount = length (selection ^. #inputs)
+    totalInputCount = collateralInputCount + ordinaryInputCount
+    selectionLimit = (cs ^. #computeSelectionLimit) (selection ^. #outputs)
+
 --------------------------------------------------------------------------------
 -- Selection deltas
 --------------------------------------------------------------------------------

lib/core/test/unit/Cardano/Wallet/Primitive/CoinSelectionSpec.hs

@@ -17,19 +17,15 @@ import Cardano.Wallet.Primitive.CoinSelection
     , Selection
     , SelectionCollateralRequirement (..)
     , SelectionConstraints (..)
+    , SelectionCorrectness (..)
     , SelectionError (..)
     , SelectionParams (..)
     , computeMinimumCollateral
     , performSelection
     , prepareOutputsWith
-    , selectionCollateral
     , selectionCollateralRequired
-    , selectionDeltaAllAssets
-    , selectionHasSufficientCollateral
-    , selectionHasValidSurplus
-    , selectionMinimumCollateral
-    , selectionMinimumCost
     , toBalanceConstraintsParams
+    , verifySelection
     )
 import Cardano.Wallet.Primitive.CoinSelection.Balance
     ( SelectionLimit, SelectionSkeleton )
@@ -85,8 +81,6 @@ import Data.Functor
     ( (<&>) )
 import Data.Generics.Internal.VL.Lens
     ( over, view, (^.) )
-import Data.Maybe
-    ( isJust )
 import GHC.Generics
     ( Generic )
 import Numeric.Natural
@@ -132,15 +126,8 @@ spec = describe "Cardano.Wallet.Primitive.CoinSelectionSpec" $ do
 
     parallel $ describe "Performing selections" $ do
 
-        it "prop_performSelection_onSuccess_hasValidSurplus" $
-            prop_performSelection_onSuccess
-            prop_performSelection_onSuccess_hasValidSurplus
-        it "prop_performSelection_onSuccess_hasSufficientCollateral" $
-            prop_performSelection_onSuccess
-            prop_performSelection_onSuccess_hasSufficientCollateral
-        it "prop_performSelection_onSuccess_hasSuitableCollateral" $
-            prop_performSelection_onSuccess
-            prop_performSelection_onSuccess_hasSuitableCollateral
+        it "prop_performSelection_onSuccess" $
+            property prop_performSelection_onSuccess
 
     parallel $ describe "Constructing balance constraints and parameters" $ do
 
@@ -179,12 +166,6 @@ type PerformSelectionPropertyInner =
     Either SelectionError Selection ->
     Property
 
-type PerformSelectionPropertyOnSuccess =
-    SelectionConstraints ->
-    SelectionParams ->
-    Selection ->
-    Property
-
 prop_performSelection_with
     :: PerformSelectionPropertyInner
     -> PerformSelectionProperty
@@ -234,41 +215,14 @@ prop_performSelection_coverage _constraints params result =
         SelectionOutputError _ -> True
         _ -> False
 
-prop_performSelection_onSuccess
-    :: PerformSelectionPropertyOnSuccess -> Property
-prop_performSelection_onSuccess onSuccess = property $
+prop_performSelection_onSuccess :: PerformSelectionProperty
+prop_performSelection_onSuccess =
     prop_performSelection_with $ \constraints params ->
         either (const $ property True) (onSuccess constraints params)
-
-prop_performSelection_onSuccess_hasValidSurplus
-    :: PerformSelectionPropertyOnSuccess
-prop_performSelection_onSuccess_hasValidSurplus cs ps selection =
-    report (selectionDeltaAllAssets selection)
-        "selectionDelta" $
-    report (selectionMinimumCost cs ps selection)
-        "selectionMinimumCost" $
-    selectionHasValidSurplus cs ps selection
-
-prop_performSelection_onSuccess_hasSufficientCollateral
-    :: PerformSelectionPropertyOnSuccess
-prop_performSelection_onSuccess_hasSufficientCollateral cs ps selection =
-    report (selectionCollateral selection)
-        "selection collateral" $
-    report (selectionMinimumCollateral cs ps selection)
-        "selection collateral minimum" $
-    report (selectionCollateralRequired ps)
-        "selection collateral required" $
-    selectionHasSufficientCollateral cs ps selection
-
-prop_performSelection_onSuccess_hasSuitableCollateral
-    :: PerformSelectionPropertyOnSuccess
-prop_performSelection_onSuccess_hasSuitableCollateral cs _ps selection =
-    report (view #collateral selection)
-        "selection collateral" $
-    property $ all suitableForCollateral (view #collateral selection)
   where
-    suitableForCollateral :: (TxIn, TxOut) -> Bool
-    suitableForCollateral = isJust . view #utxoSuitableForCollateral cs
+    onSuccess constraints params selection =
+        Pretty (verifySelection constraints params selection) ===
+        Pretty SelectionCorrect
 
 --------------------------------------------------------------------------------
 -- Construction of balance constraints and parameters