{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Mary.UTxO (
  getConsumedMaryValue,
  getProducedMaryValue,
  burnedMultiAssets,
) where

import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Mary.Core
import Cardano.Ledger.Mary.Era (MaryEra)
import Cardano.Ledger.Mary.State ()
import Cardano.Ledger.Mary.Value (MaryValue (..), filterMultiAsset, mapMaybeMultiAsset, policyID)
import Cardano.Ledger.Shelley.UTxO (
  ShelleyScriptsNeeded (..),
  getShelleyMinFeeTxUtxo,
  getShelleyScriptsNeeded,
  getShelleyWitsVKeyNeeded,
  shelleyConsumed,
  shelleyProducedValue,
 )
import Cardano.Ledger.State (
  EraUTxO (..),
  ScriptsProvided (..),
  UTxO,
  sumUTxO,
  txInsFilter,
 )
import Cardano.Ledger.Val (inject)
import Data.Foldable (fold)
import qualified Data.Set as Set
import Lens.Micro

instance EraUTxO MaryEra where
  type ScriptsNeeded MaryEra = ShelleyScriptsNeeded MaryEra

  consumed :: forall (t :: TxLevel).
PParams MaryEra
-> CertState MaryEra
-> UTxO MaryEra
-> TxBody t MaryEra
-> Value MaryEra
consumed = PParams MaryEra
-> CertState MaryEra
-> UTxO MaryEra
-> TxBody t MaryEra
-> Value MaryEra
forall era (l :: TxLevel).
(EraUTxO era, EraCertState era) =>
PParams era
-> CertState era -> UTxO era -> TxBody l era -> Value era
shelleyConsumed

  getConsumedValue :: forall (t :: TxLevel).
PParams MaryEra
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> UTxO MaryEra
-> TxBody t MaryEra
-> Value MaryEra
getConsumedValue = PParams MaryEra
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> UTxO MaryEra
-> TxBody t MaryEra
-> Value MaryEra
PParams MaryEra
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> UTxO MaryEra
-> TxBody t MaryEra
-> MaryValue
forall era (l :: TxLevel).
(MaryEraTxBody era, Value era ~ MaryValue) =>
PParams era
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> UTxO era
-> TxBody l era
-> MaryValue
getConsumedMaryValue

  getProducedValue :: forall (t :: TxLevel).
PParams MaryEra
-> (KeyHash StakePool -> Bool) -> TxBody t MaryEra -> Value MaryEra
getProducedValue PParams MaryEra
pp KeyHash StakePool -> Bool
isRegPoolId TxBody t MaryEra
txBody =
    TxBody t MaryEra
-> (TxBody TopTx MaryEra -> MaryValue) -> MaryValue
forall (t :: TxLevel -> * -> *) era (l :: TxLevel) a.
(HasEraTxLevel t era, STxLevel l era ~ STxTopLevel l era) =>
t l era -> (t TopTx era -> a) -> a
withTopTxLevelOnly TxBody t MaryEra
txBody (PParams MaryEra
-> (KeyHash StakePool -> Bool) -> TxBody TopTx MaryEra -> MaryValue
forall era.
(MaryEraTxBody era, Value era ~ MaryValue) =>
PParams era
-> (KeyHash StakePool -> Bool) -> TxBody TopTx era -> MaryValue
getProducedMaryValue PParams MaryEra
pp KeyHash StakePool -> Bool
isRegPoolId)

  getScriptsProvided :: forall (t :: TxLevel).
UTxO MaryEra -> Tx t MaryEra -> ScriptsProvided MaryEra
getScriptsProvided UTxO MaryEra
_ Tx t MaryEra
tx = Map ScriptHash (Script MaryEra) -> ScriptsProvided MaryEra
forall era. Map ScriptHash (Script era) -> ScriptsProvided era
ScriptsProvided (Tx t MaryEra
tx Tx t MaryEra
-> Getting
     (Map ScriptHash (Timelock MaryEra))
     (Tx t MaryEra)
     (Map ScriptHash (Timelock MaryEra))
-> Map ScriptHash (Timelock MaryEra)
forall s a. s -> Getting a s a -> a
^. (TxWits MaryEra
 -> Const (Map ScriptHash (Timelock MaryEra)) (TxWits MaryEra))
-> Tx t MaryEra
-> Const (Map ScriptHash (Timelock MaryEra)) (Tx t MaryEra)
(ShelleyTxWits MaryEra
 -> Const
      (Map ScriptHash (Timelock MaryEra)) (ShelleyTxWits MaryEra))
-> Tx t MaryEra
-> Const (Map ScriptHash (Timelock MaryEra)) (Tx t MaryEra)
forall era (l :: TxLevel).
EraTx era =>
Lens' (Tx l era) (TxWits era)
forall (l :: TxLevel). Lens' (Tx l MaryEra) (TxWits MaryEra)
witsTxL ((ShelleyTxWits MaryEra
  -> Const
       (Map ScriptHash (Timelock MaryEra)) (ShelleyTxWits MaryEra))
 -> Tx t MaryEra
 -> Const (Map ScriptHash (Timelock MaryEra)) (Tx t MaryEra))
-> ((Map ScriptHash (Timelock MaryEra)
     -> Const
          (Map ScriptHash (Timelock MaryEra))
          (Map ScriptHash (Timelock MaryEra)))
    -> ShelleyTxWits MaryEra
    -> Const
         (Map ScriptHash (Timelock MaryEra)) (ShelleyTxWits MaryEra))
-> Getting
     (Map ScriptHash (Timelock MaryEra))
     (Tx t MaryEra)
     (Map ScriptHash (Timelock MaryEra))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map ScriptHash (Timelock MaryEra)
 -> Const
      (Map ScriptHash (Timelock MaryEra))
      (Map ScriptHash (Timelock MaryEra)))
-> ShelleyTxWits MaryEra
-> Const
     (Map ScriptHash (Timelock MaryEra)) (ShelleyTxWits MaryEra)
(Map ScriptHash (Script MaryEra)
 -> Const
      (Map ScriptHash (Timelock MaryEra))
      (Map ScriptHash (Script MaryEra)))
-> TxWits MaryEra
-> Const (Map ScriptHash (Timelock MaryEra)) (TxWits MaryEra)
forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
Lens' (TxWits MaryEra) (Map ScriptHash (Script MaryEra))
scriptTxWitsL)

  getScriptsNeeded :: forall (t :: TxLevel).
