Add nested failure for sub transactions

Author: lehins

eras/dijkstra/impl/CHANGELOG.md

@@ -2,6 +2,7 @@
 
 ## 0.3.0.0
 
+* Add `SubTxContextError`
 * Add `DijkstraStAnnTx`
 * Add `scriptsProvidedDijkstraStAnnTx`
 * Remove `ToCBOR` and `FromCBOR` instances for `DijkstraGovPredFailure`

eras/dijkstra/impl/src/Cardano/Ledger/Dijkstra/TxInfo.hs

@@ -71,6 +71,7 @@ import Cardano.Ledger.Plutus.Data (Data)
 import Cardano.Ledger.Plutus.ToPlutusData (ToPlutusData (..))
 import Cardano.Ledger.State (StakePoolParams (..))
 import Cardano.Ledger.TxIn (TxId)
+import Control.Arrow (left)
 import Control.DeepSeq (NFData)
 import Control.Monad (forM, zipWithM)
 import Data.Aeson (KeyValue (..), ToJSON (..))
@@ -89,6 +90,8 @@ import qualified PlutusLedgerApi.V3 as PV3
 
 data DijkstraContextError era
   = ConwayContextError (ConwayContextError era)
+  | -- | Failure translating sub-transactions for Guarding purpose at the top level
+    SubTxContextError TxId (ContextError era)
   | PointerPresentInOutput (NonEmpty (TxOut era))
   | -- | Attempt to use PlutusV1-V3 in a sub-transaction will result in this failure
     SubTxIsNotSupported TxId
@@ -98,56 +101,69 @@ deriving instance
   ( AlonzoEraScript era
   , EraTxCert era
   , EraTxOut era
+  , Eq (ContextError era)
   ) =>
   Eq (DijkstraContextError era)
 
 deriving instance
   ( AlonzoEraScript era
   , EraTxCert era
   , EraTxOut era
+  , Show (ContextError era)
   ) =>
   Show (DijkstraContextError era)
 
 instance
   ( AlonzoEraScript era
   , EraTxCert era
   , EraTxOut era
+  , NFData (ContextError era)
   ) =>
   NFData (DijkstraContextError era)
 
 instance
