-- | This module provides functions to ensure skeleton outputs contain enough
-- ada to satisfy the minimum ada constraint.
module Cooked.MockChain.MinAda
  ( toTxSkelOutWithMinAda,
    toTxSkelWithMinAda,
    getTxSkelOutMinAda,
  )
where

import Cardano.Api qualified as Cardano
import Cardano.Api.Ledger qualified as Cardano
import Cardano.Api.Shelley 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.BlockChain
import Cooked.MockChain.GenerateTx.Output
import Cooked.Skeleton
import Optics.Core
import PlutusLedgerApi.V1.Value qualified as Api

-- | Compute the required minimal ADA for a given output
getTxSkelOutMinAda :: (MonadBlockChainBalancing m) => TxSkelOut -> m Integer
getTxSkelOutMinAda :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m Integer
getTxSkelOutMinAda TxSkelOut
txSkelOut = do
  PParams
params <- Params -> PParams
Emulator.pEmulatorPParams (Params -> PParams) -> m Params -> m PParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Params
forall (m :: * -> *). MonadBlockChainBalancing m => m 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)
-> m (TxOut CtxTx ConwayEra) -> m Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TxSkelOut -> m (TxOut CtxTx ConwayEra)
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m (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 :: (MonadBlockChainBalancing m) => TxSkelOut -> m TxSkelOut
-- The auto adjustment is disabled so nothing is done here
toTxSkelOutWithMinAda :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m TxSkelOut
toTxSkelOutWithMinAda txSkelOut :: TxSkelOut
txSkelOut@((TxSkelOut -> Optic' A_Lens NoIx TxSkelOut Bool -> Bool
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx TxSkelOut Bool
txSkelOutValueAutoAdjustL) -> Bool
False) = TxSkelOut -> m TxSkelOut
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return TxSkelOut
txSkelOut
-- The auto adjustment is enabled
toTxSkelOutWithMinAda TxSkelOut
txSkelOut = do
  TxSkelOut
txSkelOut' <- TxSkelOut -> m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m 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 -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Lovelace
originalAda Lovelace -> Lovelace -> Bool
forall a. Eq a => a -> a -> Bool
/= Lovelace
updatedAda) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ MockChainLogEntry -> m ()
forall (m :: * -> *).
MonadBlockChainBalancing m =>
MockChainLogEntry -> m ()
logEvent (MockChainLogEntry -> m ()) -> MockChainLogEntry -> m ()
forall a b. (a -> b) -> a -> b
$ TxSkelOut -> Lovelace -> MockChainLogEntry
MCLogAdjustedTxSkelOut TxSkelOut
txSkelOut Lovelace
updatedAda
  TxSkelOut -> m TxSkelOut
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return TxSkelOut
txSkelOut'
  where
    go :: (MonadBlockChainBalancing m) => TxSkelOut -> m TxSkelOut
    go :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m TxSkelOut
go TxSkelOut
skelOut = do
      -- Computing the required minimal amount of ADA in this output
      Integer
requiredAda <- TxSkelOut -> m Integer
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m 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 (TxSkelOut
skelOut TxSkelOut -> Optic' A_Lens NoIx TxSkelOut Lovelace -> Lovelace
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. 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 -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
requiredAda
        then TxSkelOut -> m TxSkelOut
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return TxSkelOut
skelOut
        else TxSkelOut -> m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m TxSkelOut
go (TxSkelOut -> m TxSkelOut) -> TxSkelOut -> m TxSkelOut
forall a b. (a -> b) -> a -> b
$ TxSkelOut
skelOut TxSkelOut -> (TxSkelOut -> TxSkelOut) -> TxSkelOut
forall a b. a -> (a -> b) -> b
& 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 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
.~ Integer -> Lovelace
Api.Lovelace Integer
requiredAda

-- | 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.
toTxSkelWithMinAda :: (MonadBlockChainBalancing m) => TxSkel -> m TxSkel
toTxSkelWithMinAda :: forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkel -> m TxSkel
toTxSkelWithMinAda TxSkel
skel = (\[TxSkelOut]
x -> TxSkel
skel TxSkel -> (TxSkel -> TxSkel) -> TxSkel
forall a b. a -> (a -> b) -> b
& Lens' TxSkel [TxSkelOut]
txSkelOutsL Lens' TxSkel [TxSkelOut] -> [TxSkelOut] -> TxSkel -> TxSkel
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> b -> s -> t
.~ [TxSkelOut]
x) ([TxSkelOut] -> TxSkel) -> m [TxSkelOut] -> m TxSkel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TxSkelOut] -> (TxSkelOut -> m TxSkelOut) -> m [TxSkelOut]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (TxSkel
skel TxSkel -> Lens' TxSkel [TxSkelOut] -> [TxSkelOut]
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' TxSkel [TxSkelOut]
txSkelOutsL) TxSkelOut -> m TxSkelOut
forall (m :: * -> *).
MonadBlockChainBalancing m =>
TxSkelOut -> m TxSkelOut
toTxSkelOutWithMinAda