Enhance reporting of coin selections in the log.

lib/core/src/Cardano/Wallet.hs

@@ -279,9 +279,13 @@ import Cardano.Wallet.Primitive.AddressDiscovery.Shared
     )
 import Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobin
     ( SelectionError (..)
+    , SelectionReportDetailed
+    , SelectionReportSummarized
     , SelectionResult (..)
     , UnableToConstructChangeError (..)
     , emptySkeleton
+    , makeSelectionReportDetailed
+    , makeSelectionReportSummarized
     , performSelection
     )
 import Cardano.Wallet.Primitive.Migration
@@ -1439,14 +1443,21 @@ selectAssets ctx (utxo, cp, pending) tx outs transform = do
     liftIO $ traceWith tr $ MsgSelectionStart utxo outs
     selectionCriteria <- withExceptT ErrSelectAssetsCriteriaError $ except $
         initSelectionCriteria tl pp tx utxo outs
-    sel <- performSelection
+    mSel <- performSelection
         (view #txOutputMinimumAdaQuantity $ constraints tl pp)
         (calcMinimumCost tl pp tx)
         (tokenBundleSizeAssessor tl)
         (selectionCriteria)
-    liftIO $ traceWith tr $ MsgSelectionDone sel
+    case mSel of
+        Left e -> liftIO $
+            traceWith tr $ MsgSelectionError e
+        Right sel -> liftIO $ do
+            traceWith tr $ MsgSelectionReportSummarized
+                $ makeSelectionReportSummarized sel
+            traceWith tr $ MsgSelectionReportDetailed
+                $ makeSelectionReportDetailed sel
     withExceptT ErrSelectAssetsSelectionError $ except $
-        transform (getState cp) <$> sel
+        transform (getState cp) <$> mSel
   where
     nl = ctx ^. networkLayer
     tl = ctx ^. transactionLayer @k
@@ -2638,7 +2649,9 @@ data WalletFollowLog
 -- | Log messages from API server actions running in a wallet worker context.
 data WalletLog
     = MsgSelectionStart UTxOIndex (NonEmpty TxOut)
-    | MsgSelectionDone (Either SelectionError (SelectionResult TokenBundle))
+    | MsgSelectionError SelectionError
+    | MsgSelectionReportSummarized SelectionReportSummarized
+    | MsgSelectionReportDetailed SelectionReportDetailed
     | MsgMigrationUTxOBefore UTxOStatistics
     | MsgMigrationUTxOAfter UTxOStatistics
     | MsgRewardBalanceQuery BlockHeader
@@ -2684,10 +2697,12 @@ instance ToText WalletLog where
             "Starting coin selection " <>
             "|utxo| = "+|UTxOIndex.size utxo|+" " <>
             "#recipients = "+|NE.length recipients|+""
-        MsgSelectionDone (Left e) ->
-            "Failed to select assets: "+|| e ||+""
-        MsgSelectionDone (Right s) ->
-            "Assets selected successfully: "+| s |+""
+        MsgSelectionError e ->
+            "Failed to select assets:\n"+|| e ||+""
+        MsgSelectionReportSummarized s ->
+            "Selection report (summarized):\n"+| s |+""
+        MsgSelectionReportDetailed s ->
+            "Selection report (detailed):\n"+| s |+""
         MsgMigrationUTxOBefore summary ->
             "About to migrate the following distribution: \n" <> pretty summary
         MsgMigrationUTxOAfter summary ->
@@ -2726,7 +2741,9 @@ instance HasPrivacyAnnotation WalletLog
 instance HasSeverityAnnotation WalletLog where
     getSeverityAnnotation = \case
         MsgSelectionStart{} -> Debug
-        MsgSelectionDone{} -> Debug
+        MsgSelectionError{} -> Debug
+        MsgSelectionReportSummarized{} -> Info
+        MsgSelectionReportDetailed{} -> Debug
         MsgMigrationUTxOBefore _ -> Info
         MsgMigrationUTxOAfter _ -> Info
         MsgRewardBalanceQuery _ -> Debug

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

@@ -7,6 +7,7 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
 
@@ -37,6 +38,14 @@ module Cardano.Wallet.Primitive.CoinSelection.MA.RoundRobin
     , InsufficientMinCoinValueError (..)
     , UnableToConstructChangeError (..)
 
+    -- * Reporting
+    , SelectionReport (..)
+    , SelectionReportSummarized (..)
+    , SelectionReportDetailed (..)
+    , makeSelectionReport
+    , makeSelectionReportSummarized
+    , makeSelectionReportDetailed
+
     -- * Running a selection (without making change)
     , runSelection
     , SelectionState (..)
@@ -111,7 +120,7 @@ import Data.Function
 import Data.Functor.Identity
     ( Identity (..) )
 import Data.Generics.Internal.VL.Lens
-    ( view )
+    ( over, view )
 import Data.Generics.Labels
     ()
 import Data.List.NonEmpty
@@ -125,14 +134,7 @@ import Data.Ord
 import Data.Set
     ( Set )
 import Fmt
-    ( Buildable (..)
-    , Builder
-    , blockListF
-    , blockListF'
-    , nameF
-    , tupleF
-    , unlinesF
-    )
+    ( Buildable (..), genericF, nameF, unlinesF )
 import GHC.Generics
     ( Generic )
 import GHC.Stack
@@ -242,28 +244,6 @@ data SelectionResult change = SelectionResult
     }
     deriving (Generic, Eq, Show)
 
