PLT-797 Fix the test(s) for bug #695 (#766)

* Fix the test(s) for bug 695

* Remove bug695 test

* Add solution to #695 to MustReferenceOutput / Remove #696 / harmonize tests

* Fix imports

plutus-contract/src/Plutus/Contract/Test/Coverage/Analysis/Common.hs

@@ -1,19 +1,12 @@
-{-# LANGUAGE BangPatterns          #-}
 {-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE DeriveAnyClass        #-}
 {-# LANGUAGE DerivingVia           #-}
 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE GADTs                 #-}
 {-# LANGUAGE ImportQualifiedPost   #-}
-{-# LANGUAGE LambdaCase            #-}
-{-# LANGUAGE NumericUnderscores    #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE PatternSynonyms       #-}
-{-# LANGUAGE RecordWildCards       #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TupleSections         #-}
-{-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE UndecidableInstances  #-}
 {-# LANGUAGE ViewPatterns          #-}

plutus-contract/src/Plutus/Trace/Emulator.hs

@@ -81,6 +81,7 @@ import Control.Monad.Freer.Extras.Modify (raiseEnd)
 import Control.Monad.Freer.Reader (Reader, runReader)
 import Control.Monad.Freer.State (State, evalState)
 import Control.Monad.Freer.TH (makeEffect)
+import Data.Aeson qualified as A
 import Data.Default (Default (def))
 import Data.Map qualified as Map
 import Data.Maybe (fromMaybe)
@@ -122,7 +123,6 @@ import Plutus.Trace.Emulator.Types qualified
 import Streaming (Stream)
 import Streaming.Prelude (Of ((:>)))
 
-import Data.Aeson qualified as A
 import Ledger.Params (Params (..))
 import Ledger.Slot (getSlot)
 import Plutus.V1.Ledger.Value (Value, flattenValue)

plutus-contract/src/Plutus/Trace/Scheduler.hs

@@ -286,7 +286,7 @@ runThreads e = do
             in loop
                 $ initialState
                     & activeThreads . at initialThreadTag . non mempty %~ HashSet.insert initialThreadId
-                    & mailboxes . at initialThreadId .~ Just Seq.empty
+                    & mailboxes . at initialThreadId ?~ Seq.empty
                     & (fst . nextThreadId)
                     & enqueue (suspendThread Normal initialThread)
 

plutus-contract/src/Wallet/Emulator/Folds.hs

@@ -59,7 +59,7 @@ import Control.Monad.Freer.Error (Error, throwError)
 import Data.Aeson qualified as JSON
 import Data.Foldable (toList)
 import Data.Map qualified as Map
-import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Maybe (mapMaybe)
 import Data.Set qualified as Set
 import Data.Text (Text)
 import Ledger (Block, OnChainTx (Invalid, Valid), TxId)
@@ -116,7 +116,7 @@ walletTxBalanceEvents = preMapMaybe (preview (eteEvent . walletEvent' . _2 . _Tx
 
 -- | Min lovelace of 'txOut's from adjusted unbalanced transactions for all wallets
 walletsAdjustedTxEvents :: EmulatorEventFold [Ada.Ada]
-walletsAdjustedTxEvents = (Set.toList . Set.fromList . concat) <$> preMapMaybe (preview (eteEvent . walletEvent' . _2 . _RequestHandlerLog . _AdjustingUnbalancedTx)) L.list
+walletsAdjustedTxEvents = Set.toList . Set.fromList . concat <$> preMapMaybe (preview (eteEvent . walletEvent' . _2 . _RequestHandlerLog . _AdjustingUnbalancedTx)) L.list
 
 mkTxLogs :: EmulatorEventFold [MkTxLog]
 mkTxLogs =
@@ -162,7 +162,7 @@ instanceRequests ::
     -> ContractInstanceTag
     -> EmulatorEventFoldM effs [Request PABReq]
 instanceRequests con = fmap g . instanceState con where
-    g = fromMaybe [] . fmap (State.unRequests . _requests . instContractState)
+    g = maybe [] (State.unRequests . _requests . instContractState)
 
 -- | The unbalanced transactions generated by the contract instance.
 instanceTransactions ::
@@ -175,7 +175,7 @@ instanceTransactions ::
     -> EmulatorEventFoldM effs [UnbalancedTx]
 instanceTransactions con = fmap g . instanceState @w @s @e @a @effs con where
     g :: Maybe (ContractInstanceState w s e a) -> [UnbalancedTx]
-    g = fromMaybe [] . fmap (mapMaybe (preview _BalanceTxReq . State.rqRequest) . concat . toList . instHandlersHistory)
+    g = maybe [] (mapMaybe (preview _BalanceTxReq . State.rqRequest) . concat . toList . instHandlersHistory)
 
 
 -- | The reponses received by the contract instance
@@ -187,7 +187,7 @@ instanceResponses ::
     => Contract w s e a
     -> ContractInstanceTag
     -> EmulatorEventFoldM effs [Response PABResp]
-instanceResponses con = fmap (fromMaybe [] . fmap (toList . instEvents)) . instanceState con
+instanceResponses con = fmap (maybe [] (toList . instEvents)) . instanceState con
 
 -- | Accumulated state of the contract instance
 instanceAccumState ::
@@ -337,7 +337,7 @@ data EmulatorFoldErr =
 -- | A human-readable explanation of the error, to be included in the logs.
 describeError :: EmulatorFoldErr -> String
 describeError = \case
-    InstanceStateJSONDecodingError _ _ -> unwords $
+    InstanceStateJSONDecodingError _ _ -> unwords
         [ "Failed to decode a 'Response JSON.Value'."
         , "The event is probably for a different 'Contract'."
         , "This is often caused by having multiple contract instances share the same 'ContractInstanceTag' (for example, when  using 'activateContractWallet' repeatedly on the same wallet)."

plutus-contract/src/Wallet/Emulator/MultiAgent.hs

@@ -36,6 +36,7 @@ import GHC.Generics (Generic)
 import Prettyprinter (Pretty (pretty), colon, (<+>))
 
 import Cardano.Api (NetworkId)
+import Data.Foldable (fold)
 import Ledger hiding (to, value)
 import Ledger.Ada qualified as Ada
 import Ledger.AddressMap qualified as AM
@@ -299,7 +300,7 @@ emulatorStateInitialDist networkId mp = do
     outs <- traverse (toCardanoTxOut networkId toCardanoTxOutDatum) $ Map.toList mp >>= mkOutputs
     let tx = mempty
            { txOutputs = TxOut <$> outs
-           , txMint = foldMap snd $ Map.toList mp
+           , txMint = fold mp
            , txValidRange = WAPI.defaultSlotRange
            }
         cUtxoIndex = either (error . show) id $ Validation.fromPlutusIndex mempty

plutus-contract/src/Wallet/Emulator/Stream.hs

@@ -167,18 +167,15 @@ instance Default EmulatorConfig where
 initialState :: EmulatorConfig -> EM.EmulatorState
 initialState EmulatorConfig{..} = let
     networkId = pNetworkId _params
-    in either
-        (either
+    withInitialWalletValues = either
           (error . ("Cannot build the initial state: " <>) . show)
           id
-          . EM.emulatorStateInitialDist networkId . Map.mapKeys EM.mockWalletPaymentPubKeyHash)
-        (EM.emulatorStatePool . map signTx)
-        _initialChainState
-    where
-        signTx = onCardanoTx
-              (\t -> Validation.fromPlutusTxSigned _params cUtxoIndex t CW.knownPaymentKeys)
-              CardanoApiTx
-        cUtxoIndex = either (error . show) id $ Validation.fromPlutusIndex mempty
+          . EM.emulatorStateInitialDist networkId . Map.mapKeys EM.mockWalletPaymentPubKeyHash
+    signTx = onCardanoTx
+          (\t -> Validation.fromPlutusTxSigned _params cUtxoIndex t CW.knownPaymentKeys)
+          CardanoApiTx
+    cUtxoIndex = either (error . show) id $ Validation.fromPlutusIndex mempty
+    in either withInitialWalletValues (EM.emulatorStatePool . map signTx) _initialChainState
 
 
 data EmulatorErr =

plutus-contract/src/Wallet/Emulator/Wallet.hs

@@ -208,8 +208,8 @@ makePrisms ''WalletEvent
 -- | The state used by the mock wallet environment.
 data WalletState = WalletState {
     _mockWallet              :: MockWallet, -- ^ Mock wallet with the user's private key.
-    _nodeClient              :: NodeClientState,
-    _chainIndexEmulatorState :: ChainIndexEmulatorState,
+    _nodeClient              :: NodeClientState, -- ^ The representation of the node, as known by the wallet
+    _chainIndexEmulatorState :: ChainIndexEmulatorState, -- ^ the chain index info known by the wallet
     _signingProcess          :: Maybe SigningProcess
                                 -- ^ Override the signing process.
                                 -- Used for testing multi-agent use cases.

plutus-contract/test/Spec/TxConstraints/MustPayToPubKeyAddress.hs

@@ -9,16 +9,16 @@
 {-# LANGUAGE TypeApplications    #-}
 module Spec.TxConstraints.MustPayToPubKeyAddress(tests) where
 
-import Control.Lens ((??), (^.))
+import Control.Lens (_1, _head, has, makeClassyPrisms, only, (??), (^.))
 import Control.Monad (void)
 import Test.Tasty (TestTree, testGroup)
 
+import Data.Text qualified as Text
 import Ledger qualified
 import Ledger.Ada qualified as Ada
 import Ledger.Constraints qualified as Constraints
 import Ledger.Constraints.OnChain.V1 qualified as Constraints
 import Ledger.Constraints.OnChain.V2 qualified as V2.Constraints
-import Ledger.Scripts (ScriptError (EvaluationError))
 import Ledger.Test (asDatum, asRedeemer)
 import Ledger.Tx qualified as Tx
 import Ledger.Tx.Constraints qualified as Tx.Constraints
@@ -34,6 +34,8 @@ import Plutus.V1.Ledger.Value qualified as Value
 import PlutusTx qualified
 import PlutusTx.Prelude qualified as P
 
+makeClassyPrisms ''Ledger.ScriptError
+
 -- Constraint's functions should soon be changed to use Address instead of PaymentPubKeyHash and StakeKeyHash
 tests :: TestTree
 tests = testGroup "MustPayToPubKeyAddress"
@@ -78,6 +80,9 @@ v2FeaturesNotAvailableTests sub t = testGroup "Plutus V2 features" $
     [ phase1FailureWhenUsingInlineDatumWithV1
     ] ?? sub ?? t
 
+evaluationError :: Text.Text -> Ledger.ValidationError -> Bool
+evaluationError errCode = has $ Ledger._ScriptFailure . _EvaluationError . _1 . _head . only errCode
+
 someDatum :: Ledger.Datum
 someDatum = asDatum @P.BuiltinByteString "datum"
 
@@ -215,8 +220,7 @@ successfulUseOfMustPayWithDatumInTxToPubKeyAddress submitTxFromConstraints tc =
     let onChainConstraint = asRedeemer $ MustPayWithDatumInTxToPubKeyAddress w2PaymentPubKeyHash w2StakePubKeyHash someDatum adaValue
         contract = do
             let lookups1 = mintingPolicy tc $ mustPayToPubKeyAddressPolicy tc
-                tx1 =
-                    Constraints.mustPayWithDatumInTxToPubKeyAddress
+                tx1 = Constraints.mustPayWithDatumInTxToPubKeyAddress
                         w2PaymentPubKeyHash
                         w2StakePubKeyHash
                         someDatum
@@ -236,14 +240,18 @@ phase2FailureWhenUsingUnexpectedPaymentPubKeyHash submitTxFromConstraints tc =
     let onChainConstraint = asRedeemer $ MustPayWithDatumInTxToPubKeyAddress w2PaymentPubKeyHash w2StakePubKeyHash someDatum adaValue
         contract = do
             let lookups1 = mintingPolicy tc $ mustPayToPubKeyAddressPolicy tc
-                tx1 = Constraints.mustPayWithDatumInTxToPubKeyAddress w1PaymentPubKeyHash w2StakePubKeyHash someDatum adaValue
+                tx1 = Constraints.mustPayWithDatumInTxToPubKeyAddress
+                        w1PaymentPubKeyHash
+                        w2StakePubKeyHash
+                        someDatum
+                        adaValue
                    <> Constraints.mustMintValueWithRedeemer onChainConstraint (tknValue tc)
             ledgerTx1 <- submitTxFromConstraints lookups1 tx1
             awaitTxConfirmed $ Tx.getCardanoTxId ledgerTx1
 
     in checkPredicate
     "Phase-2 validation failure occurs when onchain mustPayWithDatumInTxToPubKeyAddress constraint sees an unexpected PaymentPubkeyHash"
-    (assertFailedTransaction (\_ err -> case err of {Ledger.ScriptFailure (EvaluationError ("La":_) _) -> True; _ -> False }))
+    (assertFailedTransaction $ const $ evaluationError "La")
     (void $ trace contract)
 
 -- | Phase-2 failure when onchain mustPayWithDatumInTxToPubKeyAddress constraint cannot verify the Datum"
@@ -259,7 +267,7 @@ phase2FailureWhenUsingUnexpectedDatum submitTxFromConstraints tc =
 
     in checkPredicate
     "Phase-2 validation failure occurs when onchain mustPayWithDatumInTxToPubKeyAddress constraint sees an unexpected Datum"
-    (assertFailedTransaction (\_ err -> case err of {Ledger.ScriptFailure (EvaluationError ("La":_) _) -> True; _ -> False }))
+    (assertFailedTransaction $ const $ evaluationError "La")
     (void $ trace contract)
 
 -- | Phase-2 failure when onchain mustPayWithDatumInTxToPubKeyAddress constraint cannot verify the Value"
@@ -275,7 +283,7 @@ phase2FailureWhenUsingUnexpectedValue submitTxFromConstraints tc =
 
     in checkPredicate
     "Phase-2 validation failure occurs when onchain mustPayWithDatumInTxToPubKeyAddress constraint sees an unexpected Value"
-    (assertFailedTransaction (\_ err -> case err of {Ledger.ScriptFailure (EvaluationError ("La":_) _) -> True; _ -> False }))
+    (assertFailedTransaction $ const $ evaluationError "La")
     (void $ trace contract)
 
 
@@ -309,7 +317,7 @@ phase1FailureWhenUsingInlineDatumWithV1 submitTxFromConstraints tc =
 
     in checkPredicate
     "Phase-1 failure when mustPayToPubKeyAddress in a V1 script use inline datum"
-    (assertFailedTransaction (\_ err -> case err of {Ledger.CardanoLedgerValidationError _ -> True; _ -> False }))
+    (assertFailedTransaction (const $ has Ledger._CardanoLedgerValidationError))
     (void $ trace contract)
 
 

plutus-contract/test/Spec/TxConstraints/MustReferenceOutput.hs

@@ -10,7 +10,7 @@
 {-# LANGUAGE TypeFamilies        #-}
 module Spec.TxConstraints.MustReferenceOutput(tests) where
 
-import Control.Lens ((??), (^.))
+import Control.Lens (At (at), _1, _head, filtered, has, makeClassyPrisms, non, only, (??), (^.))
 import Control.Monad (void)
 import Test.Tasty (TestTree, testGroup)
 
@@ -23,7 +23,6 @@ import Ledger.Ada qualified as Ada
 import Ledger.Constraints qualified as Cons
 import Ledger.Constraints.OnChain.V1 qualified as Cons.V1
 import Ledger.Constraints.OnChain.V2 qualified as Cons.V2
-import Ledger.Scripts (ScriptError (EvaluationError))
 import Ledger.Test (asDatum, asRedeemer, someAddress, someValidatorHash)
 import Ledger.Tx qualified as Tx
 import Ledger.Tx.Constraints qualified as Tx.Cons
@@ -40,6 +39,9 @@ import Plutus.V1.Ledger.Value qualified as Value
 import PlutusTx qualified
 import PlutusTx.Prelude qualified as P
 import Wallet.Emulator.Wallet (WalletState, chainIndexEmulatorState)
+import Wallet.Emulator.Wallet qualified as Wallet
+
+makeClassyPrisms ''L.ScriptError
 
 tests :: TestTree
 tests =
@@ -73,6 +75,9 @@ v2FeaturesTests sub t = testGroup "Plutus V2 features" $
     , phase2FailureWhenUsingV2Script
     ] ?? sub ?? t
 
+evaluationError :: Text.Text -> L.ValidationError -> Bool
+evaluationError errCode = has $ L._ScriptFailure . _EvaluationError . _1 . _head . only errCode
+
 tknValue :: PSU.Language -> Value.Value
 tknValue l = Value.singleton (PSU.scriptCurrencySymbol $ getVersionedScript MustReferenceOutputPolicy l) "mint-me" 1
 
@@ -104,16 +109,9 @@ mustReferenceOutputContract submitTxFromConstraints l offChainTxoRefs onChainTxo
         mustReferenceOutputs = Cons.mustReferenceOutput <$> offChainTxoRefs
 
 txoRefsFromWalletState :: WalletState -> Set Tx.TxOutRef
-txoRefsFromWalletState ws =
-    head $ M.elems $ ws ^. chainIndexEmulatorState . diskState . addressMap . unCredentialMap
-
--- needed to workaround bug 695
-overrideW1TxOutRefs :: [Tx.TxOutRef] -> [Tx.TxOutRef]
-overrideW1TxOutRefs = overrideTxOutRefIdxes 50
-
-overrideTxOutRefIdxes :: Integer -> [Tx.TxOutRef] -> [Tx.TxOutRef]
-overrideTxOutRefIdxes i = fmap (\r@Tx.TxOutRef{Tx.txOutRefIdx=idx} -> r{Tx.txOutRefIdx= idx + i})
---
+txoRefsFromWalletState w = let
+  pkCred = L.addressCredential $ Wallet.ownAddress w
+  in w ^. chainIndexEmulatorState . diskState . addressMap . unCredentialMap . at pkCred . non mempty
 
 -- | Ledger validation error occurs when attempting use of offchain mustReferenceOutput
 --   constraint with V1 script
@@ -154,8 +152,7 @@ phase2FailureWithMustReferenceOutput testDescription submitTxFromConstraints l =
 
     in checkPredicateOptions defaultCheckOptions
     testDescription
-    (assertFailedTransaction (\_ err ->
-        case err of {L.ScriptFailure (EvaluationError ("Lf":_) _) -> True; _ -> False }))
+    (assertFailedTransaction $ const $ evaluationError "Lf")
     (void $ defTrace contractWithoutOffchainConstraint)
 
 -- | Valid scenario using offchain and onchain constraint
@@ -166,10 +163,9 @@ mustReferenceOutputWithSinglePubkeyOutput submitTxFromConstraints l =
             w1State <- Trace.agentState w1
             let w1TxoRefs = txoRefsFromWalletState w1State
                 w1MiddleTxoRef = [S.elemAt (length w1TxoRefs `div` 2) w1TxoRefs]
-                overridedW1TxoRefs = overrideW1TxOutRefs w1MiddleTxoRef -- need to override index due to bug 695
                 contract =
                     mustReferenceOutputContract submitTxFromConstraints l
-                    overridedW1TxoRefs overridedW1TxoRefs
+                    w1MiddleTxoRef w1MiddleTxoRef
             void $ Trace.activateContractWallet w1 contract
             void $ Trace.waitNSlots 1
 
@@ -185,11 +181,9 @@ mustReferenceOutputWithMultiplePubkeyOutputs :: SubmitTx -> PSU.Language -> Test
 mustReferenceOutputWithMultiplePubkeyOutputs submitTxFromConstraints l =
     let trace = do
             w1State <- Trace.agentState w1
-            let w1TxoRefs = txoRefsFromWalletState w1State
-                overridedW1TxoRefs = overrideW1TxOutRefs $ S.toList w1TxoRefs -- need to override index due to bug 695
+            let w1TxoRefs = S.toList $ txoRefsFromWalletState w1State
                 contract =
-                    mustReferenceOutputContract submitTxFromConstraints l
-                    overridedW1TxoRefs overridedW1TxoRefs
+                    mustReferenceOutputContract submitTxFromConstraints l w1TxoRefs w1TxoRefs
             void $ Trace.activateContractWallet w1 contract
             void $ Trace.waitNSlots 1
 
@@ -234,9 +228,9 @@ ledgerValidationErrorWhenReferencingNonExistingTxo submitTxFromConstraints l =
     in checkPredicateOptions defaultCheckOptions
     ("Ledger validation error occurs when using offchain mustReferenceOutput " ++
      "constraint with a txo that doesn't exist")
-    (assertFailedTransaction (\_ err ->
-        case err of {L.CardanoLedgerValidationError msg ->
-            Text.isInfixOf "TranslationLogicMissingInput" msg; _ -> False  }))
+    (assertFailedTransaction (const $ has
+        $ L._CardanoLedgerValidationError . filtered (Text.isInfixOf "TranslationLogicMissingInput"))
+    )
     (void $ defTrace contract)
 
 data UnitTest