-- | This module exposes functions to automatically adjust the ADA contained in
-- the outputs of a 'Cooked.Skeleton.TxSkel' to satisfy the minimal amount
-- required by the protocol parameters.
module Cooked.MockChain.Automation.AutoFilling.MinAda
  ( getTxSkelOutMinAda,
    toTxSkelOutWithMinAda,
    autoFillMinAda,
  )
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.Automation.GenerateTx.Output
import Cooked.MockChain.Effect.Log
import Cooked.MockChain.Effect.Read
import Cooked.Skeleton
import Cooked.Tweak.Common
import Cooked.Tweak.Update
import Ledger.Tx qualified as P.Ledger
import Optics.Core
import PlutusLedgerApi.V3 qualified as Api
import Polysemy
import Polysemy.Error

-- * Auto filling min ada amounts

-- | Compute the required minimal ADA for a given output
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

-- | This transforms an output into another output which contains the minimal
-- required ada. If the previous quantity of ADA was sufficient, it remains
-- unchanged. This can require a few iterations to converge, as the added ADA
-- will increase the size of the UTXO which in turn might need more ADA.
toTxSkelOutWithMinAda ::
  forall effs.
  (Members '[MockChainRead, MockChainLog, Error P.Ledger.ToCardanoError] effs) =>
  TxSkelOut ->
  Sem effs TxSkelOut
-- The auto adjustment is disabled so nothing is done here
toTxSkelOutWithMinAda :: forall (effs :: EffectRow).
Members
  '[MockChainRead, MockChainLog, Error ToCardanoError] effs =>
TxSkelOut -> Sem effs TxSkelOut
toTxSkelOutWithMinAda txSkelOut :: TxSkelOut
txSkelOut@(Optic' A_Lens NoIx 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 NoIx 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
-- The auto adjustment is enabled
toTxSkelOutWithMinAda TxSkelOut
txSkelOut = do
  TxSkelOut
txSkelOut' <- TxSkelOut -> Sem effs TxSkelOut
go TxSkelOut
txSkelOut
  let originalAda :: Lovelace
originalAda = Optic' A_Lens NoIx 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 NoIx Value Value Lovelace Lovelace
-> Optic' A_Lens NoIx 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 NoIx Value Value Lovelace Lovelace
valueLovelaceL) TxSkelOut
txSkelOut
      updatedAda :: Lovelace
updatedAda = Optic' A_Lens NoIx 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 NoIx Value Value Lovelace Lovelace
-> Optic' A_Lens NoIx 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 NoIx 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
      -- Computing the required minimal amount of ADA in this output
      Integer
requiredAda <- TxSkelOut -> Sem effs Integer
forall (effs :: EffectRow).
Members '[MockChainRead, Error ToCardanoError] effs =>
TxSkelOut -> Sem effs Integer
getTxSkelOutMinAda TxSkelOut
skelOut
      -- If this amount is sufficient, we return Nothing, otherwise, we adjust the
      -- output and possibly iterate
      if Lovelace -> Integer
Api.getLovelace (Optic' A_Lens NoIx 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 NoIx Value Value Lovelace Lovelace
-> Optic' A_Lens NoIx 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 NoIx 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 NoIx 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 NoIx Value Value Lovelace Lovelace
-> Optic' A_Lens NoIx 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 NoIx Value Value Lovelace Lovelace
valueLovelaceL) (Integer -> Lovelace
Api.Lovelace Integer
requiredAda) TxSkelOut
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 P.Ledger.ToCardanoError] effs) =>
  Sem effs ()
autoFillMinAda :: forall (effs :: EffectRow).
Members
  '[Tweak, MockChainRead, MockChainLog, Error ToCardanoError] effs =>
Sem effs ()
autoFillMinAda = Optic' A_Traversal NoIx 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]
txSkelOutputsL Lens' TxSkel [TxSkelOut]
-> Optic
     A_Traversal NoIx [TxSkelOut] [TxSkelOut] TxSkelOut TxSkelOut
-> Optic' A_Traversal NoIx 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 NoIx [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