{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Dijkstra.UTxO (
  getDijkstraScriptsNeeded,
) where

import Cardano.Ledger.Alonzo.UTxO (
  AlonzoEraUTxO (..),
  AlonzoScriptsNeeded (..),
  getAlonzoScriptsHashesNeeded,
  zipAsIxItem,
 )
import Cardano.Ledger.Babbage.UTxO (
  getBabbageScriptsProvided,
  getBabbageSpendingDatum,
  getBabbageSupplementalDataHashes,
 )
import Cardano.Ledger.BaseTypes (inject)
import Cardano.Ledger.Conway.UTxO (
  conwayConsumed,
  conwayProducedValue,
  getConwayMinFeeTxUtxo,
  getConwayScriptsNeeded,
  getConwayWitsVKeyNeeded,
 )
import Cardano.Ledger.Credential (credScriptHash)
import Cardano.Ledger.Dijkstra.Core
import Cardano.Ledger.Dijkstra.Era (DijkstraEra)
import Cardano.Ledger.Dijkstra.Scripts (DijkstraEraScript (..), pattern GuardingPurpose)
import Cardano.Ledger.Dijkstra.State
import Cardano.Ledger.Dijkstra.Tx ()
import Cardano.Ledger.Dijkstra.TxBody (DijkstraEraTxBody (..))
import Cardano.Ledger.Mary.UTxO (burnedMultiAssets, getConsumedMaryValue)
import Cardano.Ledger.Mary.Value (MaryValue)
import Data.Maybe (catMaybes)
import Lens.Micro ((^.))

instance EraUTxO DijkstraEra where
  type ScriptsNeeded DijkstraEra = AlonzoScriptsNeeded DijkstraEra

  consumed :: forall (t :: TxLevel).
PParams DijkstraEra
-> CertState DijkstraEra
-> UTxO DijkstraEra
-> TxBody t DijkstraEra
-> Value DijkstraEra
consumed = PParams DijkstraEra
-> CertState DijkstraEra
-> UTxO DijkstraEra
-> TxBody t DijkstraEra
-> Value DijkstraEra
forall era (l :: TxLevel).
(EraUTxO era, ConwayEraCertState era) =>
PParams era
-> CertState era -> UTxO era -> TxBody l era -> Value era
conwayConsumed

  getConsumedValue :: forall (t :: TxLevel).
PParams DijkstraEra
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> UTxO DijkstraEra
-> TxBody t DijkstraEra
-> Value DijkstraEra
getConsumedValue = PParams DijkstraEra
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> UTxO DijkstraEra
-> TxBody t DijkstraEra
-> Value DijkstraEra
PParams DijkstraEra
-> (Credential Staking -> Maybe Coin)
-> (Credential DRepRole -> Maybe Coin)
-> UTxO DijkstraEra
-> TxBody t DijkstraEra
-> 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 DijkstraEra
-> (KeyHash StakePool -> Bool)
-> TxBody t DijkstraEra
-> Value DijkstraEra
getProducedValue PParams DijkstraEra
pp KeyHash StakePool -> Bool
isRegPoolId TxBody t DijkstraEra
txBody =
    TxBody t DijkstraEra
-> (TxBody TopTx DijkstraEra -> MaryValue)
-> (TxBody SubTx DijkstraEra -> MaryValue)
-> MaryValue
forall (t :: TxLevel -> * -> *) era (l :: TxLevel) a.
(HasEraTxLevel t era, STxLevel l era ~ STxBothLevels l era) =>
t l era -> (t TopTx era -> a) -> (t SubTx era -> a) -> a
withBothTxLevels
      TxBody t DijkstraEra
txBody
      (PParams DijkstraEra
-> (KeyHash StakePool -> Bool)
-> TxBody TopTx DijkstraEra
-> Value DijkstraEra
forall era.
(ConwayEraTxBody era, Value era ~ MaryValue) =>
PParams era
-> (KeyHash StakePool -> Bool) -> TxBody TopTx era -> Value era
conwayProducedValue PParams DijkstraEra
pp KeyHash StakePool -> Bool
isRegPoolId)
      (PParams DijkstraEra
-> (KeyHash StakePool -> Bool)
-> TxBody SubTx DijkstraEra
-> Value DijkstraEra
forall era.
(ConwayEraTxBody era, Value era ~ MaryValue) =>
PParams era
-> (KeyHash StakePool -> Bool) -> TxBody SubTx era -> Value era
dijkstraSubTxProducedValue PParams DijkstraEra
pp KeyHash StakePool -> Bool
isRegPoolId)

  getScriptsProvided :: forall (t :: TxLevel).
UTxO DijkstraEra -> Tx t DijkstraEra -> ScriptsProvided DijkstraEra
getScriptsProvided = UTxO DijkstraEra -> Tx t DijkstraEra -> ScriptsProvided DijkstraEra
forall era (l :: TxLevel).
(EraTx era, BabbageEraTxBody era) =>
UTxO era -> Tx l era -> ScriptsProvided era
getBabbageScriptsProvided

  getScriptsNeeded :: forall (t :: TxLevel).
UTxO DijkstraEra
-> TxBody t DijkstraEra -> ScriptsNeeded DijkstraEra
getScriptsNeeded = UTxO DijkstraEra
-> TxBody t DijkstraEra -> ScriptsNeeded DijkstraEra
UTxO DijkstraEra
-> TxBody t DijkstraEra -> AlonzoScriptsNeeded DijkstraEra
forall era (l :: TxLevel).
(DijkstraEraTxBody era, DijkstraEraScript era) =>
UTxO era -> TxBody l era -> AlonzoScriptsNeeded era
getDijkstraScriptsNeeded

  getScriptsHashesNeeded :: ScriptsNeeded DijkstraEra -> Set ScriptHash
getScriptsHashesNeeded = ScriptsNeeded DijkstraEra -> Set ScriptHash
AlonzoScriptsNeeded DijkstraEra -> Set ScriptHash
forall era. AlonzoScriptsNeeded era -> Set ScriptHash
getAlonzoScriptsHashesNeeded

  getWitsVKeyNeeded :: forall (t :: TxLevel).
CertState DijkstraEra
-> UTxO DijkstraEra
-> TxBody t DijkstraEra
-> Set (KeyHash Witness)
getWitsVKeyNeeded CertState DijkstraEra
_ = UTxO DijkstraEra -> TxBody t DijkstraEra -> Set (KeyHash Witness)
forall era (l :: TxLevel).
(EraTx era, ConwayEraTxBody era) =>
UTxO era -> TxBody l era -> Set (KeyHash Witness)
getConwayWitsVKeyNeeded

  getMinFeeTxUtxo :: forall (t :: TxLevel).
PParams DijkstraEra -> Tx t DijkstraEra -> UTxO DijkstraEra -> Coin
getMinFeeTxUtxo = PParams DijkstraEra -> Tx t DijkstraEra -> UTxO DijkstraEra -> Coin
forall era (l :: TxLevel).
(EraTx era, BabbageEraTxBody era) =>
PParams era -> Tx l era -> UTxO era -> Coin
getConwayMinFeeTxUtxo

getDijkstraScriptsNeeded ::
  (DijkstraEraTxBody era, DijkstraEraScript era) =>
  UTxO era -> TxBody l era -> AlonzoScriptsNeeded era
getDijkstraScriptsNeeded :: forall era (l :: TxLevel).
(DijkstraEraTxBody era, DijkstraEraScript era) =>
UTxO era -> TxBody l era -> AlonzoScriptsNeeded era
getDijkstraScriptsNeeded UTxO era
utxo TxBody l era
txb =
  UTxO era -> TxBody l era -> AlonzoScriptsNeeded era
forall era (l :: TxLevel).
ConwayEraTxBody era =>
UTxO era -> TxBody l era -> AlonzoScriptsNeeded era
getConwayScriptsNeeded UTxO era
utxo TxBody l era
txb
    AlonzoScriptsNeeded era
-> AlonzoScriptsNeeded era -> AlonzoScriptsNeeded era
forall a. Semigroup a => a -> a -> a
<> AlonzoScriptsNeeded era
guardingScriptsNeeded
  where
    guardingScriptsNeeded :: AlonzoScriptsNeeded era
guardingScriptsNeeded = [(PlutusPurpose AsIxItem era, ScriptHash)]
-> AlonzoScriptsNeeded era
forall era.
[(PlutusPurpose AsIxItem era, ScriptHash)]
-> AlonzoScriptsNeeded era
AlonzoScriptsNeeded ([(PlutusPurpose AsIxItem era, ScriptHash)]
 -> AlonzoScriptsNeeded era)
-> [(PlutusPurpose AsIxItem era, ScriptHash)]
-> AlonzoScriptsNeeded era
forall a b. (a -> b) -> a -> b
$
      [Maybe (PlutusPurpose AsIxItem era, ScriptHash)]
-> [(PlutusPurpose AsIxItem era, ScriptHash)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (PlutusPurpose AsIxItem era, ScriptHash)]
 -> [(PlutusPurpose AsIxItem era, ScriptHash)])
