{-# 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.Value (MaryValue (..), filterMultiAsset, mapMaybeMultiAsset, policyID)
import Cardano.Ledger.Shelley.UTxO (
  ShelleyScriptsNeeded (..),
  getShelleyMinFeeTxUtxo,
  getShelleyScriptsNeeded,
  getShelleyWitsVKeyNeeded,
  shelleyProducedValue,
 )
import Cardano.Ledger.UTxO (
  EraUTxO (..),
  ScriptsProvided (..),
  UTxO,
  balance,
  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

  getConsumedValue :: PParams MaryEra
-> (Credential 'Staking -> Maybe Coin)
-> (Credential 'DRepRole -> Maybe Coin)
-> UTxO MaryEra
-> TxBody MaryEra
-> Value MaryEra
getConsumedValue = 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 = 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 = forall era. Map ScriptHash (Script era) -> ScriptsProvided era
ScriptsProvided (Tx MaryEra
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL)

  getScriptsNeeded :: UTxO MaryEra -> TxBody MaryEra -> ScriptsNeeded MaryEra
getScriptsNeeded = 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 = forall era.
(EraTx era, ShelleyEraTxBody 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
_ = 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 forall a. Semigroup a => a -> a -> a
<> Coin -> MultiAsset -> MaryValue
MaryValue forall a. Monoid a => a
mempty MultiAsset
mintedMultiAsset
  where
    mintedMultiAsset :: MultiAsset
mintedMultiAsset = (PolicyID -> AssetName -> Integer -> Bool)
-> MultiAsset -> MultiAsset
filterMultiAsset (\PolicyID
_ AssetName
_ -> (forall a. Ord a => a -> a -> Bool
> Integer
0)) forall a b. (a -> b) -> a -> b
$ TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. MaryEraTxBody era => Lens' (TxBody era) MultiAsset
mintTxBodyL
    {- balance (txins tx ◁ u) + wbalance (txwdrls tx) + keyRefunds pp tx -}
    consumedValue :: MaryValue
consumedValue =
      forall era. EraTxOut era => UTxO era -> Value era
balance (forall era. UTxO era -> Set TxIn -> UTxO era
txInsFilter UTxO era
utxo (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL))
        forall a. Semigroup a => a -> a -> a
<> forall t s. Inject t s => t -> s
inject (Coin
refunds forall a. Semigroup a => a -> a -> a
<> Coin
withdrawals)
    refunds :: Coin
refunds = 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 = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. Withdrawals -> Map RewardAccount Coin
unWithdrawals forall a b. (a -> b) -> a -> b
$ TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => 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 =
  forall era.
EraTxBody era =>
PParams era
-> (KeyHash 'StakePool -> Bool) -> TxBody era -> Value era
shelleyProducedValue PParams era
pp KeyHash 'StakePool -> Bool
isPoolRegistered TxBody era
txBody forall a. Semigroup a => a -> a -> a
<> Coin -> MultiAsset -> MaryValue
MaryValue 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 forall a. Ord a => a -> a -> Bool
< Integer
0 then forall a. a -> Maybe a
Just (forall a. Num a => a -> a
negate Integer
v) else forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$
        TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. MaryEraTxBody era => 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 forall era.
EraTxBody era =>
UTxO era -> TxBody era -> ShelleyScriptsNeeded era
getShelleyScriptsNeeded UTxO era
u TxBody era
txBody of
    ShelleyScriptsNeeded Set ScriptHash
shelleyScriptsNeeded ->
      forall era. Set ScriptHash -> ShelleyScriptsNeeded era
ShelleyScriptsNeeded forall a b. (a -> b) -> a -> b
$
        Set ScriptHash
shelleyScriptsNeeded forall a. Ord a => Set a -> Set a -> Set a
`Set.union` forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map PolicyID -> ScriptHash
policyID (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
MaryEraTxBody era =>
SimpleGetter (TxBody era) (Set PolicyID)
mintedTxBodyF)