Started work on proper test for utxo change.

Completely replaced former test, haven't yet finished new test.

Author: Anteproperispomenon

test/Spec/BotPlutusInterface/Balance.hs

@@ -6,22 +6,42 @@ module Spec.BotPlutusInterface.Balance (tests) where
 import BotPlutusInterface.Balance (balanceTxIO, defaultBalanceConfig, withFee)
 import BotPlutusInterface.Balance qualified as Balance
 import BotPlutusInterface.Effects (PABEffect)
+import BotPlutusInterface.Types (
+  ContractEnvironment (cePABConfig),
+  PABConfig (pcOwnPubKeyHash, pcProtocolParams),
+ )
+import Control.Lens ((&), (.~), (^.))
 import Data.Default (Default (def))
 import Data.Map qualified as Map
 import Data.Set qualified as Set
 import Data.Text qualified as Text
+import Data.Void (Void)
 import Ledger qualified
 import Ledger.Ada qualified as Ada
 import Ledger.Address (Address, PaymentPubKeyHash (PaymentPubKeyHash))
 import Ledger.Address qualified as Address
 import Ledger.CardanoWallet qualified as Wallet
+import Ledger.Constraints qualified as Constraints
 import Ledger.Crypto (PubKeyHash)
 import Ledger.Scripts qualified as Scripts
-import Ledger.Tx (Tx (..), TxIn (..), TxInType (..), TxOut (..), TxOutRef (..))
+import Ledger.Tx (
+  ChainIndexTxOut (..),
+  Tx (..),
+  TxIn (..),
+  TxInType (..),
+  TxOut (..),
+  TxOutRef (..),
+ )
 import Ledger.Value qualified as Value
 import Plutus.V1.Ledger.Api qualified as Api
 import PlutusTx qualified
-import Spec.MockContract (runPABEffectPure)
+import Spec.MockContract (
+  MockContractState,
+  contractEnv,
+  runContractPure,
+  runPABEffectPure,
+  utxos,
+ )
 import Test.Tasty (TestTree, testGroup)
 import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=))
 import Prelude
@@ -45,7 +65,7 @@ validator =
     $$(PlutusTx.compile [||(\_ _ _ -> ())||])
 
 valHash :: Ledger.ValidatorHash
-(Just valHash) = Ledger.toValidatorHash addr3
+valHash = Scripts.validatorHash validator
 
 pkh1, pkh2 :: PubKeyHash
 pkh1 = Address.unPaymentPubKeyHash . Wallet.paymentPubKeyHash $ Wallet.knownMockWallet 1
@@ -72,15 +92,24 @@ txIn3 = TxIn txOutRef3 (Just ConsumePublicKeyAddress)
 txIn4 = TxIn txOutRef4 (Just ConsumePublicKeyAddress)
 txIn5 = TxIn txOutRef5 (Just ConsumeSimpleScriptAddress)
 
-utxo1, utxo2, utxo3, utxo4, utxo5, utxo6, utxo7 :: (TxOutRef, TxOut)
+utxo1, utxo2, utxo3, utxo4, utxo7 :: (TxOutRef, TxOut)
 utxo1 = (txOutRef1, TxOut addr1 (Ada.lovelaceValueOf 1_100_000) Nothing)
 utxo2 = (txOutRef2, TxOut addr1 (Ada.lovelaceValueOf 1_000_000) Nothing)
 utxo3 = (txOutRef3, TxOut addr1 (Ada.lovelaceValueOf 900_000) Nothing)
 utxo4 = (txOutRef4, TxOut addr1 (Ada.lovelaceValueOf 800_000 <> Value.singleton "11223344" "Token" 200) Nothing)
-utxo5 = (txOutRef5, TxOut addr3 (Ada.lovelaceValueOf 900_000) (Just $ Ledger.DatumHash ""))
-utxo6 = (txOutRef6, TxOut addr3 (Value.singleton "11223344" "Token" 200) Nothing)
+-- utxo5 = (txOutRef5, TxOut addr3 (Ada.lovelaceValueOf 900_000) (Just $ Ledger.DatumHash ""))
+-- utxo6 = (txOutRef6, TxOut addr3 (Value.singleton "11223344" "Token" 200) Nothing)
 utxo7 = (txOutRef2, TxOut addr1 (Ada.lovelaceValueOf 5_000_000) Nothing)
 
