Implement GADTs for PlutusDebug et.al.

IntersectMBO · Dec 2, 2022 · 3ea4e01 · 3ea4e01
1 parent cbe5f09
commit 3ea4e01
Show file tree

Hide file tree

Showing 12 changed files with 268 additions and 125 deletions.
diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Data.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Data.hs
@@ -121,11 +121,6 @@ import qualified PlutusCore.Data as PCD
 -- It is imported from the Plutus package, but it needs a few additional
 -- instances to also work in the ledger.
 
--- instance FromCBOR (Annotator PV1.Data) where -- TODO: Remove this?
---   fromCBOR = pure <$> Cborg.decode
--- instance ToCBOR PV1.Data where
---   toCBOR = Cborg.encode
-
 -- TODO: Move to PlutusCore.Data module
 deriving instance NoThunks PCD.Data
 

diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs
@@ -47,7 +47,7 @@ import Cardano.Ledger.Alonzo.TxBody
   )
 import Cardano.Ledger.Alonzo.TxInfo
   ( ExtendedUTxO (..),
-    PlutusDebug,
+    PlutusDebugWrapper (..),
     ScriptFailure (..),
     ScriptResult (..),
   )
@@ -134,10 +134,15 @@ instance
   type Event (AlonzoUTXOS era) = AlonzoUtxosEvent era
   transitionRules = [utxosTransition]
 
+-- data AlonzoUtxosEvent era where
+--   AlonzoPpupToUtxosEvent :: (Event (EraRule "PPUP" era)) -> AlonzoUtxosEvent era
+--   SuccessfulPlutusScriptsEvent :: forall era (l :: Language). (IsLanguage l) => (NonEmpty (PlutusDebug l)) -> AlonzoUtxosEvent era
+--   FailedPlutusScriptsEvent :: forall era (l :: Language). (IsLanguage l) => (NonEmpty (PlutusDebug l)) -> AlonzoUtxosEvent era
+
 data AlonzoUtxosEvent era
   = AlonzoPpupToUtxosEvent (Event (EraRule "PPUP" era))
-  | SuccessfulPlutusScriptsEvent (NonEmpty PlutusDebug)
-  | FailedPlutusScriptsEvent (NonEmpty PlutusDebug)
+  | SuccessfulPlutusScriptsEvent (NonEmpty PlutusDebugWrapper)
+  | FailedPlutusScriptsEvent (NonEmpty PlutusDebugWrapper)
 
 instance
   ( Era era,
@@ -332,7 +337,7 @@ scriptFailureToFailureDescription protVer (PlutusSF t pd) =
 scriptFailuresToPredicateFailure :: ProtVer -> NonEmpty ScriptFailure -> NonEmpty FailureDescription
 scriptFailuresToPredicateFailure protVer = fmap (scriptFailureToFailureDescription protVer)
 
-scriptFailuresToPlutusDebug :: NonEmpty ScriptFailure -> NonEmpty PlutusDebug
+scriptFailuresToPlutusDebug :: NonEmpty ScriptFailure -> NonEmpty PlutusDebugWrapper
 scriptFailuresToPlutusDebug = fmap (\(PlutusSF _ pdb) -> pdb)
 
 data TagMismatchDescription

diff --git a/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tools.hs b/eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Tools.hs
@@ -1,6 +1,9 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -12,7 +15,7 @@ module Cardano.Ledger.Alonzo.Tools
 where
 
 import Cardano.Ledger.Alonzo.Data (Data, Datum (..), binaryDataToData, getPlutusData)
-import Cardano.Ledger.Alonzo.Language (Language (..))
+import Cardano.Ledger.Alonzo.Language (Language (..), SLanguage (..))
 import Cardano.Ledger.Alonzo.PlutusScriptApi (knownToNotBe1Phase)
 import Cardano.Ledger.Alonzo.Scripts
   ( AlonzoScript (..),
@@ -28,6 +31,7 @@ import Cardano.Ledger.Alonzo.TxInfo
     TranslationError,
     VersionedTxInfo (..),
     exBudgetToExUnits,
+    mkPlutusDebug,
     transExUnits,
     transProtocolVersion,
     txInfo,
@@ -71,10 +75,8 @@ data TransactionScriptFailure c
     MissingScript !RdmrPtr !(Map RdmrPtr (ScriptPurpose c, Maybe (ShortByteString, Language), ScriptHash c))
   | -- | Missing datum.
     MissingDatum !(DataHash c)
-  | -- | Plutus V1 evaluation error.
-    ValidationFailedV1 !PV1.EvaluationError ![Text] PlutusDebug
-  | -- | Plutus V2 evaluation error.
-    ValidationFailedV2 !PV2.EvaluationError ![Text] PlutusDebug
+  | -- | Plutus evaluation error, for any version
+    ValidationFailure ValidationFailed
   | -- | A redeemer points to a transaction input which is not
     --  present in the current UTxO.
     UnknownTxIn !(TxIn c)
@@ -86,7 +88,15 @@ data TransactionScriptFailure c
     IncompatibleBudget !PV1.ExBudget
   | -- | There was no cost model for a given version of Plutus in the ledger state
     NoCostModelInLedgerState !Language
-  deriving (Show, Eq)
+  deriving (Eq, Show)
+
+data ValidationFailed where
+  ValidationFailedV1 :: !PV1.EvaluationError -> ![Text] -> PlutusDebug 'PlutusV1 -> ValidationFailed
+  ValidationFailedV2 :: !PV2.EvaluationError -> ![Text] -> PlutusDebug 'PlutusV2 -> ValidationFailed
+
+deriving instance Eq (ValidationFailed)
+
+deriving instance Show (ValidationFailed)
 
 note :: e -> Maybe a -> Either e a
 note _ (Just x) = Right x
@@ -220,11 +230,11 @@ evaluateTransactionExecutionUnitsWithLogs pp tx utxo ei sysS costModels = do
       case interpreter lang (getEvaluationContext cm) maxBudget script pArgs of
         (logs, Left e) -> case lang of
           PlutusV1 ->
-            let debug = PlutusDebugV1 cm exunits script pArgs protVer
-             in Left $ ValidationFailedV1 e logs debug
+            let debug = mkPlutusDebug SPlutusV1 cm exunits script pArgs protVer
+             in Left $ ValidationFailure $ ValidationFailedV1 e logs debug
           PlutusV2 ->
-            let debug = PlutusDebugV2 cm exunits script pArgs protVer
-             in Left $ ValidationFailedV2 e logs debug
+            let debug = mkPlutusDebug SPlutusV2 cm exunits script pArgs protVer
+             in Left $ ValidationFailure $ ValidationFailedV2 e logs debug
         (logs, Right exBudget) -> note (IncompatibleBudget exBudget) $ (,) logs <$> exBudgetToExUnits exBudget
       where
         maxBudget = transExUnits . getField @"_maxTxExUnits" $ pparams