Plutus V4 and dijkstraPV

Author: zliu41

plutus-ledger-api/changelog.d/20260816_102247_unsafeFixIO_v4.md

@@ -0,0 +1,3 @@
+### Added
+
+- Plutus V4 and `dijkstraPV`.

plutus-ledger-api/exe/analyse-script-events/Main.hs

@@ -24,6 +24,7 @@ import PlutusLedgerApi.Test.EvaluationEvent
 import PlutusLedgerApi.V1 qualified as V1
 import PlutusLedgerApi.V2 qualified as V2
 import PlutusLedgerApi.V3 qualified as V3
+import PlutusLedgerApi.V4 qualified as V4
 import PlutusTx.AssocMap qualified as M
 import UntypedPlutusCore as UPLC
 
@@ -73,6 +74,16 @@ stringOfPurposeV3 = \case
   V3.VotingScript {} -> "V3 Voting"
   V3.ProposingScript {} -> "V3 Proposing"
 
+stringOfPurposeV4 :: V4.ScriptInfo -> String
+stringOfPurposeV4 = \case
+  V4.MintingScript {} -> "V4 Minting"
+  V4.SpendingScript {} -> "V4 Spending"
+  V4.WithdrawingScript {} -> "V4 Withdrawing"
+  V4.CertifyingScript {} -> "V4 Certifying"
+  V4.VotingScript {} -> "V4 Voting"
+  V4.ProposingScript {} -> "V4 Proposing"
+  V4.GuardingScript {} -> "V4 Guarding"
+
 shapeOfValue :: V1.Value -> String
 shapeOfValue (V1.Value m) =
   let l = M.toList m
@@ -117,6 +128,16 @@ analyseTxInfoV3 i = do
   analyseValue $ V3.mintValueBurned (V3.txInfoMint i)
   analyseOutputs (V3.txInfoOutputs i) V3.txOutValue
 
+analyseTxInfoV4 :: V4.TxInfo -> IO ()
+analyseTxInfoV4 i = do
+  putStr "Fee:     "
+  print $ V4.txInfoFee i
+  putStr "Mint:    "
+  analyseValue $ V4.mintValueMinted (V4.txInfoMint i)
+  putStr "Burn:    "
+  analyseValue $ V4.mintValueBurned (V4.txInfoMint i)
+  analyseOutputs (V4.txInfoOutputs i) V4.txOutValue
+
 analyseScriptContext :: EventAnalyser
 analyseScriptContext _ctx _params ev = case ev of
   PlutusEvent PlutusV1 ScriptEvaluationData {..} _expected ->
@@ -134,6 +155,11 @@ analyseScriptContext _ctx _params ev = case ev of
       [_, _, c] -> analyseCtxV3 c
       [_, c] -> analyseCtxV3 c
       l -> error $ printf "Unexpected number of V3 script arguments: %d" (length l)
+  PlutusEvent PlutusV4 ScriptEvaluationData {..} _expected ->
+    case dataInputs of
+      [_, _, c] -> analyseCtxV4 c
+      [_, c] -> analyseCtxV4 c
+      l -> error $ printf "Unexpected number of V4 script arguments: %d" (length l)
   where
     analyseCtxV1 c =
       case V1.fromData @V1.ScriptContext c of
@@ -176,6 +202,11 @@ analyseScriptContext _ctx _params ev = case ev of
               printV1info p
             Nothing -> putStrLn "* Failed to decode V1 ScriptContext for V3 event: giving up\n"
 
+    analyseCtxV4 c =
+      case V4.fromData @V4.ScriptContext c of
+        Just p -> printV4info p
+        Nothing -> putStrLn "\n* Failed to decode V4 ScriptContext for V4 event: giving up\n"
+
     printV1info p = do
       putStrLn "----------------"
       putStrLn $ stringOfPurposeV1 $ V1.scriptContextPurpose p
@@ -191,6 +222,11 @@ analyseScriptContext _ctx _params ev = case ev of
       putStrLn $ stringOfPurposeV3 $ V3.scriptContextScriptInfo p
       analyseTxInfoV3 $ V3.scriptContextTxInfo p
 