+scrValue :: Value.Value
+scrValue = (Value.singleton "11223344" "Token" 200) <> (Ada.lovelaceValueOf 500_000)
+
+scrDatum :: Ledger.Datum
+scrDatum = Ledger.Datum $ Api.toBuiltinData (23 :: Integer)
+
+scrDatumHash :: Ledger.DatumHash
+scrDatumHash = Ledger.datumHash scrDatum
+
 addUtxosForFees :: Assertion
 addUtxosForFees = do
   let txout = TxOut addr2 (Ada.lovelaceValueOf 1_000_000) Nothing
@@ -131,31 +160,40 @@ addUtxosForChange = do
 
 dontAddChangeToDatum :: Assertion
 dontAddChangeToDatum = do
-  let txout = TxOut addr2 (Ada.lovelaceValueOf 1_300_000) Nothing
-      txout2 = snd utxo5
-      txout3 = snd utxo6
-      tx = mempty {txOutputs = [txout, txout2, txout3]} `withFee` 500_000
-      minUtxo = [(txout, 1_000_000), (txout3, 1_100_000)] -- add change to these utxos
-      utxoIndex = Map.fromList [utxo5, utxo3, utxo1, utxo4, utxo7]
-      ownAddr = addr1
-      ebalancedTx =
-        fst $
-          runPABEffectPure def $
-            Balance.balanceTxStep @() @'[PABEffect ()] defaultBalanceConfig minUtxo utxoIndex ownAddr tx
-
-  case ebalancedTx of
-    Left e -> assertFailure (Text.unpack e)
-    Right (Left e) -> assertFailure (Text.unpack e)
-    Right (Right balancedTx) ->
-      assertBool
-        ( "Original UTxO not in output;\n"
-            <> "TxOuts: "
-            <> show (txOutputs balancedTx)
-            <> "\n"
-            <> "TxIns : "
-            <> show (txInputs balancedTx)
-            <> "\n"
-        )
-        $ snd utxo5 `elem` txOutputs balancedTx
-
--- txIn5 `Set.member` (txInputs balancedTx)
+  let scrTxOut' =
+        ScriptChainIndexTxOut
+          addr3
+          (Right validator) -- (valHash, Just validator)
+          (Right scrDatum) -- (scrDatumHash, Just scrDatum)
+          scrValue
+      scrTxOut = Ledger.toTxOut scrTxOut'
+      usrTxOut' =
+        PublicKeyChainIndexTxOut
+          addr1
+          (Ada.lovelaceValueOf 5_000_000)
+      usrTxOut = Ledger.toTxOut usrTxOut'
+      -- initState :: MockContractState ()
+      initState =
+        def & utxos .~ [(txOutRef6, scrTxOut), (txOutRef7, usrTxOut)]
+          & contractEnv .~ contractEnv'
+      pabConf :: PABConfig
+      pabConf = def {pcOwnPubKeyHash = pkh1}
+      -- contractEnv' :: ContractEnvironment ()
+      contractEnv' = def {cePABConfig = pabConf}
+
+      -- TODO: set these up.
+      scrLkups = mempty
+      txConsts = mempty
+
+      eunbalancedTx = Constraints.mkTx @Void scrLkups txConsts
+
+  case eunbalancedTx of
+    Left mkTxErr -> assertFailure ("MkTx Error: " <> show mkTxErr)
+    Right unbalancedTx -> do
+      let (eRslt, finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh1 unbalancedTx)
+      case eRslt of
+        (Left txt) -> assertFailure ("PAB effect error: " <> Text.unpack txt)
+        (Right (Left txt)) -> assertFailure ("Balancing error: " <> Text.unpack txt)
+        (Right (Right trx)) -> do
+          -- TODO
+          assertFailure "Incomplete Test"