Merge pull request #120 from mlabs-haskell/sam/preserve-budget-order

Preserve output order

Author: samuelWilliams99

src/BotPlutusInterface/Balance.hs

@@ -26,7 +26,7 @@ import Control.Monad.Trans.Either (EitherT, hoistEither, newEitherT, runEitherT)
 import Data.Coerce (coerce)
 import Data.Either.Combinators (rightToMaybe)
 import Data.Kind (Type)
-import Data.List (partition, (\\))
+import Data.List ((\\))
 import Data.Map (Map)
 import Data.Map qualified as Map
 import Data.Maybe (fromMaybe, mapMaybe)
@@ -311,17 +311,17 @@ addTxCollaterals utxos tx =
 handleNonAdaChange :: Address -> Map TxOutRef TxOut -> Tx -> Either Text Tx
 handleNonAdaChange changeAddr utxos tx =
   let nonAdaChange = getNonAdaChange utxos tx
+      newOutput =
+        TxOut
+          { txOutAddress = changeAddr
+          , txOutValue = nonAdaChange
+          , txOutDatumHash = Nothing
+          }
       outputs =
-        case partition ((==) changeAddr . Tx.txOutAddress) $ txOutputs tx of
-          ([], txOuts) ->
-            TxOut
-              { txOutAddress = changeAddr
-              , txOutValue = nonAdaChange
-              , txOutDatumHash = Nothing
-              } :
-            txOuts
-          (txOut@TxOut {txOutValue = v} : txOuts, txOuts') ->
-            txOut {txOutValue = v <> nonAdaChange} : (txOuts <> txOuts')
+        modifyFirst
+          ((==) changeAddr . Tx.txOutAddress)
+          (Just . maybe newOutput (addValueToTxOut nonAdaChange))
+          (txOutputs tx)
    in if isValueNat nonAdaChange
         then Right $ if Value.isZero nonAdaChange then tx else tx {txOutputs = outputs}
         else Left "Not enough inputs to balance tokens."
@@ -332,18 +332,40 @@ hasChangeUTxO changeAddr tx =
 
 -- | Adds ada change to a transaction, assuming there is already an output going to ownPkh. Otherwise, this is identity
 addAdaChange :: Address -> Integer -> Tx -> Tx
+addAdaChange _ 0 tx = tx
 addAdaChange changeAddr change tx =
   tx
     { txOutputs =
-        case partition ((==) changeAddr . Tx.txOutAddress) $ txOutputs tx of
-          (txOut@TxOut {txOutValue = v} : txOuts, txOuts') ->
-            txOut {txOutValue = v <> Ada.lovelaceValueOf change} : (txOuts <> txOuts')
-          _ -> txOutputs tx
+        modifyFirst
+          ((==) changeAddr . Tx.txOutAddress)
+          (fmap $ addValueToTxOut $ Ada.lovelaceValueOf change)
+          (txOutputs tx)
     }
 
+consJust :: forall (a :: Type). Maybe a -> [a] -> [a]
+consJust (Just x) = (x :)
+consJust _ = id
+
+{- | Modifies the first element matching a predicate, or, if none found, call the modifier with Nothing
+ Calling this function ensures the modifier will always be run once
+-}
+modifyFirst ::
+  forall (a :: Type).
+  -- | Predicate for value to update
+  (a -> Bool) ->
+  -- | Modifier, input Maybe representing existing value (or Nothing if missing), output value representing new value (or Nothing to remove)
+  (Maybe a -> Maybe a) ->
+  [a] ->
+  [a]
+modifyFirst _ m [] = m Nothing `consJust` []
+modifyFirst p m (x : xs) = if p x then m (Just x) `consJust` xs else x : modifyFirst p m xs
+
+addValueToTxOut :: Value -> TxOut -> TxOut
+addValueToTxOut val txOut = txOut {txOutValue = txOutValue txOut <> val}
+
 -- | Adds a 1 lovelace output to a transaction
 addOutput :: Address -> Tx -> Tx
-addOutput changeAddr tx = tx {txOutputs = changeTxOut : txOutputs tx}
+addOutput changeAddr tx = tx {txOutputs = txOutputs tx ++ [changeTxOut]}
   where
     changeTxOut =
       TxOut

test/Spec/BotPlutusInterface/Contract.hs

@@ -156,8 +156,8 @@ sendAda = do
         , [text|
           cardano-cli transaction build-raw --alonzo-era
           --tx-in ${inTxId}#0
-          --tx-out ${addr1}+50
           --tx-out ${addr2}+1000
+          --tx-out ${addr1}+50
           --required-signer ./signing-keys/signing-key-${pkh1'}.skey
           --fee 300
           --protocol-params-file ./protocol.json --out-file ./txs/tx-?.raw
@@ -411,8 +411,8 @@ sendTokens = do
         , [text|
           cardano-cli transaction build-raw --alonzo-era
           --tx-in ${inTxId1}#0
-          --tx-out ${addr1}+50 + 95 abcd1234.74657374546F6B656E
           --tx-out ${addr2}+1000 + 5 abcd1234.74657374546F6B656E
+          --tx-out ${addr1}+50 + 95 abcd1234.74657374546F6B656E
           --required-signer ./signing-keys/signing-key-${pkh1'}.skey
           --fee 300
           --protocol-params-file ./protocol.json --out-file ./txs/tx-?.raw
@@ -453,8 +453,8 @@ sendTokensWithoutName = do
         , [text|
           cardano-cli transaction build-raw --alonzo-era
           --tx-in ${inTxId1}#0
-          --tx-out ${addr1}+50 + 95 abcd1234
           --tx-out ${addr2}+1000 + 5 abcd1234
+          --tx-out ${addr1}+50 + 95 abcd1234
           --required-signer ./signing-keys/signing-key-${pkh1'}.skey
           --fee 300
           --protocol-params-file ./protocol.json --out-file ./txs/tx-?.raw
@@ -520,8 +520,8 @@ mintTokens = do
           cardano-cli transaction build-raw --alonzo-era
           --tx-in ${inTxId}#0
           --tx-in-collateral ${inTxId}#0
-          --tx-out ${addr1}+496700
           --tx-out ${addr2}+1000 + 5 ${curSymbol'}.74657374546F6B656E
+          --tx-out ${addr1}+496700
           --mint-script-file ./result-scripts/policy-${curSymbol'}.plutus
           --mint-redeemer-file ./result-scripts/redeemer-${redeemerHash}.json
           --mint-execution-units (500000,2000)
@@ -609,9 +609,9 @@ spendToValidator = do
         , [text|
           cardano-cli transaction build-raw --alonzo-era
           --tx-in ${inTxId}#0
-          --tx-out ${addr1}+200
           --tx-out ${valAddr'}+500
           --tx-out-datum-embed-file ./result-scripts/datum-${datumHash'}.json
+          --tx-out ${addr1}+200
           --required-signer ./signing-keys/signing-key-${pkh1'}.skey
           --fee 300
           --protocol-params-file ./protocol.json --out-file ./txs/tx-?.raw
@@ -707,8 +707,8 @@ redeemFromValidator = do
           --tx-in-redeemer-file ./result-scripts/redeemer-${redeemerHash}.json
           --tx-in-execution-units (500000,2000)
           --tx-in-collateral ${inTxId}#0
-          --tx-out ${addr1}+498350
           --tx-out ${addr2}+500
+          --tx-out ${addr1}+498350
           --required-signer ./signing-keys/signing-key-${pkh1'}.skey
           --fee 502400
           --protocol-params-file ./protocol.json --out-file ./txs/tx-?.raw