Homogenize optics usage and add traverseTweak

CHANGELOG.md

@@ -4,6 +4,9 @@
 
 ### Added
 
+- New `traverseTweak` primitive, the effectful sibling of `overTweak`: it
+  modifies every focus of an optic on the current `TxSkel` using a function
+  running in the tweak's effect stack.
 - New `withReferenceInput` helper to attach a reference input to a
   `TxSkelRedeemer`, replacing the more verbose
   `set txSkelRedeemerMReferenceInputL (Just …)` idiom.
@@ -12,6 +15,8 @@
 
 ### Changed
 
+- `beginSearchP` has been renamed to `beginSearchPure` to avoid its suffix being
+  mistaken for the `P` (prism) optic-kind suffix.
 - Building a `ParameterChange` governance action containing a `CostModels`
   parameter update now fails with an explicit `MCEUnsupportedFeature` error
   instead of silently ignoring the requested change.

doc/CHEATSHEET.md

@@ -411,7 +411,7 @@ Utxo searches are lists of UTxOs that can be manipulated conveniently.
 
 1. Utxo searches are created using:
   * `beginSearch` from a monadic call returning a list of UTxOs such as `allUtxos`
-  * `beginSearchP` from a pure call returning a list of UTxOs
+  * `beginSearchPure` from a pure call returning a list of UTxOs
 
 2. Some existing UTxO searches are provided builtin such as `utxosAtSearch`,
    `allUtxosSearch` or `txSkelOutByRefSearch`.

src/Cooked/Attack/DatumHijacking.hs

@@ -141,7 +141,7 @@ redirectOutputTweakAll outputPred indexPred = do
     go (out : l) n =
       case outputPred out of
         Nothing -> second (out :) $ go l n
-        Just newOwner | indexPred n -> bimap (out :) ((out & txSkelOutOwnerL .~ toPKHOrVScript newOwner) :) $ go l (n + 1)
+        Just newOwner | indexPred n -> bimap (out :) (set txSkelOutOwnerL (toPKHOrVScript newOwner) out :) $ go l (n + 1)
         _ -> second (out :) $ go l (n + 1)
 
 -- | Redirects, each in their own transaction, all the outputs targetted by an
@@ -169,7 +169,7 @@ redirectOutputTweakAny outputPred indexPred = do
                 newOwner <- outputPred out
                 return $
                   mplus
