{-# 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.Crypto
import Cardano.Ledger.Keys (KeyHash (..), KeyRole (..))
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 Crypto c => EraUTxO (MaryEra c) where
  type ScriptsNeeded (MaryEra c) = ShelleyScriptsNeeded (MaryEra c)

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

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

  getScriptsProvided :: UTxO (MaryEra c) -> Tx (MaryEra c) -> ScriptsProvided (MaryEra c)
getScriptsProvided UTxO (MaryEra c)
_ Tx (MaryEra c)
tx = forall era.
Map (ScriptHash (EraCrypto era)) (Script era)
-> ScriptsProvided era
ScriptsProvided (Tx (MaryEra c)
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 (EraCrypto era)) (Script era))
scriptTxWitsL)

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

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

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

  getMinFeeTxUtxo :: PParams (MaryEra c) -> Tx (MaryEra c) -> UTxO (MaryEra c) -> Coin
getMinFeeTxUtxo PParams (MaryEra c)
pp Tx (MaryEra c)
tx UTxO (MaryEra c)
_ = forall era. EraTx era => PParams era -> Tx era -> Coin
getShelleyMinFeeTxUtxo PParams (MaryEra c)
pp Tx (MaryEra c)
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 (EraCrypto era)) =>
  PParams era ->
  (Credential 'Staking (EraCrypto era) -> Maybe Coin) ->
  (Credential 'DRepRole (EraCrypto era) -> Maybe Coin) ->
  UTxO era ->
  TxBody era ->
  MaryValue (EraCrypto era)
getConsumedMaryValue :: forall era.
(MaryEraTxBody era, Value era ~ MaryValue (EraCrypto era)) =>
PParams era
-> (Credential 'Staking (EraCrypto era) -> Maybe Coin)
-> (Credential 'DRepRole (EraCrypto era) -> Maybe Coin)
-> UTxO era
-> TxBody era
-> MaryValue (EraCrypto era)
getConsumedMaryValue PParams era
pp Credential 'Staking (EraCrypto era) -> Maybe Coin
lookupStakingDeposit Credential 'DRepRole (EraCrypto era) -> Maybe Coin
lookupDRepDeposit UTxO era
utxo TxBody era
txBody =
  MaryValue (EraCrypto era)
consumedValue forall a. Semigroup a => a -> a -> a
<> forall c. Coin -> MultiAsset c -> MaryValue c
MaryValue forall a. Monoid a => a
mempty MultiAsset (EraCrypto era)
mintedMultiAsset
  where
    mintedMultiAsset :: MultiAsset (EraCrypto era)
mintedMultiAsset = forall c.
(PolicyID c -> AssetName -> Integer -> Bool)
-> MultiAsset c -> MultiAsset c
filterMultiAsset (\PolicyID (EraCrypto era)
_ 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 (EraCrypto era))
mintTxBodyL
    {- balance (txins tx ◁ u) + wbalance (txwdrls tx) + keyRefunds pp tx -}
    consumedValue :: MaryValue (EraCrypto era)
consumedValue =
      forall era. EraTxOut era => UTxO era -> Value era
balance (forall era. UTxO era -> Set (TxIn (EraCrypto era)) -> 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 (EraCrypto era)))
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 (EraCrypto era) -> Maybe Coin)
-> (Credential 'DRepRole (EraCrypto era) -> Maybe Coin)
-> TxBody era
-> Coin
getTotalRefundsTxBody PParams era
pp Credential 'Staking (EraCrypto era) -> Maybe Coin
lookupStakingDeposit Credential 'DRepRole (EraCrypto era) -> 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
. forall c. Withdrawals c -> Map (RewardAcnt c) 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 (EraCrypto era))
withdrawalsTxBodyL

getProducedMaryValue ::
  (MaryEraTxBody era, Value era ~ MaryValue (EraCrypto era)) =>
  PParams era ->
  -- | Check whether a pool with a supplied PoolStakeId is already registered.
  (KeyHash 'StakePool (EraCrypto era) -> Bool) ->
  TxBody era ->
  MaryValue (EraCrypto era)
getProducedMaryValue :: forall era.
(MaryEraTxBody era, Value era ~ MaryValue (EraCrypto era)) =>
PParams era
-> (KeyHash 'StakePool (EraCrypto era) -> Bool)
-> TxBody era
-> MaryValue (EraCrypto era)
getProducedMaryValue PParams era
pp KeyHash 'StakePool (EraCrypto era) -> Bool
isPoolRegistered TxBody era
txBody =
  forall era.
EraTxBody era =>
PParams era
-> (KeyHash 'StakePool (EraCrypto era) -> Bool)
-> TxBody era
-> Value era
shelleyProducedValue PParams era
pp KeyHash 'StakePool (EraCrypto era) -> Bool
isPoolRegistered TxBody era
txBody forall a. Semigroup a => a -> a -> a
<> forall c. Coin -> MultiAsset c -> MaryValue c
MaryValue forall a. Monoid a => a
mempty MultiAsset (EraCrypto era)
burnedMultiAsset
  where
    burnedMultiAsset :: MultiAsset (EraCrypto era)
burnedMultiAsset =
      forall c.
(PolicyID c -> AssetName -> Integer -> Maybe Integer)
-> MultiAsset c -> MultiAsset c
mapMaybeMultiAsset (\PolicyID (EraCrypto era)
_ 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 (EraCrypto era))
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 (EraCrypto era))
shelleyScriptsNeeded ->
      forall era.
Set (ScriptHash (EraCrypto era)) -> ShelleyScriptsNeeded era
ShelleyScriptsNeeded forall a b. (a -> b) -> a -> b
$
        Set (ScriptHash (EraCrypto era))
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 forall c. PolicyID c -> ScriptHash c
policyID (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
MaryEraTxBody era =>
SimpleGetter (TxBody era) (Set (PolicyID (EraCrypto era)))
mintedTxBodyF)