-- | 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 Data.Maybe
import Optics.Core
import Plutus.Script.Utils.Ada qualified as Script
import Plutus.Script.Utils.Value qualified as Script

-- | 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.
(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 necessarily contains at
-- least the minimal required ada. If the previous quantity of ada was
-- sufficient, it remains unchanged.
toTxSkelOutWithMinAda ::
  (MonadBlockChainBalancing m) =>
  -- | The output to potential adjust
  TxSkelOut ->
  -- | Returns @Nothing@ when no ajustment was required/done, and
  -- @Just(newOutput,newAdaAmount)@ otherwise.
  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
^. Lens' TxSkelOut TxSkelOutValue
txSkelOutValueL Lens' TxSkelOut TxSkelOutValue
-> Optic A_Lens NoIx TxSkelOutValue TxSkelOutValue Bool Bool
-> Optic' A_Lens NoIx TxSkelOut Bool
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 TxSkelOutValue TxSkelOutValue Bool 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 :: Ada
originalAda = TxSkelOut -> Value
txSkelOutValue TxSkelOut
txSkelOut Value -> Optic' A_Lens NoIx Value Ada -> Ada
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Value Ada
Script.adaL
      updatedAda :: Ada
updatedAda = TxSkelOut -> Value
txSkelOutValue TxSkelOut
txSkelOut' Value -> Optic' A_Lens NoIx Value Ada -> Ada
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx Value Ada
Script.adaL
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ada
originalAda Ada -> Ada -> Bool
forall a. Eq a => a -> a -> Bool
/= Ada
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 -> Ada -> MockChainLogEntry
MCLogAdjustedTxSkelOut TxSkelOut
txSkelOut Ada
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 Ada -> Integer
Script.getLovelace (TxSkelOut
skelOut TxSkelOut -> Optic' A_Lens NoIx TxSkelOut Ada -> Ada
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Lens' TxSkelOut TxSkelOutValue
txSkelOutValueL Lens' TxSkelOut TxSkelOutValue
-> Optic A_Lens NoIx TxSkelOutValue TxSkelOutValue Value Value
-> Optic A_Lens NoIx TxSkelOut TxSkelOut Value Value
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 TxSkelOutValue TxSkelOutValue Value Value
txSkelOutValueContentL Optic A_Lens NoIx TxSkelOut TxSkelOut Value Value
-> Optic' A_Lens NoIx Value Ada -> Optic' A_Lens NoIx TxSkelOut Ada
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 Ada
Script.adaL) 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 TxSkelOutValue
txSkelOutValueL Lens' TxSkelOut TxSkelOutValue
-> Optic A_Lens NoIx TxSkelOutValue TxSkelOutValue Value Value
-> Optic A_Lens NoIx TxSkelOut TxSkelOut Value Value
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 TxSkelOutValue TxSkelOutValue Value Value
txSkelOutValueContentL Optic A_Lens NoIx TxSkelOut TxSkelOut Value Value
-> Optic' A_Lens NoIx Value Ada -> Optic' A_Lens NoIx TxSkelOut Ada
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 Ada
Script.adaL Optic' A_Lens NoIx TxSkelOut Ada -> Ada -> 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 -> Ada
Script.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