-                    (return ([out], l' ++ (out & txSkelOutOwnerL .~ toPKHOrVScript newOwner) : l))
+                    (return ([out], l' ++ set txSkelOutOwnerL (toPKHOrVScript newOwner) out : l))
                     (go (l' ++ [out]) (n + 1) l)
             )
     go l' n (out : l) = go (l' ++ [out]) n l

src/Cooked/MockChain/AutoFilling.hs

@@ -32,8 +32,7 @@ autoFillWithdrawalAmounts ::
   (Members '[MockChainRead, Tweak, MockChainLog] effs) =>
   Sem effs ()
 autoFillWithdrawalAmounts = do
-  withdrawals <- viewTweak (txSkelWithdrawalsL % txSkelWithdrawalsListI)
-  newWithdrawals <- forM withdrawals $ \withdrawal -> do
+  traverseTweak (txSkelWithdrawalsL % txSkelWithdrawalsListI % traversed) $ \withdrawal -> do
     currentReward <- getCurrentReward $ view withdrawalUserL withdrawal
     case currentReward of
       Just reward | isn't withdrawalAmountAT withdrawal -> do
@@ -44,7 +43,6 @@ autoFillWithdrawalAmounts = do
             reward
         return newWithdrawal
       _ -> return withdrawal
-  setTweak (txSkelWithdrawalsL % txSkelWithdrawalsListI) newWithdrawals
 
 -- * Auto filling constitution script
 
@@ -60,14 +58,12 @@ autoFillConstitution = do
   case currentConstitution of
     Nothing -> return ()
     Just constitutionScript -> do
-      proposals <- viewTweak txSkelProposalsL
-      newProposals <- forM proposals $ \prop -> do
+      traverseTweak (txSkelProposalsL % traversed) $ \prop -> do
         when (isn't txSkelProposalConstitutionAT prop) $
           logEvent $
             MCLogAutoFilledConstitution $
               Script.toScriptHash constitutionScript
         return (fillConstitution constitutionScript prop)
-      setTweak txSkelProposalsL newProposals
 
 -- * Auto filling reference scripts
 
@@ -112,9 +108,9 @@ autoFillReferenceScripts ::
 autoFillReferenceScripts = do
   inputsKeys <- viewTweak $ txSkelInsL % to Map.keys
   -- Updating minting redeemers
-  mints <- viewTweak $ txSkelMintsL % txSkelMintsListI
-  newMints <- forM mints $ \(Mint rs tks) -> (`Mint` tks) <$> updateRedeemedScript inputsKeys rs
-  setTweak (txSkelMintsL % txSkelMintsListI) newMints
+  traverseTweak
+    (txSkelMintsL % txSkelMintsListI % traversed % mintRedeemedScriptL)
+    (updateRedeemedScript inputsKeys)
   -- Updating spending redeemers
   inputsList <- viewTweak $ txSkelInsL % to Map.toList
   newInputs <- forM inputsList $ \(oRef, red) ->
@@ -125,19 +121,13 @@ autoFillReferenceScripts = do
         Just val -> view userTxSkelRedeemerL <$> updateRedeemedScript inputsKeys (UserRedeemedScript val red)
   setTweak txSkelInsL $ Map.fromList newInputs
   -- Updating proposing redeemers
-  proposals <- viewTweak txSkelProposalsL
-  newProposals <- forM proposals $ \prop ->
-    case preview (txSkelProposalMConstitutionAT % _Just) prop of
-      Nothing -> return prop
-      Just rs -> flip (set (txSkelProposalMConstitutionAT % _Just)) prop <$> updateRedeemedScript inputsKeys rs
-  setTweak txSkelProposalsL newProposals
+  traverseTweak
+    (txSkelProposalsL % traversed % txSkelProposalMConstitutionAT % _Just)
+    (updateRedeemedScript inputsKeys)
   -- Updating widrawing redeemers
-  withdrawals <- viewTweak $ txSkelWithdrawalsL % txSkelWithdrawalsListI
-  newWithdrawals <- forM withdrawals $
-    \withdrawal@(Withdrawal user lv) -> case preview userEitherScriptP user of
-      Nothing -> return withdrawal
-      Just urs -> (`Withdrawal` lv) . review userEitherScriptP <$> updateRedeemedScript inputsKeys urs
-  setTweak (txSkelWithdrawalsL % txSkelWithdrawalsListI) newWithdrawals
+  traverseTweak
+    (txSkelWithdrawalsL % txSkelWithdrawalsListI % traversed % withdrawalUserL % userEitherScriptP)
+    (updateRedeemedScript inputsKeys)
 
 -- * Auto filling min ada amounts
 
@@ -164,7 +154,7 @@ toTxSkelOutWithMinAda ::
   TxSkelOut ->
   Sem effs TxSkelOut
 -- The auto adjustment is disabled so nothing is done here
-toTxSkelOutWithMinAda txSkelOut@((^. txSkelOutValueAutoAdjustL) -> False) = return txSkelOut
+toTxSkelOutWithMinAda txSkelOut@(view txSkelOutValueAutoAdjustL -> False) = return txSkelOut
 -- The auto adjustment is enabled
 toTxSkelOutWithMinAda txSkelOut = do
   txSkelOut' <- go txSkelOut
@@ -179,17 +169,14 @@ toTxSkelOutWithMinAda txSkelOut = do
       requiredAda <- getTxSkelOutMinAda skelOut
       -- If this amount is sufficient, we return Nothing, otherwise, we adjust the
       -- output and possibly iterate
-      if Api.getLovelace (skelOut ^. txSkelOutValueL % valueLovelaceL) >= requiredAda
+      if Api.getLovelace (view (txSkelOutValueL % valueLovelaceL) skelOut) >= requiredAda
         then return skelOut
-        else go $ skelOut & txSkelOutValueL % valueLovelaceL .~ Api.Lovelace requiredAda
+        else go $ set (txSkelOutValueL % valueLovelaceL) (Api.Lovelace requiredAda) skelOut
 
 -- | This goes through all the `TxSkelOut`s of the given skeleton and updates
 -- their ada value when requested by the user and required by the protocol
 -- parameters. Logs an event whenever such a change occurs.
 autoFillMinAda ::
   (Members '[Tweak, MockChainRead, MockChainLog, Error Ledger.ToCardanoError] effs) =>
   Sem effs ()
-autoFillMinAda = do
-  outputs <- viewTweak txSkelOutsL
-  newOutputs <- forM outputs toTxSkelOutWithMinAda
-  setTweak txSkelOutsL newOutputs
+autoFillMinAda = traverseTweak (txSkelOutsL % traversed) toTxSkelOutWithMinAda

src/Cooked/MockChain/Balancing.hs

@@ -26,7 +26,6 @@ import Cooked.MockChain.Read
 import Cooked.MockChain.UtxoSearch
 import Cooked.Skeleton
 import Data.ByteString qualified as BS
-import Data.Function
 import Data.List (find, partition)
 import Data.Map qualified as Map
 import Data.Maybe (fromMaybe)
@@ -492,7 +491,7 @@ computeBalancedTxSkel balancingUser balancingUtxos txSkel@TxSkel {..} (Script.lo
     -- policy forces us to create a new output, both yielding the same result.
     Just (newORefs, Just newTxSkelOut) -> return (newORefs, txSkelOuts ++ [newTxSkelOut])
   let newTxSkelIns = txSkelIns <> Map.fromList ((,emptyTxSkelRedeemer) <$> additionalInsTxOutRefs)
-  return $ (txSkel & txSkelOutsL .~ newTxSkelOuts) & txSkelInsL .~ newTxSkelIns
+  return $ set txSkelInsL newTxSkelIns . set txSkelOutsL newTxSkelOuts $ txSkel
 
 -- | This computes the minimum and maximum possible fee a transaction can cost
 -- based on the current protocol parameters and its number of scripts.

src/Cooked/MockChain/GenerateTx/Input.hs

@@ -22,13 +22,13 @@ toTxInAndWitness ::
       Cardano.BuildTxWith Cardano.BuildTx (Cardano.Witness Cardano.WitCtxTxIn Cardano.ConwayEra)
     )
 toTxInAndWitness (txOutRef, txSkelRedeemer) = do
-  TxSkelOut owner _ datum _ _ _ <- txSkelOutByRef txOutRef
-  witness <- case owner of
+  TxSkelOut {txSkelOutOwner, txSkelOutDatum} <- txSkelOutByRef txOutRef
+  witness <- case txSkelOutOwner of
     UserPubKey _ -> return $ Cardano.KeyWitness Cardano.KeyWitnessForSpending
     UserScript script ->
       fmap (Cardano.ScriptWitness Cardano.ScriptWitnessForSpending) $
         toScriptWitness script txSkelRedeemer $
-          case datum of
+          case txSkelOutDatum of
             NoTxSkelOutDatum -> Cardano.ScriptDatumForTxIn Nothing
             SomeTxSkelOutDatum _ Inline -> Cardano.InlineScriptDatum
             SomeTxSkelOutDatum dat _ -> Cardano.ScriptDatumForTxIn $ Just $ Ledger.toCardanoScriptData $ Api.toBuiltinData dat

src/Cooked/MockChain/GenerateTx/Output.hs

@@ -21,7 +21,7 @@ toCardanoTxOut ::
 toCardanoTxOut output = do
   let oAddress = view txSkelOutAddressG output
       oValue = view txSkelOutValueL output
-      oDatum = output ^. txSkelOutDatumL
+      oDatum = view txSkelOutDatumL output
       oRefScript = view txSkelOutMReferenceScriptL output
   networkId <- Emulator.pNetworkId <$> getParams
   address <- fromEither $ Ledger.toCardanoAddressInEra networkId oAddress

src/Cooked/MockChain/State.hs

@@ -266,7 +266,7 @@ mcstToUtxoState =
               [ UtxoPayload
                   txOutRef
                   (view txSkelOutValueL txSkelOut)
-                  ( case txSkelOut ^. txSkelOutDatumL of
+                  ( case view txSkelOutDatumL txSkelOut of
                       NoTxSkelOutDatum -> NoUtxoPayloadDatum
                       SomeTxSkelOutDatum content kind -> SomeUtxoPayloadDatum content (kind /= Inline)
                   )

src/Cooked/MockChain/UtxoSearch.hs

@@ -5,7 +5,7 @@ module Cooked.MockChain.UtxoSearch
   ( -- * UTxO searches
     UtxoSearch,
     beginSearch,
-    beginSearchP,
+    beginSearchPure,
 
     -- * Processing search result
     UtxoSearchResult,
@@ -76,10 +76,10 @@ beginSearch ::
 beginSearch = fmap (fmap (fmap (`HCons` HEmpty)))
 
 -- | Same as `beginSearch` with a pure input
-beginSearchP ::
+beginSearchPure ::
   Utxos ->
   UtxoSearch effs '[]
-beginSearchP = beginSearch . return
+beginSearchPure = beginSearch . return
 
 -- | Retrieves the `TxSkelOut`s from a `UtxoSearchResult`
 getOutputs ::

src/Cooked/Pretty/Skeleton.hs

@@ -244,7 +244,7 @@ instance PrettyCookedList TxSkelOut where
       prettyCookedOpt opts (view txSkelOutValueL output)
     ]
       ++ catMaybes
-        [ prettyCookedOptMaybe opts (output ^. txSkelOutDatumL),
+        [ prettyCookedOptMaybe opts (view txSkelOutDatumL output),
           ("Reference script:" <+>) . prettyHash opts <$> preview txSkelOutReferenceScriptHashAF output
         ]
 

src/Cooked/Skeleton/Mint.hs

@@ -170,7 +170,7 @@ txSkelMintsListI =
     ( foldl'
         ( \mints (Mint (UserRedeemedScript mp red) tks) ->
             foldl'
-              (\mints' (tk, n) -> mints' & txSkelMintsAssetClassAmountL mp tk %~ (\(_, n') -> (Just red, n + n')))
+              (\mints' (tk, n) -> over (txSkelMintsAssetClassAmountL mp tk) (\(_, n') -> (Just red, n + n')) mints')
               mints
               tks
         )

src/Cooked/Tweak/Common.hs

@@ -21,6 +21,7 @@ module Cooked.Tweak.Common
     viewAllTweak,
     setTweak,
     overTweak,
+    traverseTweak,
     overMaybeTweak,
     overMaybeSelectingTweak,
     combineModsTweak,
@@ -112,6 +113,16 @@ overTweak ::
   Sem effs ()
 overTweak optic change = getTxSkel >>= putTxSkel . over optic change
 
+-- | Like 'overTweak', but the modification of each focus runs in the tweak's
+-- effect stack. The foci are visited in the order in which they occur in the
+-- 'TxSkel'.
+traverseTweak ::
+  (Member Tweak effs, Is k A_Traversal) =>
+  Optic' k is TxSkel a ->
+  (a -> Sem effs a) ->
+  Sem effs ()
+traverseTweak optic change = getTxSkel >>= traverseOf optic change >>= putTxSkel
+
 -- | Like 'overTweak', but only modifies foci on which the argument function
 -- returns @Just@ the new focus. Returns a list of the foci that were modified,
 -- as they were /before/ the tweak, and in the order in which they occurred on

src/Cooked/Tweak/Inputs.hs

@@ -69,6 +69,6 @@ modifySpendRedeemersOfTypeTweak ::
   Sem effs [TxSkelRedeemer]
 modifySpendRedeemersOfTypeTweak f =
   overMaybeTweak (txSkelInsL % iso Map.toList Map.fromList % traversed % _2) $ \red -> do
-    typedRedeemer <- red ^? txSkelRedeemerTypedAT
+    typedRedeemer <- preview txSkelRedeemerTypedAT red
     typedRedeemerModified <- f typedRedeemer
-    return $ red & txSkelRedeemerTypedAT @a .~ typedRedeemerModified
+    return $ set (txSkelRedeemerTypedAT @a) typedRedeemerModified red

src/Cooked/Tweak/Outputs.hs

@@ -119,9 +119,9 @@ malformDatumTweak change = do
     changeOutput :: TxSkelOut -> [TxSkelOut]
     changeOutput txSkelOut =
       do
-        typedDat <- maybeToList $ txSkelOut ^? txSkelOutDatumL % txSkelOutDatumTypedAT
+        typedDat <- maybeToList $ preview (txSkelOutDatumL % txSkelOutDatumTypedAT) txSkelOut
         modifiedDat <- change typedDat
-        return $ txSkelOut & txSkelOutDatumL % txSkelOutDatumTypedAT @a .~ modifiedDat
+        return $ set (txSkelOutDatumL % txSkelOutDatumTypedAT @a) modifiedDat txSkelOut
 
 -- | A label added to a 'TxSkel' on which the 'malformDatumTweak' has been
 -- successfully applied