Add labeled helper, remove withModification

Author: axman6

src/Cooked/MockChain/Staged.hs

@@ -17,15 +17,15 @@ module Cooked.MockChain.Staged
     everywhere,
     everywhere',
     withTweak,
-    withModification,
     there,
     there',
+    labeled,
   )
 where
 
 import Cardano.Node.Emulator qualified as Emulator
 import Control.Applicative
-import Control.Monad (MonadPlus (..), msum)
+import Control.Monad (MonadPlus (..), guard, msum)
 import Control.Monad.Except
 import Control.Monad.Reader
 import Control.Monad.State
@@ -37,6 +37,7 @@ import Cooked.Pretty.Hashable
 import Cooked.Skeleton
 import Cooked.Tweak.Common
 import Data.Default
+import Data.Set qualified as Set
 import Ledger.Slot qualified as Ledger
 import Ledger.Tx qualified as Ledger
 import Plutus.Script.Utils.Address qualified as Script
@@ -191,6 +192,27 @@ everywhere' ltl = modifyLtl (LtlRelease LtlFalsity ltl)
 there :: (MonadModalBlockChain m) => Integer -> Tweak InterpMockChain b -> m a -> m a
 there n = there' n . LtlAtom . UntypedTweak
 
+-- | Apply a tweak to every transaction which has a specific label. This can
+-- be useful to apply a tweak to every transaction in a set of associated
+-- transactions.
+--
+-- >
+-- > someEndpoint = do
+-- >   ..
+-- >   validateTxSkel' txSkelTemplate
+-- >      { txSkelLabels =
+-- >         [TxSkelLabel @Text "InitialMinting", TxSkelLabel @Text "AuctionWorkflow"]
+-- >      }
+-- >
+-- > someTest = someEndpoint & labled @Text "InitialMinting" someTweak
+labeled :: (LabelConstrs lbl, MonadModalBlockChain m) => lbl -> Tweak InterpMockChain b -> m a -> m a
+labeled lbl tweak = everywhere (hasLabel >> tweak)
+  where
+    hasLabel = do
+      -- using 'hasLabelTweak' causes a cyclic dependency
+      lbls <- viewTweak txSkelLabelL
+      guard (Set.member (TxSkelLabel lbl) lbls)
+
 -- | Apply an Ltl modification to the (0-indexed) nth transaction in a
 -- given trace. Successful when this transaction exists and can be modified.
 there' :: (MonadModal m) => Integer -> Ltl (Modification m) -> m a -> m a
@@ -210,10 +232,6 @@ there' n ltl = modifyLtl (ltlDelay n ltl)
 withTweak :: (MonadModalBlockChain m) => m x -> Tweak InterpMockChain a -> m x
 withTweak = flip (there 0)
 
--- | Apply modification to the next transaction in a given trace. See 'withTweak'
-withModification :: (MonadModal m) => m a -> Ltl (Modification m) -> m a
-withModification = flip (there' 0)
-
 -- * 'MonadBlockChain' and 'MonadMockChain' instances
 
 singletonBuiltin :: builtin a -> Staged (LtlOp modification builtin) a