WIP commit message.

eras/alonzo/impl/src/Cardano/Ledger/Alonzo/Rules/Utxos.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -24,7 +25,7 @@ module Cardano.Ledger.Alonzo.Rules.Utxos
     invalidBegin,
     invalidEnd,
     UtxosEvent (..),
-    (?!##),
+    when2Phase,
     ConcreteAlonzo,
     FailureDescription (..),
     scriptFailuresToPredicateFailure,
@@ -192,10 +193,10 @@ scriptsValidateTransition = do
 
   case collectTwoPhaseScriptInputs ei sysSt pp tx utxo of
     Right sLst ->
-      case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of
+      when2Phase $ case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of
         Fails _ps fs ->
-          False
-            ?!## ValidationTagMismatch
+          failBecause $
+            ValidationTagMismatch
               (getField @"isValid" tx)
               (FailedUnexpectedly (scriptFailuresToPredicateFailure fs))
         Passes ps -> tellEvent (SuccessfulPlutusScriptsEvent ps)
@@ -229,11 +230,14 @@ scriptsNotValidateTransition = do
   case collectTwoPhaseScriptInputs ei sysSt pp tx utxo of
     Right sLst ->
       whenFailureFree $
-        case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of
-          Passes _ps -> False ?!## ValidationTagMismatch (getField @"isValid" tx) PassedUnexpectedly
-          Fails ps fs -> do
-            tellEvent (SuccessfulPlutusScriptsEvent ps)
-            tellEvent (FailedPlutusScriptsEvent (scriptFailuresToPlutusDebug fs))
+        when2Phase $
+          case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of
+            Passes _ps ->
+              failBecause $
+                ValidationTagMismatch (getField @"isValid" tx) PassedUnexpectedly
+            Fails ps fs -> do
+              tellEvent (SuccessfulPlutusScriptsEvent ps)
+              tellEvent (FailedPlutusScriptsEvent (scriptFailuresToPlutusDebug fs))
     Left info -> failBecause (CollectErrors info)
 
   let !_ = traceEvent invalidEnd ()
@@ -437,10 +441,8 @@ lbl2Phase = "2phase"
 -- | Construct a 2-phase predicate check.
 --
 --   Note that 2-phase predicate checks are by definition static.
-(?!##) :: Bool -> PredicateFailure sts -> Rule sts ctx ()
-(?!##) = labeledPred [lblStatic, lbl2Phase]
-
-infix 1 ?!##
+when2Phase :: Rule sts ctx () -> Rule sts ctx ()
+when2Phase = labeled [lblStatic, lbl2Phase]
 
 -- =========================================================
 -- Inject instances

eras/babbage/impl/src/Cardano/Ledger/Babbage/Rules/Utxos.hs

@@ -168,13 +168,14 @@ scriptsYes = do
     Right sLst ->
       {- isValid tx = evalScripts tx sLst = True -}
       whenFailureFree $
-        case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of
-          Fails _ fs ->
-            False
-              ?!## ValidationTagMismatch
-                (getField @"isValid" tx)
-                (FailedUnexpectedly (scriptFailuresToPredicateFailure fs))
-          Passes _ -> pure ()
+        when2Phase $
+          case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of
+            Fails _ fs ->
+              failBecause $
+                ValidationTagMismatch
+                  (getField @"isValid" tx)
+                  (FailedUnexpectedly (scriptFailuresToPredicateFailure fs))
+            Passes _ -> pure ()
     Left info -> failBecause (CollectErrors info)
 
   let !_ = traceEvent validEnd ()
@@ -203,8 +204,8 @@ scriptsNo = do
     Right sLst ->
       {- sLst := collectTwoPhaseScriptInputs pp tx utxo -}
       {- isValid tx = evalScripts tx sLst = False -}
-      case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of
-        Passes _ -> False ?!## ValidationTagMismatch (getField @"isValid" tx) PassedUnexpectedly
+      when2Phase $ case evalScripts @era (getField @"_protocolVersion" pp) tx sLst of
+        Passes _ -> failBecause $ ValidationTagMismatch (getField @"isValid" tx) PassedUnexpectedly
         Fails ps fs -> do
           tellEvent (SuccessfulPlutusScriptsEvent ps)
           tellEvent (FailedPlutusScriptsEvent (scriptFailuresToPlutusDebug fs))

libs/small-steps/src/Control/State/Transition/Extended.hs

@@ -45,6 +45,7 @@ module Control.State.Transition.Extended
     SingEP (..),
     EventPolicy (..),
     EventReturnType,
+    labeled,
     labeledPred,
     labeledPredE,
     ifFailureFree,
@@ -314,12 +315,18 @@ data Clause sts (rtype :: RuleType) a where
     a ->
     Clause sts rtype a
   Predicate ::
-    [Label] ->
     Validation (NonEmpty e) a ->
     -- Type of failure to return if the predicate fails
     (e -> PredicateFailure sts) ->
     a ->
     Clause sts rtype a
+  -- | Label part of a rule. The interpreter may be configured to only run parts
+  -- of rules governed by (or by the lack of) certain labels.
+  Label ::
+    [Label] ->
+    Rule sts rtype a ->
+    a ->
+    Clause sts rtype a
   IfFailureFree :: Rule sts rtype a -> Rule sts rtype a -> Clause sts rtype a
 
 deriving instance Functor (Clause sts rtype)
@@ -341,7 +348,7 @@ validateTrans ::
   (e -> PredicateFailure sts) ->
   Validation (NonEmpty e) () ->
   Rule sts ctx ()
-validateTrans t v = liftF $ Predicate [] v t ()
+validateTrans t v = liftF $ Label [] (liftF $ Predicate v t ()) ()
 
 -- | Same as `validation`, except with ability to translate opaque failures
 -- into `PredicateFailure`s with a help of supplied function.
@@ -353,7 +360,7 @@ validateTransLabeled ::
   -- | Actual validations to be executed
   Validation (NonEmpty e) () ->
   Rule sts ctx ()
-validateTransLabeled t labels v = liftF $ Predicate labels v t ()
+validateTransLabeled t labels v = liftF $ Label labels (liftF $ Predicate v t ()) ()
 
 -- | Oh noes!
 --
@@ -377,12 +384,14 @@ failBecause = (False ?!)
 -- using 'ValidateSuchThat'.
 labeledPred :: [Label] -> Bool -> PredicateFailure sts -> Rule sts ctx ()
 labeledPred lbls cond orElse =
-  liftF $
-    Predicate
-      lbls
-      (if cond then Success () else Failure (() :| []))
-      (const orElse)
-      ()
+  labeled
+    lbls
+    ( liftF $
+        Predicate
+          (if cond then Success () else Failure (() :| []))
+          (const orElse)
+          ()
+    )
 
 -- | Labeled predicate with an explanation
 labeledPredE ::
@@ -391,7 +400,14 @@ labeledPredE ::
   (e -> PredicateFailure sts) ->
   Rule sts ctx ()
 labeledPredE lbls cond orElse =
-  liftF $ Predicate lbls (eitherToValidation $ first pure cond) orElse ()
+  labeled
+    lbls
+    (liftF $ Predicate (eitherToValidation $ first pure cond) orElse ())
+
+-- | Labeled clause. This will only be executed if the interpreter is set to
+-- execute clauses with this label.
+labeled :: [Label] -> Rule sts ctx () -> Rule sts ctx ()
+labeled lbls subrule = liftF $ Label lbls subrule ()
 
 trans ::
   Embed sub super => RuleContext rtype sub -> Rule super rtype (State sub)
@@ -582,11 +598,13 @@ applyRuleInternal ep vp goSTS jc r = do
       if failureFree
         then foldF runClause yesrule
         else foldF runClause norule
-    runClause (Predicate lbls cond orElse val) =
+    runClause (Predicate cond orElse val) =
+      case cond of
+        Success x -> pure x
+        Failure errs -> modify (first (map orElse (reverse (NE.toList errs)) <>)) >> pure val
+    runClause (Label lbls subrule val) =
       if validateIf lbls
-        then case cond of
-          Success x -> pure x
-          Failure errs -> modify (first (map orElse (reverse (NE.toList errs)) <>)) >> pure val
+        then foldF runClause subrule
         else pure val
     runClause (SubTrans (subCtx :: RuleContext _rtype sub) next) = do
       s <- lift $ goSTS subCtx