UTxO MaryEra -> TxBody t MaryEra -> ScriptsNeeded MaryEra
getScriptsNeeded = UTxO MaryEra -> TxBody t MaryEra -> ScriptsNeeded MaryEra
UTxO MaryEra -> TxBody t MaryEra -> ShelleyScriptsNeeded MaryEra
forall era (l :: TxLevel).
(ShelleyEraTxBody era, MaryEraTxBody era) =>
UTxO era -> TxBody l era -> ShelleyScriptsNeeded era
getMaryScriptsNeeded

  getScriptsHashesNeeded :: ScriptsNeeded MaryEra -> Set ScriptHash
getScriptsHashesNeeded (ShelleyScriptsNeeded Set ScriptHash
scriptHashes) = Set ScriptHash
scriptHashes

  getWitsVKeyNeeded :: forall (t :: TxLevel).
CertState MaryEra
-> UTxO MaryEra -> TxBody t MaryEra -> Set (KeyHash Witness)
getWitsVKeyNeeded = CertState MaryEra
-> UTxO MaryEra -> TxBody t MaryEra -> Set (KeyHash Witness)
forall era (l :: TxLevel).
(EraTx era, ShelleyEraTxBody era, EraCertState era,
 STxLevel l era ~ STxTopLevel l era) =>
CertState era -> UTxO era -> TxBody l era -> Set (KeyHash Witness)
getShelleyWitsVKeyNeeded

  getMinFeeTxUtxo :: forall (t :: TxLevel).
PParams MaryEra -> Tx t MaryEra -> UTxO MaryEra -> Coin
getMinFeeTxUtxo PParams MaryEra
pp Tx t MaryEra
tx UTxO MaryEra
_ = PParams MaryEra -> Tx t MaryEra -> Coin
forall era (l :: TxLevel).
EraTx era =>
PParams era -> Tx l era -> Coin
getShelleyMinFeeTxUtxo PParams MaryEra
pp Tx t MaryEra
tx

-- | Calculate the value consumed by the transation.
--
--   This differs from the corresponding Shelley function 'Shelley.coinConsumed'
--   since it works on Value and it also considers the "mint" field which
--   creates or destroys non-Ada tokens.
--
--   Note that this is slightly confusing, since it also covers non-Ada assets
--   _created_ by the transaction, depending on the sign of the quantities in
--   the mint field.
getConsumedMaryValue ::
  (MaryEraTxBody era, Value era ~ MaryValue) =>
  PParams era ->
  (Credential Staking -> Maybe Coin) ->
  (Credential DRepRole -> Maybe Coin) ->
  UTxO era ->
  TxBody l era ->
  MaryValue
