generate arbitrary selection with reserve, add more classification an…

…d assertions to properties

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

@@ -213,7 +213,13 @@ coverRemainingFee (Fee fee) = go [] where
 -- change outputs if any are left, or the remaining fee otherwise
 --
 -- We divvy up the fee over all change outputs proportionally, to try and keep
--- any output:change ratio as unchanged as possible
+-- any output:change ratio as unchanged as possible.
+--
+-- This function either consumes an existing reserve on a selection, or turn it
+-- into a change output. Therefore, the resulting coin selection _will_ not have
+-- any reserve. Note that the reserve will be either 'Nothing', to indicate that
+-- there was no reserve at all, or 'Just 0' to indicate that there was a
+-- reserve, but it has been consumed entirely.
 rebalanceSelection
     :: FeeOptions
     -> CoinSelection
@@ -223,16 +229,16 @@ rebalanceSelection opts s
     | φ_original == δ_original =
         (s, Fee 0)
 
-    -- some fee left to pay, and the reserve is enough to pay for fee, use it.
-    | φ_original > δ_original && reserve s >= Just (Coin 0) =
+    -- some fee left to pay, and the reserve is non-empty, use it first.
+    | φ_original > δ_original && reserve s > Just (Coin 0) =
         let
             -- Safe because of the above guard.
             Just (Coin r) = reserve s
-            (remFee, r') = if r > φ_original
-                then (Fee 0, Coin (r - φ_original))
-                else (Fee (φ_original - r), Coin 0)
+            r' = if r > φ_original
+                then Coin (r - φ_original)
+                else Coin 0
         in
-            (s { reserve = (const r') <$> reserve s }, remFee)
+            rebalanceSelection opts (s { reserve = Just r' })
 
     -- some fee left to pay, but we've depleted all change outputs
     | φ_original > δ_original && null (change s) =
@@ -277,7 +283,10 @@ rebalanceSelection opts s
     δ_dangling = φ_original -- by construction of the change output
 
     extraChng = Coin (δ_original - φ_original)
-    sDangling = s { change = splitChange extraChng (change s) }
+    sDangling = s
+        { change = splitChange extraChng (change s)
+        , reserve = Coin 0 <$ reserve s
+        }
 
 -- | Reduce single change output by a given fee amount. If fees are too big for
 -- a single coin, returns a `Coin 0`.

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

@@ -52,6 +52,8 @@ import Data.Functor.Identity
     ( Identity (runIdentity) )
 import Data.List.NonEmpty
     ( NonEmpty )
+import Data.Maybe
+    ( isNothing )
 import Data.Word
     ( Word64 )
 import Fmt
@@ -65,13 +67,17 @@ import Test.QuickCheck
     , Property
     , checkCoverage
     , choose
+    , classify
+    , conjoin
     , counterexample
     , coverTable
     , disjoin
     , elements
     , expectFailure
     , forAllBlind
+    , frequency
     , generate
+    , oneof
     , property
     , scale
     , tabulate
@@ -407,15 +413,15 @@ propReducedChanges
     -> ShowFmt FeeProp
     -> Property
 propReducedChanges drg (ShowFmt (FeeProp coinSel utxo (fee, dust))) = do
-    isRight coinSel' ==> let Right s = coinSel' in prop s
+    withMaxSuccess 1000 $ isRight coinSel' ==> let Right s = coinSel' in prop s
   where
     prop s = do
         let chgs' = sum $ map getCoin $ change s
         let chgs = sum $ map getCoin $ change coinSel
         let inps' = CS.inputs s
         let inps = CS.inputs coinSel
-        disjoin
-            [ chgs' `shouldSatisfy` (<= chgs)
+        classify (reserve coinSel > Just (Coin fee)) "reserve > fee" $ disjoin
+            [ chgs' `shouldSatisfy` (< chgs)
             , length inps' `shouldSatisfy` (>= length inps)
             ]
     feeOpt = feeOptions fee dust
@@ -495,19 +501,34 @@ prop_rebalanceSelection
     -> Property
 prop_rebalanceSelection sel onDangling = do
     let (sel', fee') = rebalanceSelection opts sel
-    let prop = case onDangling of
+    let selectionIsBalanced = case onDangling of
             PayAndBalance ->
                 fee' /= Fee 0 || Fee (delta sel') == estimateFee opts sel'
             SaveMoney ->
                 fee' /= Fee 0 || Fee (delta sel') >= estimateFee opts sel'
-    property prop
+    let reserveIsEmpty =
+            case reserve sel of
+                Nothing -> isNothing (reserve sel')
+                Just{}  -> reserve sel' == Just (Coin 0)
+    conjoin
+        [ property selectionIsBalanced
+        , property reserveIsEmpty
+        ]
         & counterexample (unlines
             [ "selection (before):", pretty sel
             , "selection (after):", pretty sel'
             , "delta (before): " <> show (delta sel)
             , "delta (after):  " <> show (delta sel')
             , "remaining fee:  " <> show (getFee fee')
             ])
+        & classify (reserveNonNull && feeLargerThanDelta)
+            "reserve > 0 && fee > delta"
+        & classify (reserveLargerThanFee && feeLargerThanDelta)
+            "reserve > fee && fee > delta"
+        & classify reserveLargerThanFee
+            "reserve > fee"
+        & classify feeLargerThanDelta
+            "fee > delta"
   where
     delta s = inputBalance s - (outputBalance s + changeBalance s)
     opts = FeeOptions
@@ -523,6 +544,13 @@ prop_rebalanceSelection sel onDangling = do
         , onDanglingChange = onDangling
         }
 
+    reserveNonNull =
+        reserve sel > Just (Coin 0)
+    reserveLargerThanFee =
+        reserve sel > Just (Coin $ getFee $ estimateFee opts sel)
+    feeLargerThanDelta =
+        getFee (estimateFee opts sel) > delta sel
+
 {-------------------------------------------------------------------------------
                          Fee Adjustment - Unit Tests
 -------------------------------------------------------------------------------}
@@ -627,9 +655,17 @@ genSelectionFor :: NonEmpty TxOut -> Gen CoinSelection
 genSelectionFor outs = do
     let opts = CS.CoinSelectionOptions (const 100) (const $ pure ())
     utxo <- vector (NE.length outs * 3) >>= genUTxO
+    rsv <- frequency
+        [ (3, pure Nothing)
+        , (1, Just . Coin <$> oneof
+            [ choose (1, 10000)
+            , choose (500000, 1000000)
+            ]
+          )
+        ]
     case runIdentity $ runExceptT $ largestFirst opts outs utxo of
         Left _ -> genSelectionFor outs
-        Right (s,_) -> return s
+        Right (s,_) -> pure $ s { reserve = rsv }
 
 instance Arbitrary TxIn where
     shrink _ = []