-> [Maybe (PlutusPurpose AsIxItem era, ScriptHash)]
-> [(PlutusPurpose AsIxItem era, ScriptHash)]
forall a b. (a -> b) -> a -> b
$
        OSet (Credential Guard)
-> (AsIxItem Word32 (Credential Guard)
    -> Maybe (PlutusPurpose AsIxItem era, ScriptHash))
-> [Maybe (PlutusPurpose AsIxItem era, ScriptHash)]
forall (f :: * -> *) it c.
Foldable f =>
f it -> (AsIxItem Word32 it -> c) -> [c]
zipAsIxItem (TxBody l era
txb TxBody l era
-> Getting
     (OSet (Credential Guard)) (TxBody l era) (OSet (Credential Guard))
-> OSet (Credential Guard)
forall s a. s -> Getting a s a -> a
^. Getting
  (OSet (Credential Guard)) (TxBody l era) (OSet (Credential Guard))
forall era (l :: TxLevel).
DijkstraEraTxBody era =>
Lens' (TxBody l era) (OSet (Credential Guard))
forall (l :: TxLevel).
Lens' (TxBody l era) (OSet (Credential Guard))
guardsTxBodyL) ((AsIxItem Word32 (Credential Guard)
  -> Maybe (PlutusPurpose AsIxItem era, ScriptHash))
 -> [Maybe (PlutusPurpose AsIxItem era, ScriptHash)])