+    printV4info p = do
+      putStrLn "----------------"
+      putStrLn $ stringOfPurposeV4 $ V4.scriptContextScriptInfo p
+      analyseTxInfoV4 $ V4.scriptContextTxInfo p
+
 -- Data object analysis
 
 -- Statistics about a Data object
@@ -416,6 +452,25 @@ analyseCosts ctx _ ev =
                   (_, Left _) -> Failed
                   (_, Right cost) -> OK cost
       printCost result dataBudget
+    PlutusEvent PlutusV4 ScriptEvaluationData {..} _ -> do
+      dataInput <-
+        case dataInputs of
+          [input] -> pure input
+          _ -> throwIO $ userError "PlutusV4 script expects exactly one input"
+      let result =
+            case deserialiseScript PlutusV4 dataProtocolVersion dataScript of
+              Left _ -> DeserialisationError
+              Right script -> do
+                case V4.evaluateScriptRestricting
+                  dataProtocolVersion
+                  V4.Quiet
+                  ctx
+                  dataBudget
+                  script
+                  dataInput of
+                  (_, Left _) -> Failed
+                  (_, Right cost) -> OK cost
+      printCost result dataBudget
   where
     printCost :: EvaluationResult -> ExBudget -> IO ()
     printCost result claimedCost =
@@ -463,12 +518,14 @@ analyseOneFile analyse eventFile = do
   case ( mkContext V1.mkEvaluationContext (eventsCostParamsV1 events)
        , mkContext V2.mkEvaluationContext (eventsCostParamsV2 events)
        , mkContext V3.mkEvaluationContext (eventsCostParamsV2 events)
+       , mkContext V4.mkEvaluationContext (eventsCostParamsV2 events)
        ) of
-    (Right ctxV1, Right ctxV2, Right ctxV3) ->
-      mapM_ (runSingleEvent ctxV1 ctxV2 ctxV3) (eventsOf events)
-    (Left err, _, _) -> error $ display err
-    (_, Left err, _) -> error $ display err
-    (_, _, Left err) -> error $ display err
+    (Right ctxV1, Right ctxV2, Right ctxV3, Right ctxV4) ->
+      mapM_ (runSingleEvent ctxV1 ctxV2 ctxV3 ctxV4) (eventsOf events)
+    (Left err, _, _, _) -> error $ display err
+    (_, Left err, _, _) -> error $ display err
+    (_, _, Left err, _) -> error $ display err
+    (_, _, _, Left err) -> error $ display err
   where
     mkContext f = \case
       Nothing -> Right Nothing
@@ -478,9 +535,10 @@ analyseOneFile analyse eventFile = do
       :: Maybe (EvaluationContext, [Int64])
       -> Maybe (EvaluationContext, [Int64])
       -> Maybe (EvaluationContext, [Int64])
+      -> Maybe (EvaluationContext, [Int64])
       -> ScriptEvaluationEvent
       -> IO ()
-    runSingleEvent ctxV1 ctxV2 ctxV3 event =
+    runSingleEvent ctxV1 ctxV2 ctxV3 ctxV4 event =
       case event of
         PlutusEvent PlutusV1 _ _ ->
           case ctxV1 of
@@ -494,6 +552,10 @@ analyseOneFile analyse eventFile = do
           case ctxV3 of
             Just (ctx, params) -> analyse ctx params event
             Nothing -> putStrLn "*** ctxV3 missing ***"
+        PlutusEvent PlutusV4 _ _ ->
+          case ctxV4 of
+            Just (ctx, params) -> analyse ctx params event
+            Nothing -> putStrLn "*** ctxV4 missing ***"
 
 main :: IO ()
 main =

plutus-ledger-api/exe/dump-cost-model-parameters/Main.hs

