wip: re-write balanceTransaction

now:

Cardano.Wallet.Shelley.Transaction
  balanceTransaction
    produces balanced transactions or fails (49835ms)
      +++ OK, passed 5000 tests:
       1.18% fee above 1 ada

      52.54% missing tokens
      12.86% not yet supported: zero ada output
      10.96% success
       9.68% missing coin and tokens
       4.90% not yet supported: conflicting networks
       3.54% outputs below minCoinValue
       3.32% missing coin
       1.12% unable to construct change
       0.86% existing collateral
       0.20% selection limit reached
       0.02% not yet supported: too small change

lib/core/src/Cardano/Api/Gen.hs

@@ -489,8 +489,8 @@ genNetworkMagic = do
 genNetworkId :: Gen NetworkId
 genNetworkId =
     frequency
-        [ (95, pure Mainnet)
-        , (5, Testnet <$> genNetworkMagic)
+        [ (99, pure Mainnet)
+        , (1, Testnet <$> genNetworkMagic)
         ]
 
 genStakeCredential :: Gen StakeCredential

lib/core/src/Cardano/Wallet/Api/Server.hs

@@ -3805,7 +3805,7 @@ instance IsServerError ErrBalanceTx where
             apiError err500 CreatedInvalidTransaction $ mconcat
                 [ "Deposits/refunds are not yet supported for balancing."
                 ]
-        ErrBalanceTxNotYetSupported (UnderestimatedFee _) ->
+        ErrBalanceTxNotYetSupported (UnderestimatedFee _ _) ->
             apiError err500 CreatedInvalidTransaction $ mconcat
                 [ "What was supposed to be an initial overestimation of fees "
                 , "turned out to be an underestimation, and I cannot recover. "

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

@@ -206,6 +206,10 @@ data SelectionParams = SelectionParams
     , assetsToMint
         :: !TokenMap
         -- ^ Specifies a set of assets to mint.
+    , extraCoinIn
+        :: !Coin
+    , extraCoinOut
+        :: !Coin
     , outputsToCover
         :: ![TxOut]
         -- ^ Specifies a set of outputs that must be paid for.
@@ -440,11 +444,11 @@ toBalanceConstraintsParams (constraints, params) =
         , assetsToMint =
             view #assetsToMint params
         , extraCoinSource =
-            view #rewardWithdrawal params <>
+            view #rewardWithdrawal params <> view #extraCoinIn params <>
             mtimesDefault
                 (view #certificateDepositsReturned params)
                 (view #certificateDepositAmount constraints)
-        , extraCoinSink =
+        , extraCoinSink = view #extraCoinOut params <>
             mtimesDefault
                 (view #certificateDepositsTaken params)
                 (view #certificateDepositAmount constraints)

lib/core/src/Cardano/Wallet/Transaction.hs

@@ -72,13 +72,16 @@ import Cardano.Wallet.Primitive.Types.RewardAccount
 import Cardano.Wallet.Primitive.Types.TokenMap
     ( TokenMap )
 import Cardano.Wallet.Primitive.Types.Tx
-    ( TokenBundleSizeAssessor
+    ( SealedTx
+    , TokenBundleSizeAssessor
     , Tx (..)
     , TxConstraints
     , TxIn
     , TxMetadata
     , TxOut
     )
+import Cardano.Wallet.Primitive.Types.UTxO
+    ( UTxO )
 import Data.List.NonEmpty
     ( NonEmpty )
 import Data.Text
@@ -185,6 +188,17 @@ data TransactionLayer k tx = TransactionLayer
         --
         -- Returns `Nothing` for ByronEra transactions.
 
+    , toCardanoUTxO
+        :: [(TxIn, TxOut)] -> Node.UTxO Node.AlonzoEra
+        -- for balanceTransaction
+
+    , evaluateTransactionBalance
+        :: SealedTx
+        -> Bool -- ^ If true, set fee to zero
+        -> Node.ProtocolParameters
+        -> UTxO
+        -> Node.Value
+
     , computeSelectionLimit
         :: ProtocolParameters
         -> TransactionCtx
@@ -244,6 +258,60 @@ data TxUpdate = TxUpdate
         -- ^ Set a new fee or use the old one.
     }
 
+{-
+
+-- | "Balance Tx" Monad
+data BTX a
+
+instance Monad BTX
+
+
+-- Wrong but useful assumptions:
+-- 1. Execution cost
+-- 2. changing coin values
+
+addInputs :: [(TxIn, TxOut)] -> BTX ()
+addInputs = error "todo"
+
+addCollateral :: [(TxIn, TxOut)] -> BTX ()
+addCollateral = error "todo"
+
+addOutputs :: [TxOut] -> BTX ()
+addOutputs = error "todo"
+
+evaluateMinFee :: BTX Coin
+evaluateMinFee = error "todo"
+
+-- TODO: Can be negative
+evaluateBalance :: BTX Coin
+evaluateBalance = error "todo"
+
+-- WARNING: Setting the fee may change the minimum fee
+setFee :: Coin -> BTX Coin
+setFee = error "todo"
+
+-- | TODO: Ensure this goes to the first /wallet/ output.
+--
+-- WARNING: Distributing surplus may change the minimum fee.
+distributeSurplus :: Coin -> BTX ()
+distributeSurplus = error "todo"
+
+
+-- NOTE1: A naive "evaluateBalance >>= distributeSurplus" until balanced may not
+-- necessarily work. We may get stuck in a loop.
+distributeSurplus' :: Coin -> BTX Coin
+distributeSurplus' = do
+    surplus <- evaluateBalance
+
+
+
+-}
+
+
+
+
+
+
 -- | Some additional context about a transaction. This typically contains
 -- details that are known upfront about the transaction and are used to
 -- construct it from inputs selected from the wallet's UTxO.

lib/shelley/src/Cardano/Wallet/Shelley/Compatibility.hs

@@ -79,6 +79,7 @@ module Cardano.Wallet.Shelley.Compatibility
     , toCardanoValue
     , fromCardanoValue
     , fromCardanoLovelace
+    , posAndNegFromCardanoValue
     , rewardAccountFromAddress
     , fromShelleyPParams
     , fromAlonzoPParams
@@ -365,6 +366,8 @@ import qualified Data.Array as Array
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.ByteString.Short as SBS
+import Data.Either
+    ( lefts, rights )
 import qualified Data.Map.Strict as Map
 import qualified Data.Map.Strict.NonEmptyMap as NonEmptyMap
 import qualified Data.Set as Set
@@ -1562,6 +1565,41 @@ fromCardanoValue = uncurry TokenBundle.fromFlatList . extract
     mkPolicyId = W.UnsafeTokenPolicyId . W.Hash . Cardano.serialiseToRawBytes
     mkTokenName = W.UnsafeTokenName . Cardano.serialiseToRawBytes
 
+-- | Convert a 'Cardano.Value' into a positive and negative component. Useful
+-- to convert the potentially negative balance of a partial tx into
+-- TokenBundles.
+posAndNegFromCardanoValue
+    :: HasCallStack
+    => Cardano.Value
+    -> (TokenBundle.TokenBundle, TokenBundle.TokenBundle)
+posAndNegFromCardanoValue = foldMap go . Cardano.valueToList
+  where
+    go :: (Cardano.AssetId, Cardano.Quantity)
+       -> (TokenBundle.TokenBundle, TokenBundle.TokenBundle)
+    go (Cardano.AdaAssetId, q) = partition q $
+        TokenBundle.fromCoin . Coin.fromNatural
+    go ((Cardano.AssetId policy name), q) = partition q $ \n ->
+        TokenBundle.fromFlatList (W.Coin 0)
+            [ ( TokenBundle.AssetId (mkPolicyId policy) (mkTokenName name)
+              , W.TokenQuantity n
+              )
+            ]
+
+    -- | Convert a 'Cardano.Quantity' to a 'TokenBundle' using the supplied
+    -- function. The result is stored in 'fst' for positive quantities, and
+    -- 'snd' for negative quantities.
+    partition
+        :: Cardano.Quantity
+        -> (Natural -> TokenBundle.TokenBundle)
+        -> (TokenBundle.TokenBundle, TokenBundle.TokenBundle)
+    partition (Cardano.Quantity q) f
+        | q > 0     = (f $ fromIntegral q, mempty)
+        | q < 0     = (mempty, f $ fromIntegral $ abs q)
+        | otherwise = (mempty, mempty)
+
+    mkPolicyId = W.UnsafeTokenPolicyId . W.Hash . Cardano.serialiseToRawBytes
+    mkTokenName = W.UnsafeTokenName . Cardano.serialiseToRawBytes
+
 fromShelleyWdrl :: SL.Wdrl crypto -> Map W.RewardAccount W.Coin
 fromShelleyWdrl (SL.Wdrl wdrl) = Map.fromList $
     bimap (fromStakeCredential . SL.getRwdCred) fromShelleyCoin

lib/shelley/src/Cardano/Wallet/Shelley/Transaction.hs

@@ -135,6 +135,8 @@ import Cardano.Wallet.Primitive.Types.Tx
     , txOutCoin
     , txSizeDistance
     )
+import Cardano.Wallet.Primitive.Types.UTxO
+    ( UTxO (..) )
 import Cardano.Wallet.Shelley.Compatibility
     ( fromCardanoAddress
     , fromCardanoLovelace
@@ -198,7 +200,7 @@ import Data.Kind
 import Data.Map.Strict
     ( Map, (!) )
 import Data.Maybe
-    ( mapMaybe )
+    ( fromMaybe, mapMaybe )
 import Data.Quantity
     ( Quantity (..) )
 import Data.Set
@@ -238,6 +240,8 @@ import qualified Cardano.Wallet.Primitive.Types.TokenMap as TokenMap
 import qualified Cardano.Wallet.Shelley.Compatibility as Compatibility
 import qualified Codec.CBOR.Encoding as CBOR
 import qualified Codec.CBOR.Write as CBOR
+import Data.Bifunctor
+    ( bimap )
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.Foldable as F
@@ -515,6 +519,11 @@ newTransactionLayer networkId = TransactionLayer
             InAnyCardanoEra AlonzoEra (Cardano.Tx body wits) ->
                 signTransaction networkId acctResolver addressResolver inputResolver (body, wits)
                 & sealedTxFromCardano'
+    , toCardanoUTxO = Cardano.UTxO
+        . Map.fromList
+        . map (bimap toCardanoTxIn (toCardanoTxOut Cardano.ShelleyBasedEraAlonzo))
+
+    , evaluateTransactionBalance= _evaluateTransactionBalance
 
     , mkUnsignedTransaction = \era stakeXPub _pp ctx selection -> do
         let ttl   = txTimeToLive ctx
@@ -567,6 +576,41 @@ newTransactionLayer networkId = TransactionLayer
 _decodeSealedTx :: SealedTx -> (Tx, TokenMap, TokenMap, [Certificate])
 _decodeSealedTx (cardanoTx -> InAnyCardanoEra _era tx) = fromCardanoTx tx
 
+_evaluateTransactionBalance
+    :: SealedTx -> Bool -> Cardano.ProtocolParameters -> UTxO -> Cardano.Value
+_evaluateTransactionBalance tx shouldZero pp u = withAlonzoBod (if shouldZero then tx' else tx) $ \bod ->
+        lovelaceFromCardanoTxOutValue
+        $ Cardano.evaluateTransactionBalance pp mempty u' bod
+  where
+    u' =  Cardano.UTxO
+        . Map.fromList
+        . map (bimap toCardanoTxIn (toCardanoTxOut Cardano.ShelleyBasedEraAlonzo))
+        . Map.toList
+        . unUTxO
+        $ u
+    -- FIXME: Duplication with TxLayer ^^^
+
+
+    -- FIXME: Unsafe vvv
+    Right tx' = updateSealedTx tx $ noTxUpdate
+        { feeUpdate = UseNewTxFee $ fromMaybe (Coin 0) $ _evaluateMinimumFee pp tx
+        }
+
+    lovelaceFromCardanoTxOutValue
+        :: forall era. Cardano.TxOutValue era -> Cardano.Value
+    lovelaceFromCardanoTxOutValue (Cardano.TxOutAdaOnly _ coin) = error "no"
+    lovelaceFromCardanoTxOutValue (Cardano.TxOutValue _ val) = val
+
+    withAlonzoBod
+        :: SealedTx
+        -> (Cardano.TxBody Cardano.AlonzoEra -> a)
+        -> a
+    withAlonzoBod (cardanoTx -> Cardano.InAnyCardanoEra Cardano.AlonzoEra tx) f =
+        let Cardano.Tx bod _ = tx
+        in f bod
+    withAlonzoBod _ _ = error "withBod: other eras are not handled yet"
+
+
 mkDelegationCertificates
     :: DelegationAction
         -- Pool Id to which we're planning to delegate