-instance Buildable (SelectionResult TokenBundle) where
-    build = buildSelectionResult (blockListF . fmap TokenBundle.Flat)
-
-instance Buildable (SelectionResult TxOut) where
-    build = buildSelectionResult (blockListF . fmap build)
-
-buildSelectionResult
-    :: ([change] -> Builder)
-    -> SelectionResult change
-    -> Builder
-buildSelectionResult changeF s@SelectionResult{inputsSelected,extraCoinSource} =
-    mconcat
-        [ nameF "inputs selected" (inputsF inputsSelected)
-        , nameF "extra coin input" (build extraCoinSource)
-        , nameF "outputs covered" (build $ outputsCovered s)
-        , nameF "change generated" (changeF $ changeGenerated s)
-        , nameF "size utxo remaining" (build $ UTxOIndex.size $ utxoRemaining s)
-        ]
-  where
-    inputsF :: NonEmpty (TxIn, TxOut) -> Builder
-    inputsF = blockListF' "+" tupleF
-
 -- | Calculate the actual difference between the total outputs (incl. change)
 -- and total inputs of a particular selection. By construction, this should be
 -- greater than total fees and deposits.
@@ -625,6 +605,125 @@ performSelection minCoinFor costFor bundleSizeAssessor criteria
         , "outputs: " <> show outputsToCover
         ]
 