getConsumedMaryValue :: forall era (l :: TxLevel).
(MaryEraTxBody era, Value era ~ MaryValue) =>
PParams era
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> UTxO era
-> TxBody l era
-> MaryValue
getConsumedMaryValue PParams era
pp Credential Staking -> Maybe Coin
lookupStakingDeposit Credential DRepRole -> Maybe Coin
lookupDRepDeposit UTxO era
utxo TxBody l era
txBody =
  MaryValue
consumedValue MaryValue -> MaryValue -> MaryValue
forall a. Semigroup a => a -> a -> a
<> Coin -> MultiAsset -> MaryValue
MaryValue Coin
forall a. Monoid a => a
mempty MultiAsset
mintedMultiAsset
  where
    mintedMultiAsset :: MultiAsset
mintedMultiAsset = (PolicyID -> AssetName -> Integer -> Bool)
-> MultiAsset -> MultiAsset
filterMultiAsset (\PolicyID
_ AssetName
_ -> (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0)) (MultiAsset -> MultiAsset) -> MultiAsset -> MultiAsset
forall a b. (a -> b) -> a -> b
$ TxBody l era
txBody TxBody l era
-> Getting MultiAsset (TxBody l era) MultiAsset -> MultiAsset
forall s a. s -> Getting a s a -> a
^. Getting MultiAsset (TxBody l era) MultiAsset
forall era (l :: TxLevel).
MaryEraTxBody era =>
Lens' (TxBody l era) MultiAsset
forall (l :: TxLevel). Lens' (TxBody l era) MultiAsset
mintTxBodyL
    {- balance (txins tx ◁ u) + wbalance (txwdrls tx) + keyRefunds pp tx -}
    consumedValue :: MaryValue
consumedValue =
      UTxO era -> Value era
forall era. EraTxOut era => UTxO era -> Value era
sumUTxO (UTxO era -> Set TxIn -> UTxO era
forall era. UTxO era -> Set TxIn -> UTxO era
txInsFilter UTxO era
utxo (TxBody l era
txBody TxBody l era
-> Getting (Set TxIn) (TxBody l era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody l era) (Set TxIn)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL))
        MaryValue -> MaryValue -> MaryValue
forall a. Semigroup a => a -> a -> a
<> Coin -> MaryValue
forall t s. Inject t s => t -> s
inject (Coin
refunds Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
withdrawals)
    refunds :: Coin
refunds = PParams era
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> TxBody l era
-> Coin
forall era (l :: TxLevel).
EraTxBody era =>
PParams era
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> TxBody l era
-> Coin
forall (l :: TxLevel).
PParams era
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> TxBody l era
-> Coin
getTotalRefundsTxBody PParams era
pp Credential Staking -> Maybe Coin
lookupStakingDeposit Credential DRepRole -> Maybe Coin
lookupDRepDeposit TxBody l era
txBody
    withdrawals :: Coin
withdrawals = Map RewardAccount Coin -> Coin
forall m. Monoid m => Map RewardAccount m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map RewardAccount Coin -> Coin)
-> (Withdrawals -> Map RewardAccount Coin) -> Withdrawals -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Withdrawals -> Map RewardAccount Coin
unWithdrawals (Withdrawals -> Coin) -> Withdrawals -> Coin
forall a b. (a -> b) -> a -> b
$ TxBody l era
txBody TxBody l era
-> Getting Withdrawals (TxBody l era) Withdrawals -> Withdrawals
forall s a. s -> Getting a s a -> a
^. Getting Withdrawals (TxBody l era) Withdrawals
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) Withdrawals
forall (l :: TxLevel). Lens' (TxBody l era) Withdrawals
withdrawalsTxBodyL

getProducedMaryValue ::
  (MaryEraTxBody era, Value era ~ MaryValue) =>
  PParams era ->
  -- | Check whether a pool with a supplied PoolStakeId is already registered.
  (KeyHash StakePool -> Bool) ->
  TxBody TopTx era ->
  MaryValue
getProducedMaryValue :: forall era.
(MaryEraTxBody era, Value era ~ MaryValue) =>
PParams era
-> (KeyHash StakePool -> Bool) -> TxBody TopTx era -> MaryValue
getProducedMaryValue PParams era
pp KeyHash StakePool -> Bool
isPoolRegistered TxBody TopTx era
txBody =
  PParams era
