From 6421a756bf17a5bbd129fe58fb7820d6ca7a9b21 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C4=B1z=C4=B1r=20Sefa=20=C4=B0rken?= Date: Tue, 7 Apr 2026 20:46:44 +0300 Subject: [PATCH 1/3] fix: return full redeemer report instead of single entry --- testgen-hs/Evaluation.hs | 61 +++------------------------------------- 1 file changed, 4 insertions(+), 57 deletions(-) diff --git a/testgen-hs/Evaluation.hs b/testgen-hs/Evaluation.hs index c4efdf4..9e1f312 100644 --- a/testgen-hs/Evaluation.hs +++ b/testgen-hs/Evaluation.hs @@ -15,10 +15,9 @@ where import CLI (GenSize (..), NumCases (..), Seed (..)) import Cardano.Api.Internal.Orphans () import Cardano.Ledger.Alonzo.Plutus.Evaluate (evalTxExUnits) -import Cardano.Ledger.Alonzo.Scripts (AsIx (..), ExUnits (..)) import Cardano.Ledger.Api (ConwayEra, PParams, TransactionScriptFailure) import qualified Cardano.Ledger.Api as Ledger -import Cardano.Ledger.Api.Tx (PlutusPurpose, RedeemerReport, Tx) +import Cardano.Ledger.Api.Tx (RedeemerReport, Tx) import Cardano.Ledger.Api.UTxO (UTxO (..)) import Cardano.Slotting.EpochInfo (EpochInfo) import Cardano.Slotting.Slot () @@ -27,7 +26,6 @@ import Data.Aeson (ToJSON) import qualified Data.Aeson as J import qualified Data.Aeson.Encoding as AesonEncoding import qualified Data.ByteString.Lazy.Char8 as BL8 -import Data.List (sortOn) import qualified Data.Map as Map import Data.Proxy (Proxy) import Data.Text (Text) @@ -89,61 +87,10 @@ eval'Conway :: SystemStart -> J.Value eval'Conway pparams tx utxo epochInfo systemStart = - case J.decode (AesonEncoding.encodingToLazyByteString (ogmiosSuccess redeemerReport)) of + case J.decode (AesonEncoding.encodingToLazyByteString (ogmiosSuccess report)) of Just v -> v Nothing -> error "ogmiosSuccess produced invalid JSON" where - redeemerReport :: RedeemerReport ConwayEra - redeemerReport = selectSingleReport fullReport + report :: RedeemerReport ConwayEra + report = evalTxExUnits pparams tx utxo epochInfo systemStart - fullReport :: RedeemerReport ConwayEra - fullReport = evalTxExUnits pparams tx utxo epochInfo systemStart - - -- Collapse the full report down to a single entry, preferring failures. - selectSingleReport :: RedeemerReport ConwayEra -> RedeemerReport ConwayEra - selectSingleReport report = - case Map.toList failures of - (purpose, errors) : _ -> - Map.singleton purpose (Left (pickScriptFailure errors)) - [] -> - case Map.toList successes of - (purpose, exUnits) : _ -> - Map.singleton purpose (Right exUnits) - [] -> - Map.empty - where - (failures, successes) = Map.foldrWithKey groupReports (Map.empty, Map.empty) report - - groupReports :: - (Ord (PlutusPurpose AsIx era)) => - PlutusPurpose AsIx era -> - Either (Ledger.TransactionScriptFailure era) ExUnits -> - (Map.Map (PlutusPurpose AsIx era) [Ledger.TransactionScriptFailure era], Map.Map (PlutusPurpose AsIx era) ExUnits) -> - (Map.Map (PlutusPurpose AsIx era) [Ledger.TransactionScriptFailure era], Map.Map (PlutusPurpose AsIx era) ExUnits) - groupReports purpose result (failures, successes) = - case result of - Left scriptFail -> (Map.unionWith (++) (Map.singleton purpose [scriptFail]) failures, successes) - Right exUnits -> (failures, Map.singleton purpose exUnits <> successes) - --- | Return the most relevant script failure from a list of errors. -pickScriptFailure :: - [Ledger.TransactionScriptFailure era] -> - Ledger.TransactionScriptFailure era -pickScriptFailure xs = - case sortOn scriptFailurePriority xs of - [] -> error "Empty list of script failures from the ledger!?" - x : _ -> x - where - scriptFailurePriority :: - Ledger.TransactionScriptFailure era -> - Word - scriptFailurePriority = \case - Ledger.UnknownTxIn {} -> 0 - Ledger.MissingScript {} -> 0 - Ledger.RedeemerPointsToUnknownScriptHash {} -> 1 - Ledger.NoCostModelInLedgerState {} -> 1 - Ledger.InvalidTxIn {} -> 2 - Ledger.MissingDatum {} -> 3 - Ledger.ContextError {} -> 4 - Ledger.ValidationFailure {} -> 5 - Ledger.IncompatibleBudget {} -> 999 From fa6568248c9c16beeb476d625a553b0ef88d0728 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C4=B1z=C4=B1r=20Sefa=20=C4=B0rken?= Date: Thu, 9 Apr 2026 21:11:42 +0300 Subject: [PATCH 2/3] fix: linting --- testgen-hs/Evaluation.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/testgen-hs/Evaluation.hs b/testgen-hs/Evaluation.hs index 9e1f312..a909651 100644 --- a/testgen-hs/Evaluation.hs +++ b/testgen-hs/Evaluation.hs @@ -93,4 +93,3 @@ eval'Conway pparams tx utxo epochInfo systemStart = where report :: RedeemerReport ConwayEra report = evalTxExUnits pparams tx utxo epochInfo systemStart - From 42e660a4052fa3d21ed23cfecab887c8eb1ad8d9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?H=C4=B1z=C4=B1r=20Sefa=20=C4=B0rken?= Date: Thu, 9 Apr 2026 21:26:42 +0300 Subject: [PATCH 3/3] fix: hlint, unused language pragma --- testgen-hs/Evaluation.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/testgen-hs/Evaluation.hs b/testgen-hs/Evaluation.hs index a909651..5ed2039 100644 --- a/testgen-hs/Evaluation.hs +++ b/testgen-hs/Evaluation.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-orphans #-}