-  ( ToJSON (TxCert era)
+  ( ToJSON (TxOut era)
+  , ToJSON (TxCert era)
+  , ToJSON (ContextError era)
   , ToJSON (PlutusPurpose AsIx era)
   , ToJSON (PlutusPurpose AsItem era)
-  , ToJSON (TxOut era)
   , EraPParams era
   ) =>
   ToJSON (DijkstraContextError era)
   where
   toJSON = \case
     ConwayContextError x -> toJSON x
+    SubTxContextError txId subTxError ->
+      kindObject
+        "SubTxContextError"
+        [ "txId" .= toJSON txId
+        , "subTxError" .= toJSON subTxError
+        ]
     PointerPresentInOutput x -> kindObject "PointerPresentInOutput" ["txOut" .= toJSON x]
     SubTxIsNotSupported txId -> kindObject "SubTxIsNotSupported" ["txId" .= toJSON txId]
 
 instance
   ( EraPParams era
-  , DecCBOR (TxCert era)
   , DecCBOR (TxOut era)
+  , DecCBOR (TxCert era)
+  , DecCBOR (ContextError era)
   , DecCBOR (PlutusPurpose AsIx era)
   , DecCBOR (PlutusPurpose AsItem era)
   ) =>
   DecCBOR (DijkstraContextError era)
   where
   decCBOR = decode $ Summands "ContextError" $ \case
     16 -> SumD ConwayContextError <! From
-    17 -> SumD PointerPresentInOutput <! From
-    18 -> SumD SubTxIsNotSupported <! From
+    17 -> SumD SubTxContextError <! From <! From
+    18 -> SumD PointerPresentInOutput <! From
+    19 -> SumD SubTxIsNotSupported <! From
     k -> Invalid k
 
 instance
   ( EraPParams era
-  , EncCBOR (TxCert era)
   , EncCBOR (TxOut era)
+  , EncCBOR (TxCert era)
+  , EncCBOR (ContextError era)
   , EncCBOR (PlutusPurpose AsIx era)
   , EncCBOR (PlutusPurpose AsItem era)
   ) =>
@@ -156,8 +172,9 @@ instance
   encCBOR =
     encode . \case
       ConwayContextError x -> Sum ConwayContextError 16 !> To x
-      PointerPresentInOutput x -> Sum PointerPresentInOutput 17 !> To x
-      SubTxIsNotSupported txId -> Sum SubTxIsNotSupported 18 !> To txId
+      SubTxContextError txId subTxError -> Sum SubTxContextError 17 !> To txId !> To subTxError
+      PointerPresentInOutput x -> Sum PointerPresentInOutput 18 !> To x
+      SubTxIsNotSupported txId -> Sum SubTxIsNotSupported 19 !> To txId
 
 instance Inject (ConwayContextError era) (DijkstraContextError era) where
   inject = ConwayContextError
@@ -424,9 +441,10 @@ instance EraPlutusTxInfo 'PlutusV4 DijkstraEra where
           purpose@(GuardingPurpose AsPurpose) -> do
             _subTxInfosForGuards <-
               forM (OMap.elems (tx ^. bodyTxL . subTransactionsTxBodyL)) $ \subTx -> do
+                let txId = txIdTx subTx
                 mkTxInfo <-
                   unPlutusTxInfoResult $
-                    case Map.lookup (txIdTx subTx) (ltiMemoizedSubTransactions lti) of
+                    case Map.lookup txId (ltiMemoizedSubTransactions lti) of
                       Nothing ->
                         toPlutusTxInfo proxy $
                           lti
@@ -435,7 +453,7 @@ instance EraPlutusTxInfo 'PlutusV4 DijkstraEra where
                             }
                       Just txInfoResults ->
                         lookupTxInfoResult (plutusSLanguage proxy) txInfoResults
-                mkTxInfo purpose
+                left (SubTxContextError txId) $ mkTxInfo purpose
             -- TODO: Add Sub transactions
             Right topTxInfo
           _ -> Right topTxInfo

eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Arbitrary.hs

@@ -20,6 +20,7 @@ import Cardano.Ledger.Allegra.Scripts (
   pattern RequireTimeExpire,
   pattern RequireTimeStart,
  )
+import Cardano.Ledger.Alonzo.Plutus.Context (ContextError)
 import Cardano.Ledger.BaseTypes (StrictMaybe)
 import Cardano.Ledger.Conway.Rules (ConwayDelegPredFailure)
 import Cardano.Ledger.Dijkstra (ApplyTxError (DijkstraApplyTxError), DijkstraEra)
@@ -157,6 +158,7 @@ instance
   , Arbitrary (PParamsHKD StrictMaybe era)
   , Arbitrary (TxCert era)
   , Arbitrary (TxOut era)
+  , Arbitrary (ContextError era)
   ) =>
   Arbitrary (DijkstraContextError era)
   where

eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/TreeDiff.hs

@@ -16,6 +16,7 @@ module Test.Cardano.Ledger.Dijkstra.TreeDiff (
   module Test.Cardano.Ledger.Conway.TreeDiff,
 ) where
 
+import Cardano.Ledger.Alonzo.Plutus.Context (ContextError)
 import Cardano.Ledger.BaseTypes (StrictMaybe)
 import Cardano.Ledger.Conway.Rules (ConwayGovEvent)
 import Cardano.Ledger.Dijkstra (DijkstraEra)
@@ -161,6 +162,7 @@ instance
   , ToExpr (PlutusPurpose AsItem era)
   , ToExpr (TxCert era)
   , ToExpr (TxOut era)
+  , ToExpr (ContextError era)
   ) =>
   ToExpr (DijkstraContextError era)