-> (KeyHash StakePool -> Bool) -> TxBody TopTx era -> Value era
forall era.
EraTxBody era =>
PParams era
-> (KeyHash StakePool -> Bool) -> TxBody TopTx era -> Value era
shelleyProducedValue PParams era
pp KeyHash StakePool -> Bool
isPoolRegistered TxBody TopTx era
txBody MaryValue -> MaryValue -> MaryValue
forall a. Semigroup a => a -> a -> a
<> TxBody TopTx era -> MaryValue
forall era (l :: TxLevel).
MaryEraTxBody era =>
TxBody l era -> MaryValue
burnedMultiAssets TxBody TopTx era
txBody

burnedMultiAssets :: MaryEraTxBody era => TxBody l era -> MaryValue
burnedMultiAssets :: forall era (l :: TxLevel).
MaryEraTxBody era =>
TxBody l era -> MaryValue
burnedMultiAssets TxBody l era
txBody =
  Coin -> MultiAsset -> MaryValue
MaryValue Coin
forall a. Monoid a => a
mempty (MultiAsset -> MaryValue) -> MultiAsset -> MaryValue
forall a b. (a -> b) -> a -> b
$
    (PolicyID -> AssetName -> Integer -> Maybe Integer)
-> MultiAsset -> MultiAsset
mapMaybeMultiAsset (\PolicyID
_ AssetName
_ Integer
v -> if Integer
v Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Integer
forall a. Num a => a -> a
negate Integer
v) else Maybe Integer
forall a. Maybe a
Nothing) (MultiAsset -> MultiAsset) -> MultiAsset -> MultiAsset
forall a b. (a -> b) -> a -> b
$
      TxBody l era
txBody TxBody l era
-> Getting MultiAsset (TxBody l era) MultiAsset -> MultiAsset
forall s a. s -> Getting a s a -> a
^. Getting MultiAsset (TxBody l era) MultiAsset
forall era (l :: TxLevel).
MaryEraTxBody era =>
Lens' (TxBody l era) MultiAsset
forall (l :: TxLevel). Lens' (TxBody l era) MultiAsset
mintTxBodyL

-- | Computes the set of script hashes required to unlock the transaction inputs and the
-- withdrawals. Unlike the one from Shelley, this one also includes script hashes needed
-- for minting multi-assets in the transaction.
getMaryScriptsNeeded ::
  (ShelleyEraTxBody era, MaryEraTxBody era) =>
  UTxO era ->
  TxBody l era ->
  ShelleyScriptsNeeded era
getMaryScriptsNeeded :: forall era (l :: TxLevel).
(ShelleyEraTxBody era, MaryEraTxBody era) =>
UTxO era -> TxBody l era -> ShelleyScriptsNeeded era
getMaryScriptsNeeded UTxO era
u TxBody l era
txBody =
  case UTxO era -> TxBody l era -> ShelleyScriptsNeeded era
forall era (l :: TxLevel).
EraTxBody era =>
UTxO era -> TxBody l era -> ShelleyScriptsNeeded era
getShelleyScriptsNeeded UTxO era
u TxBody l era
txBody of
    ShelleyScriptsNeeded Set ScriptHash
shelleyScriptsNeeded ->
      Set ScriptHash -> ShelleyScriptsNeeded era
forall era. Set ScriptHash -> ShelleyScriptsNeeded era
ShelleyScriptsNeeded (Set ScriptHash -> ShelleyScriptsNeeded era)
-> Set ScriptHash -> ShelleyScriptsNeeded era
forall a b. (a -> b) -> a -> b
$
        Set ScriptHash
shelleyScriptsNeeded Set ScriptHash -> Set ScriptHash -> Set ScriptHash
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (PolicyID -> ScriptHash) -> Set PolicyID -> Set ScriptHash
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map PolicyID -> ScriptHash
policyID (TxBody l era
txBody TxBody l era
-> Getting (Set PolicyID) (TxBody l era) (Set PolicyID)
-> Set PolicyID
forall s a. s -> Getting a s a -> a
^. Getting (Set PolicyID) (TxBody l era) (Set PolicyID)
forall era (l :: TxLevel).
MaryEraTxBody era =>
SimpleGetter (TxBody l era) (Set PolicyID)
forall (l :: TxLevel). SimpleGetter (TxBody l era) (Set PolicyID)
mintedTxBodyF)