From 092fb354e7324bd12df52a1d8e1053ba6e0e2c6e Mon Sep 17 00:00:00 2001 From: mmontin Date: Tue, 23 Jun 2026 02:07:16 +0200 Subject: [PATCH] Homogenize optics usage and add traverseTweak Optics ergonomics pass on the library: - Add `traverseTweak`, the effectful sibling of `overTweak`, and use it to replace the repeated view/forM/set triples in the auto-filling tweaks (reference scripts, withdrawal amounts, constitution, min-Ada) with a single call over a composed traversal. - Use NamedFieldPuns instead of a positional `TxSkelOut` match in GenerateTx/Input. - Replace single-call infix optic operators (`^.`, `.~`, `%~`, `^?`) with their prefix equivalents (`view`, `set`, `over`, `preview`) to match the convention documented in doc/OPTICS.md, and express the one chained update in Balancing as a composition of prefix setters. - Rename `beginSearchP` to `beginSearchPure` so its suffix is not mistaken for the `P` (prism) optic-kind suffix. Co-authored-by: Copilot <223556219+Copilot@users.noreply.github.com> --- CHANGELOG.md | 5 +++ doc/CHEATSHEET.md | 2 +- src/Cooked/Attack/DatumHijacking.hs | 4 +-- src/Cooked/MockChain/AutoFilling.hs | 43 ++++++++--------------- src/Cooked/MockChain/Balancing.hs | 3 +- src/Cooked/MockChain/GenerateTx/Input.hs | 6 ++-- src/Cooked/MockChain/GenerateTx/Output.hs | 2 +- src/Cooked/MockChain/State.hs | 2 +- src/Cooked/MockChain/UtxoSearch.hs | 6 ++-- src/Cooked/Pretty/Skeleton.hs | 2 +- src/Cooked/Skeleton/Mint.hs | 2 +- src/Cooked/Tweak/Common.hs | 11 ++++++ src/Cooked/Tweak/Inputs.hs | 4 +-- src/Cooked/Tweak/Outputs.hs | 4 +-- 14 files changed, 49 insertions(+), 47 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index ea782e863..0b3f73c41 100644 --- a/CHANGELOG.md +++ b/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. diff --git a/doc/CHEATSHEET.md b/doc/CHEATSHEET.md index 79006546c..50f942e0f 100644 --- a/doc/CHEATSHEET.md +++ b/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`. diff --git a/src/Cooked/Attack/DatumHijacking.hs b/src/Cooked/Attack/DatumHijacking.hs index b7317fcba..9a638f387 100644 --- a/src/Cooked/Attack/DatumHijacking.hs +++ b/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 diff --git a/src/Cooked/MockChain/AutoFilling.hs b/src/Cooked/MockChain/AutoFilling.hs index c9f789748..2ca1bf582 100644 --- a/src/Cooked/MockChain/AutoFilling.hs +++ b/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,9 +169,9 @@ 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 @@ -189,7 +179,4 @@ toTxSkelOutWithMinAda txSkelOut = do 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 diff --git a/src/Cooked/MockChain/Balancing.hs b/src/Cooked/MockChain/Balancing.hs index f49da44aa..09cc1fd6a 100644 --- a/src/Cooked/MockChain/Balancing.hs +++ b/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. diff --git a/src/Cooked/MockChain/GenerateTx/Input.hs b/src/Cooked/MockChain/GenerateTx/Input.hs index 668412aba..c5a2f39ad 100644 --- a/src/Cooked/MockChain/GenerateTx/Input.hs +++ b/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 diff --git a/src/Cooked/MockChain/GenerateTx/Output.hs b/src/Cooked/MockChain/GenerateTx/Output.hs index 531814378..47ee08471 100644 --- a/src/Cooked/MockChain/GenerateTx/Output.hs +++ b/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 diff --git a/src/Cooked/MockChain/State.hs b/src/Cooked/MockChain/State.hs index fa4c626f3..738726c7f 100644 --- a/src/Cooked/MockChain/State.hs +++ b/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) ) diff --git a/src/Cooked/MockChain/UtxoSearch.hs b/src/Cooked/MockChain/UtxoSearch.hs index a0a2eedd1..92971349c 100644 --- a/src/Cooked/MockChain/UtxoSearch.hs +++ b/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 :: diff --git a/src/Cooked/Pretty/Skeleton.hs b/src/Cooked/Pretty/Skeleton.hs index 35cf89951..980446166 100644 --- a/src/Cooked/Pretty/Skeleton.hs +++ b/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 ] diff --git a/src/Cooked/Skeleton/Mint.hs b/src/Cooked/Skeleton/Mint.hs index 69e39f337..37624e7c1 100644 --- a/src/Cooked/Skeleton/Mint.hs +++ b/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 ) diff --git a/src/Cooked/Tweak/Common.hs b/src/Cooked/Tweak/Common.hs index eef5704e0..9dbe97f6a 100644 --- a/src/Cooked/Tweak/Common.hs +++ b/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 diff --git a/src/Cooked/Tweak/Inputs.hs b/src/Cooked/Tweak/Inputs.hs index ea5941a52..d807eb257 100644 --- a/src/Cooked/Tweak/Inputs.hs +++ b/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 diff --git a/src/Cooked/Tweak/Outputs.hs b/src/Cooked/Tweak/Outputs.hs index 207abdd97..ff88fa7b1 100644 --- a/src/Cooked/Tweak/Outputs.hs +++ b/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