-> (AsIxItem Word32 (Credential Guard)
    -> Maybe (PlutusPurpose AsIxItem era, ScriptHash))
-> [Maybe (PlutusPurpose AsIxItem era, ScriptHash)]
forall a b. (a -> b) -> a -> b
$
          \(AsIxItem Word32
idx Credential Guard
cred) -> (\ScriptHash
sh -> (AsIxItem Word32 ScriptHash -> PlutusPurpose AsIxItem era
forall era (f :: * -> * -> *).
DijkstraEraScript era =>
f Word32 ScriptHash -> PlutusPurpose f era
GuardingPurpose (Word32 -> ScriptHash -> AsIxItem Word32 ScriptHash
forall ix it. ix -> it -> AsIxItem ix it
AsIxItem Word32
idx ScriptHash
sh), ScriptHash
sh)) (ScriptHash -> (PlutusPurpose AsIxItem era, ScriptHash))
-> Maybe ScriptHash
-> Maybe (PlutusPurpose AsIxItem era, ScriptHash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Credential Guard -> Maybe ScriptHash
forall (kr :: KeyRole). Credential kr -> Maybe ScriptHash
credScriptHash Credential Guard
cred

instance AlonzoEraUTxO DijkstraEra where
  getSupplementalDataHashes :: forall (l :: TxLevel).
UTxO DijkstraEra -> TxBody l DijkstraEra -> Set DataHash
getSupplementalDataHashes = UTxO DijkstraEra -> TxBody l DijkstraEra -> Set DataHash
forall era (l :: TxLevel).
BabbageEraTxBody era =>
UTxO era -> TxBody l era -> Set DataHash
getBabbageSupplementalDataHashes

  getSpendingDatum :: forall (l :: TxLevel).
UTxO DijkstraEra
-> Tx l DijkstraEra
-> PlutusPurpose AsItem DijkstraEra
-> Maybe (Data DijkstraEra)
getSpendingDatum = UTxO DijkstraEra
-> Tx l DijkstraEra
-> PlutusPurpose AsItem DijkstraEra
-> Maybe (Data DijkstraEra)
forall era (l :: TxLevel).
(AlonzoEraTx era, BabbageEraTxOut era) =>
UTxO era
-> Tx l era -> PlutusPurpose AsItem era -> Maybe (Data era)
getBabbageSpendingDatum

dijkstraSubTxProducedValue ::
  (ConwayEraTxBody era, Value era ~ MaryValue) =>
  PParams era ->
  (KeyHash StakePool -> Bool) ->
  TxBody SubTx era ->
  Value era
dijkstraSubTxProducedValue :: forall era.
(ConwayEraTxBody era, Value era ~ MaryValue) =>
PParams era
-> (KeyHash StakePool -> Bool) -> TxBody SubTx era -> Value era
dijkstraSubTxProducedValue PParams era
pp KeyHash StakePool -> Bool
isRegPoolId TxBody SubTx era
txBody =
  StrictSeq (TxOut era) -> Value era
forall era (f :: * -> *).
(EraTxOut era, Foldable f) =>
f (TxOut era) -> Value era
sumAllValue (TxBody SubTx era
txBody TxBody SubTx era
-> Getting
     (StrictSeq (TxOut era)) (TxBody SubTx era) (StrictSeq (TxOut era))
-> StrictSeq (TxOut era)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictSeq (TxOut era)) (TxBody SubTx era) (StrictSeq (TxOut era))
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (StrictSeq (TxOut era))
forall (l :: TxLevel). Lens' (TxBody l era) (StrictSeq (TxOut era))
outputsTxBodyL)
    MaryValue -> MaryValue -> MaryValue