@@ -16,6 +16,7 @@ import PlutusLedgerApi.Common (IsParamName, PlutusLedgerLanguage (..), showParam
 import PlutusLedgerApi.V1 qualified as V1
 import PlutusLedgerApi.V2 qualified as V2
 import PlutusLedgerApi.V3 qualified as V3
+import PlutusLedgerApi.V4 qualified as V4
 
 import Data.Aeson qualified as A (Object, ToJSON, Value (Array, Number))
 import Data.Aeson.Encode.Pretty (encodePretty)
@@ -70,6 +71,7 @@ infoFor =
         PlutusV1 -> (PLC.DefaultFunSemanticsVariantD, paramNames @V1.ParamName)
         PlutusV2 -> (PLC.DefaultFunSemanticsVariantD, paramNames @V2.ParamName)
         PlutusV3 -> (PLC.DefaultFunSemanticsVariantE, paramNames @V3.ParamName)
+        PlutusV4 -> (PLC.DefaultFunSemanticsVariantE, paramNames @V4.ParamName)
 
 -- Return the current cost model parameters for a given LL version in the form
 -- of a list of (name, value) pairs ordered by name according to the relevant

plutus-ledger-api/exe/dump-cost-model-parameters/Parsers.hs

@@ -16,6 +16,7 @@ parseVersion = eitherReader $ \case
   "1" -> Right $ One PlutusV1
   "2" -> Right $ One PlutusV2
   "3" -> Right $ One PlutusV3
+  "4" -> Right $ One PlutusV4
   s -> Left $ "Unknown ledger language version: " ++ s
 
 whichll :: Parser WhichLL

plutus-ledger-api/exe/test-onchain-evaluation/Main.hs

@@ -18,6 +18,7 @@ import Control.Monad.Writer.Strict
 import Data.List.NonEmpty (nonEmpty)
 import Data.Maybe (catMaybes)
 import PlutusLedgerApi.V3.EvaluationContext qualified as V3
+import PlutusLedgerApi.V4.EvaluationContext qualified as V4
 import System.Directory.Extra (listFiles)
 import System.Environment (getEnv)
 import System.FilePath (isExtensionOf, takeBaseName)
@@ -31,23 +32,25 @@ testOneFile eventFile = testCase (takeBaseName eventFile) $ do
   case ( mkContext V1.mkEvaluationContext (eventsCostParamsV1 events)
        , mkContext V2.mkEvaluationContext (eventsCostParamsV2 events)
        , mkContext V3.mkEvaluationContext (eventsCostParamsV2 events)
+       , mkContext V4.mkEvaluationContext (eventsCostParamsV2 events)
        ) of
-    (Right ctxV1, Right ctxV2, Right ctxV3) -> do
+    (Right ctxV1, Right ctxV2, Right ctxV3, Right ctxV4) -> do
       errs <-
         fmap catMaybes $
           mapConcurrently
-            (evaluate . runSingleEvent ctxV1 ctxV2 ctxV3)
+            (evaluate . runSingleEvent ctxV1 ctxV2 ctxV3 ctxV4)
             (eventsOf events)
       whenJust (nonEmpty errs) $ assertFailure . renderTestFailures
-    (Left err, _, _) -> assertFailure $ display err
-    (_, Left err, _) -> assertFailure $ display err
-    (_, _, Left err) -> assertFailure $ display err
+    (Left err, _, _, _) -> assertFailure $ display err
+    (_, Left err, _, _) -> assertFailure $ display err
+    (_, _, Left err, _) -> assertFailure $ display err
+    (_, _, _, Left err) -> assertFailure $ display err
   where
     mkContext f = \case
       Nothing -> Right Nothing
       Just costParams -> Just . (,costParams) . fst <$> runWriterT (f costParams)
 
-    runSingleEvent ctxV1 ctxV2 ctxV3 event =
+    runSingleEvent ctxV1 ctxV2 ctxV3 ctxV4 event =
       case event of
         PlutusEvent PlutusV1 _ _ -> case ctxV1 of
           Just (ctx, params) -> InvalidResult <$> checkEvaluationEvent ctx params event
@@ -58,6 +61,9 @@ testOneFile eventFile = testCase (takeBaseName eventFile) $ do
         PlutusEvent PlutusV3 _ _ -> case ctxV3 of
           Just (ctx, params) -> InvalidResult <$> checkEvaluationEvent ctx params event
           Nothing -> Just $ MissingCostParametersFor PlutusV3
+        PlutusEvent PlutusV4 _ _ -> case ctxV4 of
+          Just (ctx, params) -> InvalidResult <$> checkEvaluationEvent ctx params event
+          Nothing -> Just $ MissingCostParametersFor PlutusV4
 
 main :: IO ()
 main = do

plutus-ledger-api/executables/src/PlutusCore/Executable/Blueprint.hs

@@ -64,6 +64,7 @@ readPlutusVersion = \case
   "v1" -> PlutusV1
   "v2" -> PlutusV2
   "v3" -> PlutusV3
+  "v4" -> PlutusV4
   other -> error $ "Unknown plutusVersion in blueprint: " <> T.unpack other
 
 getPlutusVersion :: Value -> PlutusLedgerLanguage

plutus-ledger-api/plutus-ledger-api.cabal

@@ -104,6 +104,8 @@ library
     PlutusLedgerApi.V4.Data.Address
     PlutusLedgerApi.V4.Data.Contexts
     PlutusLedgerApi.V4.Data.Tx
+    PlutusLedgerApi.V4.EvaluationContext
+    PlutusLedgerApi.V4.ParamName
     PlutusLedgerApi.V4.Tx
 
   other-modules:
@@ -190,6 +192,8 @@ library plutus-ledger-api-testlib
     PlutusLedgerApi.Test.V3.Data.MintValue
     PlutusLedgerApi.Test.V3.EvaluationContext
     PlutusLedgerApi.Test.V3.MintValue
+    PlutusLedgerApi.Test.V4.Data.EvaluationContext
+    PlutusLedgerApi.Test.V4.EvaluationContext
 
   build-depends:
     , barbies

plutus-ledger-api/src/PlutusLedgerApi/Common.hs

@@ -47,6 +47,7 @@ module PlutusLedgerApi.Common
   , Protocol.changPV
   , Protocol.plominPV
   , Protocol.vanRossemPV
+  , Protocol.dijkstraPV
   , Protocol.newestPV
   , Protocol.knownPVs
 

plutus-ledger-api/src/PlutusLedgerApi/Common/Hash.hs

@@ -29,4 +29,5 @@ plutusVersionTag = \case
   PlutusV1 -> 0x1
   PlutusV2 -> 0x2
   PlutusV3 -> 0x3
+  PlutusV4 -> 0x4
 {-# INLINEABLE plutusVersionTag #-}

plutus-ledger-api/src/PlutusLedgerApi/Common/ProtocolVersions.hs

@@ -12,6 +12,7 @@ module PlutusLedgerApi.Common.ProtocolVersions
   , changPV
   , plominPV
   , vanRossemPV
+  , dijkstraPV
   , newestPV
   , knownPVs
   , futurePV
@@ -85,6 +86,10 @@ plominPV = MajorProtocolVersion 10
 vanRossemPV :: MajorProtocolVersion
 vanRossemPV = MajorProtocolVersion 11
 
+-- | The Dijkstra HF will introduce the Dijkstra era and Plutus V4.
+dijkstraPV :: MajorProtocolVersion
+dijkstraPV = MajorProtocolVersion 12
+
 {-| The set of protocol versions that are "known", i.e. that have been released
 and have actual differences associated with them.  This is currently only
 used for testing, so efficiency is not parmount and a list is fine. -}
@@ -99,14 +104,15 @@ knownPVs =
   , changPV
   , plominPV
   , vanRossemPV
+  , dijkstraPV
   ]
 
 -- We're sometimes in an intermediate state where we've added new builtins but
 -- not yet released them (but intend to). This is used by some of the tests to
 -- decide what PVs the test should include.  UPDATE THIS when we're expecting to
 -- release new builtins in a forthcoming PV.
 newestPV :: MajorProtocolVersion
-newestPV = vanRossemPV
+newestPV = dijkstraPV
 
 {-| This is a placeholder for when we don't yet know what protocol version will
   be used for something. It's a very high protocol version that should never
@@ -127,7 +133,8 @@ Here's a table specifying the mapping in full:
 ll
 1       A           B          D
 2       A           B          D
-3       C           C          E
+3       -           C          E
+4       -           -          E? (TBD)
 
 I.e. for example