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

module Cardano.Ledger.Mary.UTxO (
  getConsumedMaryValue,
  getProducedMaryValue,
) 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 :: PParams MaryEra
-> CertState MaryEra
-> UTxO MaryEra
-> TxBody MaryEra
-> Value MaryEra
consumed = PParams MaryEra
-> CertState MaryEra
-> UTxO MaryEra
-> TxBody MaryEra
-> Value MaryEra
forall era.
(EraUTxO era, EraCertState era) =>
PParams era -> CertState era -> UTxO era -> TxBody era -> Value era
shelleyConsumed

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

  getProducedValue :: PParams MaryEra
-> (KeyHash 'StakePool -> Bool) -> TxBody MaryEra -> Value MaryEra
getProducedValue = PParams MaryEra
-> (KeyHash 'StakePool -> Bool) -> TxBody MaryEra -> Value MaryEra
PParams MaryEra
-> (KeyHash 'StakePool -> Bool) -> TxBody MaryEra -> MaryValue
forall era.
(MaryEraTxBody era, Value era ~ MaryValue) =>
PParams era
-> (KeyHash 'StakePool -> Bool) -> TxBody era -> MaryValue
getProducedMaryValue

  getScriptsProvided :: UTxO MaryEra -> Tx MaryEra -> ScriptsProvided MaryEra
getScriptsProvided UTxO MaryEra
_ Tx MaryEra
tx = Map ScriptHash (Script MaryEra) -> ScriptsProvided MaryEra
forall era. Map ScriptHash (Script era) -> ScriptsProvided era
ScriptsProvided (Tx MaryEra
ShelleyTx MaryEra
tx ShelleyTx MaryEra
-> Getting
     (Map ScriptHash (Timelock MaryEra))
     (ShelleyTx 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 MaryEra
-> Const (Map ScriptHash (Timelock MaryEra)) (Tx MaryEra)
(TxWits MaryEra
 -> Const (Map ScriptHash (Timelock MaryEra)) (TxWits MaryEra))
-> ShelleyTx MaryEra
-> Const (Map ScriptHash (Timelock MaryEra)) (ShelleyTx MaryEra)
forall era. EraTx era => Lens' (Tx era) (TxWits era)
Lens' (Tx MaryEra) (TxWits MaryEra)
witsTxL ((TxWits MaryEra
  -> Const (Map ScriptHash (Timelock MaryEra)) (TxWits MaryEra))
 -> ShelleyTx MaryEra
 -> Const (Map ScriptHash (Timelock MaryEra)) (ShelleyTx MaryEra))
-> ((Map ScriptHash (Timelock MaryEra)
     -> Const
          (Map ScriptHash (Timelock MaryEra))
          (Map ScriptHash (Timelock MaryEra)))
    -> TxWits MaryEra
    -> Const (Map ScriptHash (Timelock MaryEra)) (TxWits MaryEra))
-> Getting
     (Map ScriptHash (Timelock MaryEra))
     (ShelleyTx 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)))
-> TxWits MaryEra
-> Const (Map ScriptHash (Timelock MaryEra)) (TxWits 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 :: UTxO MaryEra -> TxBody MaryEra -> ScriptsNeeded MaryEra
getScriptsNeeded = UTxO MaryEra -> TxBody MaryEra -> ScriptsNeeded MaryEra
UTxO MaryEra -> TxBody MaryEra -> ShelleyScriptsNeeded MaryEra
forall era.
(ShelleyEraTxBody era, MaryEraTxBody era) =>
UTxO era -> TxBody era -> ShelleyScriptsNeeded era
getMaryScriptsNeeded

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

  getWitsVKeyNeeded :: CertState MaryEra
-> UTxO MaryEra -> TxBody MaryEra -> Set (KeyHash 'Witness)
getWitsVKeyNeeded = CertState MaryEra
-> UTxO MaryEra -> TxBody MaryEra -> Set (KeyHash 'Witness)
forall era.
(EraTx era, ShelleyEraTxBody era, EraCertState era) =>
CertState era -> UTxO era -> TxBody era -> Set (KeyHash 'Witness)
getShelleyWitsVKeyNeeded

  getMinFeeTxUtxo :: PParams MaryEra -> Tx MaryEra -> UTxO MaryEra -> Coin
getMinFeeTxUtxo PParams MaryEra
pp Tx MaryEra
tx UTxO MaryEra
_ = PParams MaryEra -> Tx MaryEra -> Coin
forall era. EraTx era => PParams era -> Tx era -> Coin
getShelleyMinFeeTxUtxo PParams MaryEra
pp Tx 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 era ->
  MaryValue
getConsumedMaryValue :: forall era.
(MaryEraTxBody era, Value era ~ MaryValue) =>
PParams era
-> (Credential 'Staking -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> UTxO era
-> TxBody era
-> MaryValue
getConsumedMaryValue PParams era
pp Credential 'Staking -> Maybe Coin
lookupStakingDeposit Credential 'DRepRole -> Maybe Coin
lookupDRepDeposit UTxO era
utxo TxBody 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 era
txBody TxBody era
-> Getting MultiAsset (TxBody era) MultiAsset -> MultiAsset
forall s a. s -> Getting a s a -> a
^. Getting MultiAsset (TxBody era) MultiAsset
forall era. MaryEraTxBody era => Lens' (TxBody era) MultiAsset
Lens' (TxBody 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 era
txBody TxBody era
-> Getting (Set TxIn) (TxBody era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody era) (Set TxIn)
forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
Lens' (TxBody 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 era
-> Coin
forall era.
EraTxBody era =>
PParams era
-> (Credential 'Staking -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> TxBody era
-> Coin
getTotalRefundsTxBody PParams era
pp Credential 'Staking -> Maybe Coin
lookupStakingDeposit Credential 'DRepRole -> Maybe Coin
lookupDRepDeposit TxBody 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 era
txBody TxBody era
-> Getting Withdrawals (TxBody era) Withdrawals -> Withdrawals
forall s a. s -> Getting a s a -> a
^. Getting Withdrawals (TxBody era) Withdrawals
forall era. EraTxBody era => Lens' (TxBody era) Withdrawals
Lens' (TxBody 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 era ->
  MaryValue
getProducedMaryValue :: forall era.
(MaryEraTxBody era, Value era ~ MaryValue) =>
PParams era
-> (KeyHash 'StakePool -> Bool) -> TxBody era -> MaryValue
getProducedMaryValue PParams era
pp KeyHash 'StakePool -> Bool
isPoolRegistered TxBody era
txBody =
  PParams era
-> (KeyHash 'StakePool -> Bool) -> TxBody era -> Value era
forall era.
EraTxBody era =>
PParams era
-> (KeyHash 'StakePool -> Bool) -> TxBody era -> Value era
shelleyProducedValue PParams era
pp KeyHash 'StakePool -> Bool
isPoolRegistered TxBody era
txBody MaryValue -> MaryValue -> MaryValue
forall a. Semigroup a => a -> a -> a
<> Coin -> MultiAsset -> MaryValue
MaryValue Coin
forall a. Monoid a => a
mempty MultiAsset
burnedMultiAsset
  where
    burnedMultiAsset :: MultiAsset
burnedMultiAsset =
      (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 era
txBody TxBody era
-> Getting MultiAsset (TxBody era) MultiAsset -> MultiAsset
forall s a. s -> Getting a s a -> a
^. Getting MultiAsset (TxBody era) MultiAsset
forall era. MaryEraTxBody era => Lens' (TxBody era) MultiAsset
Lens' (TxBody 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 era ->
  ShelleyScriptsNeeded era
getMaryScriptsNeeded :: forall era.
(ShelleyEraTxBody era, MaryEraTxBody era) =>
UTxO era -> TxBody era -> ShelleyScriptsNeeded era
getMaryScriptsNeeded UTxO era
u TxBody era
txBody =
  case UTxO era -> TxBody era -> ShelleyScriptsNeeded era
forall era.
EraTxBody era =>
UTxO era -> TxBody era -> ShelleyScriptsNeeded era
getShelleyScriptsNeeded UTxO era
u TxBody 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 era
txBody TxBody era
-> Getting (Set PolicyID) (TxBody era) (Set PolicyID)
-> Set PolicyID
forall s a. s -> Getting a s a -> a
^. Getting (Set PolicyID) (TxBody era) (Set PolicyID)
forall era.
MaryEraTxBody era =>
SimpleGetter (TxBody era) (Set PolicyID)
SimpleGetter (TxBody era) (Set PolicyID)
mintedTxBodyF)