module Cooked.MockChain.AutoFilling where
import Cardano.Api qualified as Cardano
import Cardano.Ledger.Shelley.Core qualified as Shelley
import Cardano.Node.Emulator.Internal.Node.Params qualified as Emulator
import Control.Monad
import Cooked.MockChain.GenerateTx.Output
import Cooked.MockChain.Log
import Cooked.MockChain.Read
import Cooked.MockChain.UtxoSearch
import Cooked.Skeleton
import Cooked.Tweak.Common
import Data.List (find)
import Data.Map qualified as Map
import Ledger.Tx qualified as P.Ledger
import Optics.Core
import Plutus.Script.Utils.Address qualified as Script
import Plutus.Script.Utils.Scripts qualified as Script
import PlutusLedgerApi.V3 qualified as Api
import Polysemy
import Polysemy.Error
autoFillWithdrawalAmounts ::
(Members '[MockChainRead, Tweak, MockChainLog] effs) =>
Sem effs ()
autoFillWithdrawalAmounts :: forall (effs :: EffectRow).
Members '[MockChainRead, Tweak, MockChainLog] effs =>
Sem effs ()
autoFillWithdrawalAmounts = do
Optic' A_Traversal '[] TxSkel Withdrawal
-> (Withdrawal -> Sem effs Withdrawal) -> Sem effs ()
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Traversal) =>
Optic' k is TxSkel a -> (a -> Sem effs a) -> Sem effs ()
traverseTweak (Lens' TxSkel TxSkelWithdrawals
txSkelWithdrawalsL Lens' TxSkel TxSkelWithdrawals
-> Optic
An_Iso
'[]
TxSkelWithdrawals
TxSkelWithdrawals
[Withdrawal]
[Withdrawal]
-> Optic A_Lens '[] TxSkel TxSkel [Withdrawal] [Withdrawal]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
An_Iso
'[]
TxSkelWithdrawals
TxSkelWithdrawals
[Withdrawal]
[Withdrawal]
txSkelWithdrawalsListI Optic A_Lens '[] TxSkel TxSkel [Withdrawal] [Withdrawal]
-> Optic
A_Traversal '[] [Withdrawal] [Withdrawal] Withdrawal Withdrawal
-> Optic' A_Traversal '[] TxSkel Withdrawal
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
A_Traversal '[] [Withdrawal] [Withdrawal] Withdrawal Withdrawal
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed) ((Withdrawal -> Sem effs Withdrawal) -> Sem effs ())
-> (Withdrawal -> Sem effs Withdrawal) -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ \Withdrawal
withdrawal -> do
Maybe Lovelace
currentReward <- User 'IsEither 'Redemption -> Sem effs (Maybe Lovelace)
forall (effs :: EffectRow) c.
(Member MockChainRead effs, ToCredential c) =>
c -> Sem effs (Maybe Lovelace)
getCurrentReward (User 'IsEither 'Redemption -> Sem effs (Maybe Lovelace))
-> User 'IsEither 'Redemption -> Sem effs (Maybe Lovelace)
forall a b. (a -> b) -> a -> b
$ Optic' A_Lens '[] Withdrawal (User 'IsEither 'Redemption)
-> Withdrawal -> User 'IsEither 'Redemption
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] Withdrawal (User 'IsEither 'Redemption)
withdrawalUserL Withdrawal
withdrawal
case Maybe Lovelace
currentReward of
Just Lovelace
reward | Optic' An_AffineTraversal '[] Withdrawal Lovelace
-> Withdrawal -> Bool
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Bool
isn't Optic' An_AffineTraversal '[] Withdrawal Lovelace
withdrawalAmountAT Withdrawal
withdrawal -> do
let newWithdrawal :: Withdrawal
newWithdrawal = Lovelace -> Withdrawal -> Withdrawal
fillAmount Lovelace
reward Withdrawal
withdrawal
MockChainLogEntry -> Sem effs ()
forall (effs :: EffectRow).
Member MockChainLog effs =>
MockChainLogEntry -> Sem effs ()
logEvent (MockChainLogEntry -> Sem effs ())
-> MockChainLogEntry -> Sem effs ()
forall a b. (a -> b) -> a -> b
$
Credential -> Lovelace -> MockChainLogEntry
MCLogAutoFilledWithdrawalAmount
(Optic' A_Getter '[] Withdrawal Credential
-> Withdrawal -> Credential
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Optic' A_Lens '[] Withdrawal (User 'IsEither 'Redemption)
withdrawalUserL Optic' A_Lens '[] Withdrawal (User 'IsEither 'Redemption)
-> Optic
A_Getter
'[]
(User 'IsEither 'Redemption)
(User 'IsEither 'Redemption)
Credential
Credential
-> Optic' A_Getter '[] Withdrawal Credential
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (User 'IsEither 'Redemption -> Credential)
-> Optic
A_Getter
'[]
(User 'IsEither 'Redemption)
(User 'IsEither 'Redemption)
Credential
Credential
forall s a. (s -> a) -> Getter s a
to User 'IsEither 'Redemption -> Credential
forall a. ToCredential a => a -> Credential
Script.toCredential) Withdrawal
newWithdrawal)
Lovelace
reward
Withdrawal -> Sem effs Withdrawal
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return Withdrawal
newWithdrawal
Maybe Lovelace
_ -> Withdrawal -> Sem effs Withdrawal
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return Withdrawal
withdrawal
autoFillConstitution ::
(Members '[MockChainRead, Tweak, MockChainLog] effs) =>
Sem effs ()
autoFillConstitution :: forall (effs :: EffectRow).
Members '[MockChainRead, Tweak, MockChainLog] effs =>
Sem effs ()
autoFillConstitution = do
Maybe VScript
currentConstitution <- Sem effs (Maybe VScript)
forall (effs :: EffectRow).
Member MockChainRead effs =>
Sem effs (Maybe VScript)
getConstitutionScript
case Maybe VScript
currentConstitution of
Maybe VScript
Nothing -> () -> Sem effs ()
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just VScript
constitutionScript -> do
Optic' A_Traversal '[] TxSkel TxSkelProposal
-> (TxSkelProposal -> Sem effs TxSkelProposal) -> Sem effs ()
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Traversal) =>
Optic' k is TxSkel a -> (a -> Sem effs a) -> Sem effs ()
traverseTweak (Lens' TxSkel [TxSkelProposal]
txSkelProposalsL Lens' TxSkel [TxSkelProposal]
-> Optic
A_Traversal
'[]
[TxSkelProposal]
[TxSkelProposal]
TxSkelProposal
TxSkelProposal
-> Optic' A_Traversal '[] TxSkel TxSkelProposal
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
A_Traversal
'[]
[TxSkelProposal]
[TxSkelProposal]
TxSkelProposal
TxSkelProposal
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed) ((TxSkelProposal -> Sem effs TxSkelProposal) -> Sem effs ())
-> (TxSkelProposal -> Sem effs TxSkelProposal) -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ \TxSkelProposal
prop -> do
Bool -> Sem effs () -> Sem effs ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Optic'
An_AffineTraversal '[] TxSkelProposal (User 'IsScript 'Redemption)
-> TxSkelProposal -> Bool
forall k (is :: IxList) s a.
Is k An_AffineFold =>
Optic' k is s a -> s -> Bool
isn't Optic'
An_AffineTraversal '[] TxSkelProposal (User 'IsScript 'Redemption)
txSkelProposalConstitutionAT TxSkelProposal
prop) (Sem effs () -> Sem effs ()) -> Sem effs () -> Sem effs ()
forall a b. (a -> b) -> a -> b
$
MockChainLogEntry -> Sem effs ()
forall (effs :: EffectRow).
Member MockChainLog effs =>
MockChainLogEntry -> Sem effs ()
logEvent (MockChainLogEntry -> Sem effs ())
-> MockChainLogEntry -> Sem effs ()
forall a b. (a -> b) -> a -> b
$
ScriptHash -> MockChainLogEntry
MCLogAutoFilledConstitution (ScriptHash -> MockChainLogEntry)
-> ScriptHash -> MockChainLogEntry
forall a b. (a -> b) -> a -> b
$
VScript -> ScriptHash
forall a. ToScriptHash a => a -> ScriptHash
Script.toScriptHash VScript
constitutionScript
TxSkelProposal -> Sem effs TxSkelProposal
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (VScript -> TxSkelProposal -> TxSkelProposal
forall script.
(ToVScript script, Typeable script) =>
script -> TxSkelProposal -> TxSkelProposal
fillConstitution VScript
constitutionScript TxSkelProposal
prop)
updateRedeemedScript ::
(Members '[MockChainLog, MockChainRead] effs) =>
[Api.TxOutRef] ->
User IsScript Redemption ->
Sem effs (User IsScript Redemption)
updateRedeemedScript :: forall (effs :: EffectRow).
Members '[MockChainLog, MockChainRead] effs =>
[TxOutRef]
-> User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption)
updateRedeemedScript
[TxOutRef]
inputs
rs :: User 'IsScript 'Redemption
rs@( UserRedeemedScript
(script -> VScript
forall script. ToVScript script => script -> VScript
toVScript -> VScript
vScript)
txSkelRed :: TxSkelRedeemer
txSkelRed@(TxSkelRedeemer {txSkelRedeemerAutoFill :: TxSkelRedeemer -> Bool
txSkelRedeemerAutoFill = Bool
True})
) = do
[TxOutRef]
oRefsInInputs <- Sem effs (UtxoSearchResult '[]) -> Sem effs [TxOutRef]
forall (effs :: EffectRow) (elems :: IxList).
Sem effs (UtxoSearchResult elems) -> Sem effs [TxOutRef]
getTxOutRefs (Sem effs (UtxoSearchResult '[]) -> Sem effs [TxOutRef])
-> Sem effs (UtxoSearchResult '[]) -> Sem effs [TxOutRef]
forall a b. (a -> b) -> a -> b
$ (Sem effs (UtxoSearchResult '[])
-> Sem effs (UtxoSearchResult '[]))
-> Sem effs (UtxoSearchResult '[])
forall (effs :: EffectRow) (els :: IxList).
Member MockChainRead effs =>
(UtxoSearch effs '[] -> UtxoSearch effs els) -> UtxoSearch effs els
allUtxosSearch ((Sem effs (UtxoSearchResult '[])
-> Sem effs (UtxoSearchResult '[]))
-> Sem effs (UtxoSearchResult '[]))
-> (Sem effs (UtxoSearchResult '[])
-> Sem effs (UtxoSearchResult '[]))
-> Sem effs (UtxoSearchResult '[])
forall a b. (a -> b) -> a -> b
$ VScript
-> Sem effs (UtxoSearchResult '[])
-> Sem effs (UtxoSearchResult '[])
forall s (effs :: EffectRow) (els :: IxList).
ToScriptHash s =>
s -> UtxoSearch effs els -> UtxoSearch effs els
ensureProperReferenceScript VScript
vScript
Sem effs (User 'IsScript 'Redemption)
-> (TxOutRef -> Sem effs (User 'IsScript 'Redemption))
-> Maybe TxOutRef
-> Sem effs (User 'IsScript 'Redemption)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(User 'IsScript 'Redemption -> Sem effs (User 'IsScript 'Redemption)
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return User 'IsScript 'Redemption
rs)
( \TxOutRef
oRef -> do
MockChainLogEntry -> Sem effs ()
forall (effs :: EffectRow).
Member MockChainLog effs =>
MockChainLogEntry -> Sem effs ()
logEvent (MockChainLogEntry -> Sem effs ())
-> MockChainLogEntry -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ TxSkelRedeemer -> TxOutRef -> ScriptHash -> MockChainLogEntry
MCLogAddedReferenceScript TxSkelRedeemer
txSkelRed TxOutRef
oRef (VScript -> ScriptHash
forall a. ToScriptHash a => a -> ScriptHash
Script.toScriptHash VScript
vScript)
User 'IsScript 'Redemption -> Sem effs (User 'IsScript 'Redemption)
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return (User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption))
-> User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption)
forall a b. (a -> b) -> a -> b
$ Optic
An_AffineTraversal
'[]
(User 'IsScript 'Redemption)
(User 'IsScript 'Redemption)
TxSkelRedeemer
TxSkelRedeemer
-> (TxSkelRedeemer -> TxSkelRedeemer)
-> User 'IsScript 'Redemption
-> User 'IsScript 'Redemption
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over Optic
An_AffineTraversal
'[]
(User 'IsScript 'Redemption)
(User 'IsScript 'Redemption)
TxSkelRedeemer
TxSkelRedeemer
forall (kind :: UserKind) (mode :: UserMode).
AffineTraversal' (User kind mode) TxSkelRedeemer
userTxSkelRedeemerAT (TxOutRef -> TxSkelRedeemer -> TxSkelRedeemer
fillReferenceInput TxOutRef
oRef) User 'IsScript 'Redemption
rs
)
(Maybe TxOutRef -> Sem effs (User 'IsScript 'Redemption))
-> Maybe TxOutRef -> Sem effs (User 'IsScript 'Redemption)
forall a b. (a -> b) -> a -> b
$ case [TxOutRef]
oRefsInInputs of
[] -> Maybe TxOutRef
forall a. Maybe a
Nothing
[TxOutRef]
l | Just TxOutRef
oRefM' <- (TxOutRef -> Bool) -> [TxOutRef] -> Maybe TxOutRef
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (TxOutRef -> [TxOutRef] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [TxOutRef]
inputs) [TxOutRef]
l -> TxOutRef -> Maybe TxOutRef
forall a. a -> Maybe a
Just TxOutRef
oRefM'
(TxOutRef
oRefM' : [TxOutRef]
_) -> TxOutRef -> Maybe TxOutRef
forall a. a -> Maybe a
Just TxOutRef
oRefM'
updateRedeemedScript [TxOutRef]
_ User 'IsScript 'Redemption
rs = User 'IsScript 'Redemption -> Sem effs (User 'IsScript 'Redemption)
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return User 'IsScript 'Redemption
rs
autoFillReferenceScripts ::
(Members '[Tweak, MockChainRead, MockChainLog] effs) =>
Sem effs ()
autoFillReferenceScripts :: forall (effs :: EffectRow).
Members '[Tweak, MockChainRead, MockChainLog] effs =>
Sem effs ()
autoFillReferenceScripts = do
[TxOutRef]
inputsKeys <- Optic' A_Getter '[] TxSkel [TxOutRef] -> Sem effs [TxOutRef]
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Getter) =>
Optic' k is TxSkel a -> Sem effs a
viewTweak (Optic' A_Getter '[] TxSkel [TxOutRef] -> Sem effs [TxOutRef])
-> Optic' A_Getter '[] TxSkel [TxOutRef] -> Sem effs [TxOutRef]
forall a b. (a -> b) -> a -> b
$ Lens' TxSkel (Map TxOutRef TxSkelRedeemer)
txSkelInsL Lens' TxSkel (Map TxOutRef TxSkelRedeemer)
-> Optic
A_Getter
'[]
(Map TxOutRef TxSkelRedeemer)
(Map TxOutRef TxSkelRedeemer)
[TxOutRef]
[TxOutRef]
-> Optic' A_Getter '[] TxSkel [TxOutRef]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (Map TxOutRef TxSkelRedeemer -> [TxOutRef])
-> Optic
A_Getter
'[]
(Map TxOutRef TxSkelRedeemer)
(Map TxOutRef TxSkelRedeemer)
[TxOutRef]
[TxOutRef]
forall s a. (s -> a) -> Getter s a
to Map TxOutRef TxSkelRedeemer -> [TxOutRef]
forall k a. Map k a -> [k]
Map.keys
Optic' A_Traversal '[] TxSkel (User 'IsScript 'Redemption)
-> (User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption))
-> Sem effs ()
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Traversal) =>
Optic' k is TxSkel a -> (a -> Sem effs a) -> Sem effs ()
traverseTweak
(Lens' TxSkel TxSkelMints
txSkelMintsL Lens' TxSkel TxSkelMints
-> Optic An_Iso '[] TxSkelMints TxSkelMints [Mint] [Mint]
-> Optic A_Lens '[] TxSkel TxSkel [Mint] [Mint]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic An_Iso '[] TxSkelMints TxSkelMints [Mint] [Mint]
txSkelMintsListI Optic A_Lens '[] TxSkel TxSkel [Mint] [Mint]
-> Optic A_Traversal '[] [Mint] [Mint] Mint Mint
-> Optic A_Traversal '[] TxSkel TxSkel Mint Mint
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Traversal '[] [Mint] [Mint] Mint Mint
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed Optic A_Traversal '[] TxSkel TxSkel Mint Mint
-> Optic
A_Lens
'[]
Mint
Mint
(User 'IsScript 'Redemption)
(User 'IsScript 'Redemption)
-> Optic' A_Traversal '[] TxSkel (User 'IsScript 'Redemption)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
A_Lens
'[]
Mint
Mint
(User 'IsScript 'Redemption)
(User 'IsScript 'Redemption)
mintRedeemedScriptL)
([TxOutRef]
-> User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption)
forall (effs :: EffectRow).
Members '[MockChainLog, MockChainRead] effs =>
[TxOutRef]
-> User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption)
updateRedeemedScript [TxOutRef]
inputsKeys)
[(TxOutRef, TxSkelRedeemer)]
inputsList <- Optic' A_Getter '[] TxSkel [(TxOutRef, TxSkelRedeemer)]
-> Sem effs [(TxOutRef, TxSkelRedeemer)]
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Getter) =>
Optic' k is TxSkel a -> Sem effs a
viewTweak (Optic' A_Getter '[] TxSkel [(TxOutRef, TxSkelRedeemer)]
-> Sem effs [(TxOutRef, TxSkelRedeemer)])
-> Optic' A_Getter '[] TxSkel [(TxOutRef, TxSkelRedeemer)]
-> Sem effs [(TxOutRef, TxSkelRedeemer)]
forall a b. (a -> b) -> a -> b
$ Lens' TxSkel (Map TxOutRef TxSkelRedeemer)
txSkelInsL Lens' TxSkel (Map TxOutRef TxSkelRedeemer)
-> Optic
A_Getter
'[]
(Map TxOutRef TxSkelRedeemer)
(Map TxOutRef TxSkelRedeemer)
[(TxOutRef, TxSkelRedeemer)]
[(TxOutRef, TxSkelRedeemer)]
-> Optic' A_Getter '[] TxSkel [(TxOutRef, TxSkelRedeemer)]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% (Map TxOutRef TxSkelRedeemer -> [(TxOutRef, TxSkelRedeemer)])
-> Optic
A_Getter
'[]
(Map TxOutRef TxSkelRedeemer)
(Map TxOutRef TxSkelRedeemer)
[(TxOutRef, TxSkelRedeemer)]
[(TxOutRef, TxSkelRedeemer)]
forall s a. (s -> a) -> Getter s a
to Map TxOutRef TxSkelRedeemer -> [(TxOutRef, TxSkelRedeemer)]
forall k a. Map k a -> [(k, a)]
Map.toList
[(TxOutRef, TxSkelRedeemer)]
newInputs <- [(TxOutRef, TxSkelRedeemer)]
-> ((TxOutRef, TxSkelRedeemer)
-> Sem effs (TxOutRef, TxSkelRedeemer))
-> Sem effs [(TxOutRef, TxSkelRedeemer)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(TxOutRef, TxSkelRedeemer)]
inputsList (((TxOutRef, TxSkelRedeemer)
-> Sem effs (TxOutRef, TxSkelRedeemer))
-> Sem effs [(TxOutRef, TxSkelRedeemer)])
-> ((TxOutRef, TxSkelRedeemer)
-> Sem effs (TxOutRef, TxSkelRedeemer))
-> Sem effs [(TxOutRef, TxSkelRedeemer)]
forall a b. (a -> b) -> a -> b
$ \(TxOutRef
oRef, TxSkelRedeemer
red) ->
(TxOutRef
oRef,) (TxSkelRedeemer -> (TxOutRef, TxSkelRedeemer))
-> Sem effs TxSkelRedeemer -> Sem effs (TxOutRef, TxSkelRedeemer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
Maybe VScript
validatorM <- Optic' An_AffineTraversal '[] TxSkelOut VScript
-> TxOutRef -> Sem effs (Maybe VScript)
forall (effs :: EffectRow) af (is :: IxList) c.
(Member MockChainRead effs, Is af An_AffineFold) =>
Optic' af is TxSkelOut c -> TxOutRef -> Sem effs (Maybe c)
previewByRef (Lens' TxSkelOut (User 'IsEither 'Allocation)
txSkelOutOwnerL Lens' TxSkelOut (User 'IsEither 'Allocation)
-> Optic
An_AffineTraversal
'[]
(User 'IsEither 'Allocation)
(User 'IsEither 'Allocation)
VScript
VScript
-> Optic' An_AffineTraversal '[] TxSkelOut VScript
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
An_AffineTraversal
'[]
(User 'IsEither 'Allocation)
(User 'IsEither 'Allocation)
VScript
VScript
forall (kind :: UserKind) (mode :: UserMode).
AffineTraversal' (User kind mode) VScript
userVScriptAT) TxOutRef
oRef
case Maybe VScript
validatorM of
Maybe VScript
Nothing -> TxSkelRedeemer -> Sem effs TxSkelRedeemer
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return TxSkelRedeemer
red
Just VScript
val -> Optic' A_Lens '[] (User 'IsScript 'Redemption) TxSkelRedeemer
-> User 'IsScript 'Redemption -> TxSkelRedeemer
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] (User 'IsScript 'Redemption) TxSkelRedeemer
userTxSkelRedeemerL (User 'IsScript 'Redemption -> TxSkelRedeemer)
-> Sem effs (User 'IsScript 'Redemption) -> Sem effs TxSkelRedeemer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxOutRef]
-> User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption)
forall (effs :: EffectRow).
Members '[MockChainLog, MockChainRead] effs =>
[TxOutRef]
-> User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption)
updateRedeemedScript [TxOutRef]
inputsKeys (VScript -> TxSkelRedeemer -> User 'IsScript 'Redemption
forall script (a :: UserKind).
(a ∈ '[ 'IsScript, 'IsEither], ToVScript script,
Typeable script) =>
script -> TxSkelRedeemer -> User a 'Redemption
UserRedeemedScript VScript
val TxSkelRedeemer
red)
Lens' TxSkel (Map TxOutRef TxSkelRedeemer)
-> Map TxOutRef TxSkelRedeemer -> Sem effs ()
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Setter) =>
Optic' k is TxSkel a -> a -> Sem effs ()
setTweak Lens' TxSkel (Map TxOutRef TxSkelRedeemer)
txSkelInsL (Map TxOutRef TxSkelRedeemer -> Sem effs ())
-> Map TxOutRef TxSkelRedeemer -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ [(TxOutRef, TxSkelRedeemer)] -> Map TxOutRef TxSkelRedeemer
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(TxOutRef, TxSkelRedeemer)]
newInputs
Optic' A_Traversal '[] TxSkel (User 'IsScript 'Redemption)
-> (User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption))
-> Sem effs ()
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Traversal) =>
Optic' k is TxSkel a -> (a -> Sem effs a) -> Sem effs ()
traverseTweak
(Lens' TxSkel [TxSkelProposal]
txSkelProposalsL Lens' TxSkel [TxSkelProposal]
-> Optic
A_Traversal
'[]
[TxSkelProposal]
[TxSkelProposal]
TxSkelProposal
TxSkelProposal
-> Optic' A_Traversal '[] TxSkel TxSkelProposal
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
A_Traversal
'[]
[TxSkelProposal]
[TxSkelProposal]
TxSkelProposal
TxSkelProposal
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed Optic' A_Traversal '[] TxSkel TxSkelProposal
-> Optic
An_AffineTraversal
'[]
TxSkelProposal
TxSkelProposal
(Maybe (User 'IsScript 'Redemption))
(Maybe (User 'IsScript 'Redemption))
-> Optic
A_Traversal
'[]
TxSkel
TxSkel
(Maybe (User 'IsScript 'Redemption))
(Maybe (User 'IsScript 'Redemption))
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
An_AffineTraversal
'[]
TxSkelProposal
TxSkelProposal
(Maybe (User 'IsScript 'Redemption))
(Maybe (User 'IsScript 'Redemption))
forall (kind :: UserKind).
Typeable kind =>
AffineTraversal' TxSkelProposal (Maybe (User kind 'Redemption))
txSkelProposalMConstitutionAT Optic
A_Traversal
'[]
TxSkel
TxSkel
(Maybe (User 'IsScript 'Redemption))
(Maybe (User 'IsScript 'Redemption))
-> Optic
A_Prism
'[]
(Maybe (User 'IsScript 'Redemption))
(Maybe (User 'IsScript 'Redemption))
(User 'IsScript 'Redemption)
(User 'IsScript 'Redemption)
-> Optic' A_Traversal '[] TxSkel (User 'IsScript 'Redemption)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
A_Prism
'[]
(Maybe (User 'IsScript 'Redemption))
(Maybe (User 'IsScript 'Redemption))
(User 'IsScript 'Redemption)
(User 'IsScript 'Redemption)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
([TxOutRef]
-> User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption)
forall (effs :: EffectRow).
Members '[MockChainLog, MockChainRead] effs =>
[TxOutRef]
-> User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption)
updateRedeemedScript [TxOutRef]
inputsKeys)
Optic' A_Traversal '[] TxSkel (User 'IsScript 'Redemption)
-> (User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption))
-> Sem effs ()
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Traversal) =>
Optic' k is TxSkel a -> (a -> Sem effs a) -> Sem effs ()
traverseTweak
(Lens' TxSkel TxSkelWithdrawals
txSkelWithdrawalsL Lens' TxSkel TxSkelWithdrawals
-> Optic
An_Iso
'[]
TxSkelWithdrawals
TxSkelWithdrawals
[Withdrawal]
[Withdrawal]
-> Optic A_Lens '[] TxSkel TxSkel [Withdrawal] [Withdrawal]
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
An_Iso
'[]
TxSkelWithdrawals
TxSkelWithdrawals
[Withdrawal]
[Withdrawal]
txSkelWithdrawalsListI Optic A_Lens '[] TxSkel TxSkel [Withdrawal] [Withdrawal]
-> Optic
A_Traversal '[] [Withdrawal] [Withdrawal] Withdrawal Withdrawal
-> Optic' A_Traversal '[] TxSkel Withdrawal
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
A_Traversal '[] [Withdrawal] [Withdrawal] Withdrawal Withdrawal
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed Optic' A_Traversal '[] TxSkel Withdrawal
-> Optic' A_Lens '[] Withdrawal (User 'IsEither 'Redemption)
-> Optic
A_Traversal
'[]
TxSkel
TxSkel
(User 'IsEither 'Redemption)
(User 'IsEither 'Redemption)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic' A_Lens '[] Withdrawal (User 'IsEither 'Redemption)
withdrawalUserL Optic
A_Traversal
'[]
TxSkel
TxSkel
(User 'IsEither 'Redemption)
(User 'IsEither 'Redemption)
-> Optic
A_Prism
'[]
(User 'IsEither 'Redemption)
(User 'IsEither 'Redemption)
(User 'IsScript 'Redemption)
(User 'IsScript 'Redemption)
-> Optic' A_Traversal '[] TxSkel (User 'IsScript 'Redemption)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic
A_Prism
'[]
(User 'IsEither 'Redemption)
(User 'IsEither 'Redemption)
(User 'IsScript 'Redemption)
(User 'IsScript 'Redemption)
forall (mode :: UserMode).
Prism' (User 'IsEither mode) (User 'IsScript mode)
userEitherScriptP)
([TxOutRef]
-> User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption)
forall (effs :: EffectRow).
Members '[MockChainLog, MockChainRead] effs =>
[TxOutRef]
-> User 'IsScript 'Redemption
-> Sem effs (User 'IsScript 'Redemption)
updateRedeemedScript [TxOutRef]
inputsKeys)
getTxSkelOutMinAda ::
(Members '[MockChainRead, Error P.Ledger.ToCardanoError] effs) =>
TxSkelOut ->
Sem effs Integer
getTxSkelOutMinAda :: forall (effs :: EffectRow).
Members '[MockChainRead, Error ToCardanoError] effs =>
TxSkelOut -> Sem effs Integer
getTxSkelOutMinAda TxSkelOut
txSkelOut = do
PParams
params <- Params -> PParams
Emulator.pEmulatorPParams (Params -> PParams) -> Sem effs Params -> Sem effs PParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem effs Params
forall (effs :: EffectRow).
Member MockChainRead effs =>
Sem effs Params
getParams
Coin -> Integer
Cardano.unCoin
(Coin -> Integer)
-> (TxOut CtxTx ConwayEra -> Coin)
-> TxOut CtxTx ConwayEra
-> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PParams -> TxOut EmulatorEra -> Coin
forall era. EraTxOut era => PParams era -> TxOut era -> Coin
Shelley.getMinCoinTxOut PParams
params
(BabbageTxOut EmulatorEra -> Coin)
-> (TxOut CtxTx ConwayEra -> BabbageTxOut EmulatorEra)
-> TxOut CtxTx ConwayEra
-> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyBasedEra ConwayEra
-> TxOut CtxUTxO ConwayEra -> TxOut EmulatorEra
forall era ledgerera.
(HasCallStack, ShelleyLedgerEra era ~ ledgerera) =>
ShelleyBasedEra era -> TxOut CtxUTxO era -> TxOut ledgerera
Cardano.toShelleyTxOut ShelleyBasedEra ConwayEra
Cardano.ShelleyBasedEraConway
(TxOut CtxUTxO ConwayEra -> BabbageTxOut EmulatorEra)
-> (TxOut CtxTx ConwayEra -> TxOut CtxUTxO ConwayEra)
-> TxOut CtxTx ConwayEra
-> BabbageTxOut EmulatorEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut CtxTx ConwayEra -> TxOut CtxUTxO ConwayEra
forall era. TxOut CtxTx era -> TxOut CtxUTxO era
Cardano.toCtxUTxOTxOut
(TxOut CtxTx ConwayEra -> Integer)
-> Sem effs (TxOut CtxTx ConwayEra) -> Sem effs Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxSkelOut -> Sem effs (TxOut CtxTx ConwayEra)
forall (effs :: EffectRow).
Members '[MockChainRead, Error ToCardanoError] effs =>
TxSkelOut -> Sem effs (TxOut CtxTx ConwayEra)
toCardanoTxOut TxSkelOut
txSkelOut
toTxSkelOutWithMinAda ::
forall effs.
(Members '[MockChainRead, MockChainLog, Error P.Ledger.ToCardanoError] effs) =>
TxSkelOut ->
Sem effs TxSkelOut
toTxSkelOutWithMinAda :: forall (effs :: EffectRow).
Members
'[MockChainRead, MockChainLog, Error ToCardanoError] effs =>
TxSkelOut -> Sem effs TxSkelOut
toTxSkelOutWithMinAda txSkelOut :: TxSkelOut
txSkelOut@(Optic' A_Lens '[] TxSkelOut Bool -> TxSkelOut -> Bool
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens '[] TxSkelOut Bool
txSkelOutValueAutoAdjustL -> Bool
False) = TxSkelOut -> Sem effs TxSkelOut
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return TxSkelOut
txSkelOut
toTxSkelOutWithMinAda TxSkelOut
txSkelOut = do
TxSkelOut
txSkelOut' <- TxSkelOut -> Sem effs TxSkelOut
go TxSkelOut
txSkelOut
let originalAda :: Lovelace
originalAda = Optic' A_Lens '[] TxSkelOut Lovelace -> TxSkelOut -> Lovelace
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens' TxSkelOut Value
txSkelOutValueL Lens' TxSkelOut Value
-> Optic A_Lens '[] Value Value Lovelace Lovelace
-> Optic' A_Lens '[] TxSkelOut Lovelace
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens '[] Value Value Lovelace Lovelace
valueLovelaceL) TxSkelOut
txSkelOut
updatedAda :: Lovelace
updatedAda = Optic' A_Lens '[] TxSkelOut Lovelace -> TxSkelOut -> Lovelace
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens' TxSkelOut Value
txSkelOutValueL Lens' TxSkelOut Value
-> Optic A_Lens '[] Value Value Lovelace Lovelace
-> Optic' A_Lens '[] TxSkelOut Lovelace
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens '[] Value Value Lovelace Lovelace
valueLovelaceL) TxSkelOut
txSkelOut'
Bool -> Sem effs () -> Sem effs ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lovelace
originalAda Lovelace -> Lovelace -> Bool
forall a. Eq a => a -> a -> Bool
/= Lovelace
updatedAda) (Sem effs () -> Sem effs ()) -> Sem effs () -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ MockChainLogEntry -> Sem effs ()
forall (effs :: EffectRow).
Member MockChainLog effs =>
MockChainLogEntry -> Sem effs ()
logEvent (MockChainLogEntry -> Sem effs ())
-> MockChainLogEntry -> Sem effs ()
forall a b. (a -> b) -> a -> b
$ TxSkelOut -> Lovelace -> MockChainLogEntry
MCLogAdjustedTxSkelOut TxSkelOut
txSkelOut Lovelace
updatedAda
TxSkelOut -> Sem effs TxSkelOut
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return TxSkelOut
txSkelOut'
where
go :: TxSkelOut -> Sem effs TxSkelOut
go :: TxSkelOut -> Sem effs TxSkelOut
go TxSkelOut
skelOut = do
Integer
requiredAda <- TxSkelOut -> Sem effs Integer
forall (effs :: EffectRow).
Members '[MockChainRead, Error ToCardanoError] effs =>
TxSkelOut -> Sem effs Integer
getTxSkelOutMinAda TxSkelOut
skelOut
if Lovelace -> Integer
Api.getLovelace (Optic' A_Lens '[] TxSkelOut Lovelace -> TxSkelOut -> Lovelace
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view (Lens' TxSkelOut Value
txSkelOutValueL Lens' TxSkelOut Value
-> Optic A_Lens '[] Value Value Lovelace Lovelace
-> Optic' A_Lens '[] TxSkelOut Lovelace
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens '[] Value Value Lovelace Lovelace
valueLovelaceL) TxSkelOut
skelOut) Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
requiredAda
then TxSkelOut -> Sem effs TxSkelOut
forall a. a -> Sem effs a
forall (m :: * -> *) a. Monad m => a -> m a
return TxSkelOut
skelOut
else TxSkelOut -> Sem effs TxSkelOut
go (TxSkelOut -> Sem effs TxSkelOut)
-> TxSkelOut -> Sem effs TxSkelOut
forall a b. (a -> b) -> a -> b
$ Optic' A_Lens '[] TxSkelOut Lovelace
-> Lovelace -> TxSkelOut -> TxSkelOut
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
set (Lens' TxSkelOut Value
txSkelOutValueL Lens' TxSkelOut Value
-> Optic A_Lens '[] Value Value Lovelace Lovelace
-> Optic' A_Lens '[] TxSkelOut Lovelace
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Lens '[] Value Value Lovelace Lovelace
valueLovelaceL) (Integer -> Lovelace
Api.Lovelace Integer
requiredAda) TxSkelOut
skelOut
autoFillMinAda ::
(Members '[Tweak, MockChainRead, MockChainLog, Error P.Ledger.ToCardanoError] effs) =>
Sem effs ()
autoFillMinAda :: forall (effs :: EffectRow).
Members
'[Tweak, MockChainRead, MockChainLog, Error ToCardanoError] effs =>
Sem effs ()
autoFillMinAda = Optic' A_Traversal '[] TxSkel TxSkelOut
-> (TxSkelOut -> Sem effs TxSkelOut) -> Sem effs ()
forall (effs :: EffectRow) k (is :: IxList) a.
(Member Tweak effs, Is k A_Traversal) =>
Optic' k is TxSkel a -> (a -> Sem effs a) -> Sem effs ()
traverseTweak (Lens' TxSkel [TxSkelOut]
txSkelOutsL Lens' TxSkel [TxSkelOut]
-> Optic
A_Traversal '[] [TxSkelOut] [TxSkelOut] TxSkelOut TxSkelOut
-> Optic' A_Traversal '[] TxSkel TxSkelOut
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Traversal '[] [TxSkelOut] [TxSkelOut] TxSkelOut TxSkelOut
forall (t :: * -> *) a b.
Traversable t =>
Traversal (t a) (t b) a b
traversed) TxSkelOut -> Sem effs TxSkelOut
forall (effs :: EffectRow).
Members
'[MockChainRead, MockChainLog, Error ToCardanoError] effs =>
TxSkelOut -> Sem effs TxSkelOut
toTxSkelOutWithMinAda