+--------------------------------------------------------------------------------
+-- Reporting
+--------------------------------------------------------------------------------
+
+-- | Includes both summarized and detailed information about a selection.
+--
+data SelectionReport = SelectionReport
+    { summary :: SelectionReportSummarized
+    , detail :: SelectionReportDetailed
+    }
+    deriving (Eq, Generic, Show)
+
+-- | Includes summarized information about a selection.
+--
+-- Each data point can be serialized as a single line of text.
+--
+data SelectionReportSummarized = SelectionReportSummarized
+    { computedFee :: Coin
+    , totalAdaBalanceIn :: Coin
+    , totalAdaBalanceOut :: Coin
+    , adaBalanceOfSelectedInputs :: Coin
+    , adaBalanceOfExtraInput :: Coin
+    , adaBalanceOfRequestedOutputs :: Coin
+    , adaBalanceOfGeneratedChangeOutputs :: Coin
+    , numberOfSelectedInputs :: Int
+    , numberOfRequestedOutputs :: Int
+    , numberOfGeneratedChangeOutputs :: Int
+    , numberOfUniqueNonAdaAssetsInSelectedInputs :: Int
+    , numberOfUniqueNonAdaAssetsInRequestedOutputs :: Int
+    , numberOfUniqueNonAdaAssetsInGeneratedChangeOutputs :: Int
+    , sizeOfRemainingUtxoSet :: Int
+    }
+    deriving (Eq, Generic, Show)
+
+-- | Includes detailed information about a selection.
+--
+data SelectionReportDetailed = SelectionReportDetailed
+    { selectedInputs :: [(TxIn, TxOut)]
+    , requestedOutputs :: [TxOut]
+    , generatedChangeOutputs :: [TokenBundle.Flat TokenBundle]
+    }
+    deriving (Eq, Generic, Show)
+
+instance Buildable SelectionReport where
+    build = genericF
+instance Buildable SelectionReportSummarized where
+    build = genericF
+instance Buildable SelectionReportDetailed where
+    build = genericF
+
+makeSelectionReport
+    :: SelectionResult TokenBundle -> SelectionReport
+makeSelectionReport s = SelectionReport
+    { summary = makeSelectionReportSummarized s
+    , detail = makeSelectionReportDetailed s
+    }
+
+makeSelectionReportSummarized
+    :: SelectionResult TokenBundle -> SelectionReportSummarized
+makeSelectionReportSummarized s = SelectionReportSummarized {..}
+  where
+    computedFee
+        = Coin.distance totalAdaBalanceIn totalAdaBalanceOut
+    totalAdaBalanceIn
+        = adaBalanceOfSelectedInputs <> adaBalanceOfExtraInput
+    totalAdaBalanceOut
+        = adaBalanceOfGeneratedChangeOutputs <> adaBalanceOfRequestedOutputs
+    adaBalanceOfSelectedInputs
+        = F.foldMap (view (#tokens . #coin) . snd) $ view #inputsSelected s
+    adaBalanceOfExtraInput
+        = F.fold (view #extraCoinSource s)
+    adaBalanceOfGeneratedChangeOutputs
+        = F.foldMap (view #coin) $ view #changeGenerated s
+    adaBalanceOfRequestedOutputs
+        = F.foldMap (view (#tokens . #coin)) $ view #outputsCovered s
+    numberOfSelectedInputs
+        = length $ view #inputsSelected s
+    numberOfRequestedOutputs
+        = length $ view #outputsCovered s
+    numberOfGeneratedChangeOutputs
+        = length $ view #changeGenerated s
+    numberOfUniqueNonAdaAssetsInSelectedInputs
+        = Set.size
+        $ F.foldMap (TokenBundle.getAssets . view #tokens . snd)
+        $ view #inputsSelected s
+    numberOfUniqueNonAdaAssetsInRequestedOutputs
+        = Set.size
+        $ F.foldMap (TokenBundle.getAssets . view #tokens)
+        $ view #outputsCovered s
+    numberOfUniqueNonAdaAssetsInGeneratedChangeOutputs
+        = Set.size
+        $ F.foldMap TokenBundle.getAssets
+        $ view #changeGenerated s
+    sizeOfRemainingUtxoSet
+        = UTxOIndex.size $ utxoRemaining s
+
+makeSelectionReportDetailed
+    :: SelectionResult TokenBundle -> SelectionReportDetailed
+makeSelectionReportDetailed s = SelectionReportDetailed
+    { selectedInputs
+        = F.toList $ view #inputsSelected s
+    , requestedOutputs
+        = view #outputsCovered s
+    , generatedChangeOutputs
+        = TokenBundle.Flat <$> view #changeGenerated s
+    }
+
+-- A convenience instance for 'Buildable' contexts that include a nested
+-- 'SelectionResult' value.
+instance Buildable (SelectionResult TokenBundle) where
+    build = build . makeSelectionReport
+
+-- A convenience instance for 'Buildable' contexts that include a nested
+-- 'SelectionResult' value.
+instance Buildable (SelectionResult TxOut) where
+    build = build
+        . makeSelectionReport
+        . over #changeGenerated (fmap $ view #tokens)
+
 --------------------------------------------------------------------------------
 -- Running a selection (without making change)
 --------------------------------------------------------------------------------