forall a. Semigroup a => a -> a -> a
<> Coin -> MaryValue
forall t s. Inject t s => t -> s
inject (PParams era
-> (KeyHash StakePool -> Bool) -> TxBody SubTx era -> Coin
forall era (l :: TxLevel).
EraTxBody era =>
PParams era -> (KeyHash StakePool -> Bool) -> TxBody l era -> Coin
forall (l :: TxLevel).
PParams era -> (KeyHash StakePool -> Bool) -> TxBody l era -> Coin
getTotalDepositsTxBody PParams era
pp KeyHash StakePool -> Bool
isRegPoolId TxBody SubTx era
txBody Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> TxBody SubTx era
txBody TxBody SubTx era -> Getting Coin (TxBody SubTx era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxBody SubTx era) Coin
forall era (l :: TxLevel).
ConwayEraTxBody era =>
Lens' (TxBody l era) Coin
forall (l :: TxLevel). Lens' (TxBody l era) Coin
treasuryDonationTxBodyL)
    MaryValue -> MaryValue -> MaryValue
forall a. Semigroup a => a -> a -> a
<> TxBody SubTx era -> MaryValue
forall era (l :: TxLevel).
MaryEraTxBody era =>
TxBody l era -> MaryValue
burnedMultiAssets TxBody SubTx era
txBody