Fix conditional execution of rules whenever there is already predicat…

…e failure.

In #2679 we got an implmentation of conditional execution. The intent
was to prevent running some expensive predicate checks whenever there is
already at least one existing predicate failure. That PR did not account
for the fact that rules are executed in a recursive function and the
state that carries information about predicate failures is not shared
between each invocation. In other words, whenever one STS rule called
another (eg. UTXOW calling UTXO), the invoked STS rules would be
oblivious to previous failures.

libs/cardano-ledger-test/src/Test/Cardano/Ledger/Examples/BabbageFeatures.hs

@@ -1073,12 +1073,23 @@ genericBabbageFeatures pf =
             testU
               pf
               (trustMeP pf True $ malformedScriptRefTx pf)
-              (Left [fromUtxowB @era (MalformedReferenceScripts (Set.fromList [hashScript @era $ malformedScript pf "rs"]))]),
+              ( Left
+                  [ fromUtxowB @era $
+                      MalformedReferenceScripts $
+                        Set.singleton
+                          (hashScript @era $ malformedScript pf "rs")
+                  ]
+              ),
           testCase "malformed script witness" $
             testU
               pf
               (trustMeP pf True $ malformedScriptWitTx pf)
-              (Left [fromUtxowB @era (MalformedScriptWitnesses (Set.fromList [hashScript @era $ malformedScript pf "malfoy"]))]),
+              ( Left
+                  [ fromUtxowB @era $
+                      MalformedScriptWitnesses $
+                        Set.singleton (hashScript @era $ malformedScript pf "malfoy")
+                  ]
+              ),
           testCase "inline datum and ref script and redundant script witness" $
             testU
               pf

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

@@ -84,11 +84,11 @@ where
 
 import Control.Exception (Exception (..), throw)
 import Control.Monad (when)
-import Control.Monad.Free.Church
+import Control.Monad.Free.Church (F, MonadFree (wrap), foldF, liftF)
 import Control.Monad.Identity (Identity (..))
 import Control.Monad.State.Class (MonadState (..), modify)
-import Control.Monad.Trans.Class (MonadTrans, lift)
-import Control.Monad.Trans.Except
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
 import Control.Monad.Trans.State.Strict (StateT (..))
 import Data.Bifunctor (Bifunctor (second), first)
 import Data.Coerce (Coercible, coerce)
@@ -102,7 +102,15 @@ import qualified Data.List.NonEmpty as NE
 import Data.Typeable (typeRep)
 import Data.Void (Void)
 import NoThunks.Class (NoThunks (..))
-import Validation
+import Validation (Validation (..), eitherToValidation)
+
+-- | In order to avoid boolean blindness we create specialized type for the
+-- concept of any rule having information about overall state of the nested
+-- clause.
+data IsFailing
+  = Failing
+  | NotFailing
+  deriving (Eq, Show)
 
 data RuleType
   = Initial
@@ -475,14 +483,14 @@ applySTSOpts ::
   RuleContext rtype s ->
   m (EventReturnType ep s (State s, [PredicateFailure s]))
 applySTSOpts ApplySTSOpts {asoAssertions, asoValidation, asoEvents} ctx =
-  let goRule :: RuleInterpreter ep
-      goRule = applyRuleInternal asoEvents asoValidation goSTS
-      goSTS :: STSInterpreter ep
-      goSTS c =
-        runExceptT (applySTSInternal asoEvents asoAssertions goRule c) >>= \case
+  let goRule :: IsFailing -> RuleInterpreter ep
+      goRule isFailing = applyRuleInternal isFailing asoEvents asoValidation goSTS
+      goSTS :: IsFailing -> STSInterpreter ep
+      goSTS isFailing c =
+        runExceptT (applySTSInternal asoEvents asoAssertions (goRule isFailing) c) >>= \case
           Left err -> throw $! AssertionException err
           Right res -> pure $! res
-   in goSTS ctx
+   in goSTS NotFailing ctx
 
 applySTSOptsEither ::
   forall s m rtype ep.
@@ -563,34 +571,38 @@ applySTSIndifferently =
 applyRuleInternal ::
   forall (ep :: EventPolicy) s m rtype.
   (STS s, RuleTypeRep rtype, m ~ BaseM s) =>
+  -- | We need to know if the current STS incurred at least one
+  -- PredicateFailure.  This is necessary because `applyRuleInternal` is called
+  -- recursively through the @goSTS@ argument, which will not have access to any
+  -- of the predicate failures occured in other branches of STS rule execusion tree.
+  IsFailing ->
   SingEP ep ->
   ValidationPolicy ->
   -- | Interpreter for subsystems
-  STSInterpreter ep ->
+  (IsFailing -> STSInterpreter ep) ->
   RuleContext rtype s ->
   Rule s rtype (State s) ->
   m (EventReturnType ep s (State s, [PredicateFailure s]))
-applyRuleInternal ep vp goSTS jc r = do
+applyRuleInternal isAlreadyFailing ep vp goSTS jc r = do
   (s, er) <- flip runStateT ([], []) $ foldF runClause r
   case ep of
     EPDiscard -> pure (s, fst er)
     EPReturn -> pure ((s, fst er), snd er)
   where
-    runClause ::
-      forall f t a.
-      ( f ~ t m,
-        MonadState ([PredicateFailure s], [Event s]) f,
-        MonadTrans t
-      ) =>
-      Clause s rtype a ->
-      t m a
+    isFailing :: StateT ([PredicateFailure s], [Event s]) m IsFailing
+    isFailing =
+      case isAlreadyFailing of
+        Failing -> pure Failing
+        NotFailing -> do
+          isFailingNow <- null . fst <$> get
+          pure $ if isFailingNow then Failing else NotFailing
+    runClause :: Clause s rtype a -> StateT ([PredicateFailure s], [Event s]) m a
     runClause (Lift f next) = next <$> lift f
     runClause (GetCtx next) = pure $ next jc
-    runClause (IfFailureFree yesrule norule) = do
-      failureFree <- null . fst <$> get
-      if failureFree
-        then foldF runClause yesrule
-        else foldF runClause norule
+    runClause (IfFailureFree notFailingRule failingRule) = do
+      isFailing >>= \case
+        Failing -> foldF runClause failingRule
+        NotFailing -> foldF runClause notFailingRule
     runClause (Predicate cond orElse val) =
       case vp of
         ValidateNone -> pure val
@@ -602,7 +614,8 @@ applyRuleInternal ep vp goSTS jc r = do
         then foldF runClause subrule
         else pure val
     runClause (SubTrans (subCtx :: RuleContext _rtype sub) next) = do
-      s <- lift $ goSTS subCtx
+      isFailingNow <- isFailing
+      s <- lift $ goSTS isFailingNow subCtx
       let ss :: State sub
           sfails :: [PredicateFailure sub]
           sevs :: [Event sub]