{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Functions in this module take a (Proof era) as their first
--   parameter and do something potentially different in each Era.
module Test.Cardano.Ledger.Generic.Functions where

import Cardano.Ledger.Address (Addr (..))
import Cardano.Ledger.Alonzo.Scripts (plutusScriptLanguage)
import Cardano.Ledger.Alonzo.Tx (AlonzoTx (..), IsValid (..))
import Cardano.Ledger.Alonzo.TxBody (AlonzoTxOut (..))
import Cardano.Ledger.Babbage.TxBody (BabbageTxOut (..))
import Cardano.Ledger.Babbage.UTxO (getReferenceScripts)
import Cardano.Ledger.BaseTypes (
  BlocksMade (BlocksMade),
  Globals (epochInfo),
  ProtVer (..),
  natVersion,
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.State (ChainAccountState (..), VState (..))
import Cardano.Ledger.Credential (Credential, StakeReference (..))
import Cardano.Ledger.Plutus.Data (Datum (..), binaryDataToData, hashData)
import Cardano.Ledger.Plutus.ExUnits (ExUnits (..))
import Cardano.Ledger.Plutus.Language (Language (..))
import Cardano.Ledger.Shelley.AdaPots (AdaPots (..), totalAdaPotsES)
import Cardano.Ledger.Shelley.LedgerState (
  CertState,
  DState (..),
  EpochState (..),
  LedgerState (..),
  NewEpochState (..),
  PState (..),
  UTxOState (..),
 )
import Cardano.Ledger.Shelley.State (ShelleyCertState (..))
import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..))
import Cardano.Ledger.State (EraUTxO (..), UTxO (..), coinBalance, unScriptsProvided)
import Cardano.Ledger.TxIn (TxIn (..))
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.Val (Val ((<+>), (<->)), inject)
import Cardano.Slotting.EpochInfo.API (epochInfoSize)
import Control.Monad.Reader (runReader)
import Data.Default (Default (def))
import qualified Data.Foldable as Fold (fold, toList)
import qualified Data.List as List
import Data.Map (Map, keysSet, restrictKeys)
import qualified Data.Map.Strict as Map
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Sequence.Strict (StrictSeq)
import Data.Set (Set)
import qualified Data.Set as Set
import Lens.Micro
import Numeric.Natural
import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysFailsLang, alwaysSucceedsLang)
import Test.Cardano.Ledger.Generic.Fields (TxOutField (..))
import Test.Cardano.Ledger.Generic.ModelState (MUtxo, Model, ModelNewEpochState (..))
import Test.Cardano.Ledger.Generic.Proof (Proof (..), Reflect (..))
import Test.Cardano.Ledger.Generic.Scriptic (Scriptic (..))
import qualified Test.Cardano.Ledger.Generic.Scriptic as Scriptic
import Test.Cardano.Ledger.Shelley.Rewards (RewardUpdateOld, createRUpdOld_)
import Test.Cardano.Ledger.Shelley.Utils (testGlobals)

-- ====================================================================
-- Era agnostic actions on (PParams era) (TxOut era) and
-- other XX types Mostly by pattern matching against Proof objects

maxCollateralInputs' :: Proof era -> PParams era -> Natural
maxCollateralInputs' :: forall era. Proof era -> PParams era -> Natural
maxCollateralInputs' Proof era
Alonzo PParams era
pp = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => Lens' (PParams era) Natural
ppMaxCollateralInputsL
maxCollateralInputs' Proof era
Babbage PParams era
pp = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => Lens' (PParams era) Natural
ppMaxCollateralInputsL
maxCollateralInputs' Proof era
Conway PParams era
pp = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => Lens' (PParams era) Natural
ppMaxCollateralInputsL
maxCollateralInputs' Proof era
_proof PParams era
_pp = Natural
0
{-# NOINLINE maxCollateralInputs' #-}

maxTxExUnits' :: Proof era -> PParams era -> ExUnits
maxTxExUnits' :: forall era. Proof era -> PParams era -> ExUnits
maxTxExUnits' Proof era
Alonzo PParams era
pp = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
ppMaxTxExUnitsL
maxTxExUnits' Proof era
Babbage PParams era
pp = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
ppMaxTxExUnitsL
maxTxExUnits' Proof era
Conway PParams era
pp = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => Lens' (PParams era) ExUnits
ppMaxTxExUnitsL
maxTxExUnits' Proof era
_proof PParams era
_x = forall a. Monoid a => a
mempty
{-# NOINLINE maxTxExUnits' #-}

collateralPercentage' :: Proof era -> PParams era -> Natural
collateralPercentage' :: forall era. Proof era -> PParams era -> Natural
collateralPercentage' Proof era
Alonzo PParams era
pp = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => Lens' (PParams era) Natural
ppCollateralPercentageL
collateralPercentage' Proof era
Babbage PParams era
pp = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => Lens' (PParams era) Natural
ppCollateralPercentageL
collateralPercentage' Proof era
Conway PParams era
pp = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraPParams era => Lens' (PParams era) Natural
ppCollateralPercentageL
collateralPercentage' Proof era
_proof PParams era
_pp = Natural
0
{-# NOINLINE collateralPercentage' #-}

protocolVersion :: Proof era -> ProtVer
protocolVersion :: forall era. Proof era -> ProtVer
protocolVersion Proof era
Conway = Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @9) Natural
0
protocolVersion Proof era
Babbage = Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @7) Natural
0
protocolVersion Proof era
Alonzo = Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @6) Natural
0
protocolVersion Proof era
Mary = Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @4) Natural
0
protocolVersion Proof era
Allegra = Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @3) Natural
0
protocolVersion Proof era
Shelley = Version -> Natural -> ProtVer
ProtVer (forall (v :: Natural).
(KnownNat v, MinVersion <= v, v <= MaxVersion) =>
Version
natVersion @2) Natural
0
{-# NOINLINE protocolVersion #-}

-- | Positive numbers are "deposits owed", negative amounts are "refunds gained"
depositsAndRefunds ::
  (EraPParams era, ShelleyEraTxCert era) =>
  PParams era ->
  [TxCert era] ->
  Map (Credential 'Staking) Coin ->
  Coin
depositsAndRefunds :: forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era
-> [TxCert era] -> Map (Credential 'Staking) Coin -> Coin
depositsAndRefunds PParams era
pp [TxCert era]
certificates Map (Credential 'Staking) Coin
keydeposits = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl' Coin -> TxCert era -> Coin
accum (Integer -> Coin
Coin Integer
0) [TxCert era]
certificates
  where
    accum :: Coin -> TxCert era -> Coin
accum Coin
ans (RegTxCert Credential 'Staking
_) = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppKeyDepositL forall t. Val t => t -> t -> t
<+> Coin
ans
    accum Coin
ans (UnRegTxCert Credential 'Staking
hk) =
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'Staking
hk Map (Credential 'Staking) Coin
keydeposits of
        Maybe Coin
Nothing -> Coin
ans
        Just Coin
c -> Coin
ans forall t. Val t => t -> t -> t
<-> Coin
c
    accum Coin
ans (RegPoolTxCert PoolParams
_) = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era. EraPParams era => Lens' (PParams era) Coin
ppPoolDepositL forall t. Val t => t -> t -> t
<+> Coin
ans
    accum Coin
ans (RetirePoolTxCert KeyHash 'StakePool
_ EpochNo
_) = Coin
ans -- The pool reward is refunded at the end of the epoch
    accum Coin
ans TxCert era
_ = Coin
ans

-- | Compute the set of ScriptHashes for which there should be ScriptWitnesses. In Babbage
--  Era and later, where inline Scripts are allowed, they should not appear in this set.
scriptWitsNeeded' :: Proof era -> MUtxo era -> TxBody era -> Set ScriptHash
scriptWitsNeeded' :: forall era. Proof era -> MUtxo era -> TxBody era -> Set ScriptHash
scriptWitsNeeded' Proof era
Conway MUtxo era
utxo TxBody era
txBody = Set ScriptHash
regularScripts forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ScriptHash
inlineScripts
  where
    theUtxo :: UTxO era
theUtxo = forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo
    inputs :: Set TxIn
inputs = TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL
    inlineScripts :: Set ScriptHash
inlineScripts = forall k a. Map k a -> Set k
keysSet forall a b. (a -> b) -> a -> b
$ forall era.
BabbageEraTxOut era =>
UTxO era -> Set TxIn -> Map ScriptHash (Script era)
getReferenceScripts UTxO era
theUtxo Set TxIn
inputs
    regularScripts :: Set ScriptHash
regularScripts = forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO era
theUtxo TxBody era
txBody)
scriptWitsNeeded' Proof era
Babbage MUtxo era
utxo TxBody era
txBody = Set ScriptHash
regularScripts forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ScriptHash
inlineScripts
  where
    theUtxo :: UTxO era
theUtxo = forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo
    inputs :: Set TxIn
inputs = (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL) forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. BabbageEraTxBody era => Lens' (TxBody era) (Set TxIn)
referenceInputsTxBodyL)
    inlineScripts :: Set ScriptHash
inlineScripts = forall k a. Map k a -> Set k
keysSet forall a b. (a -> b) -> a -> b
$ forall era.
BabbageEraTxOut era =>
UTxO era -> Set TxIn -> Map ScriptHash (Script era)
getReferenceScripts UTxO era
theUtxo Set TxIn
inputs
    regularScripts :: Set ScriptHash
regularScripts = forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO era
theUtxo TxBody era
txBody)
scriptWitsNeeded' Proof era
Alonzo MUtxo era
utxo TxBody era
txBody =
  forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody era
txBody)
scriptWitsNeeded' Proof era
Mary MUtxo era
utxo TxBody era
txBody =
  forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody era
txBody)
scriptWitsNeeded' Proof era
Allegra MUtxo era
utxo TxBody era
txBody =
  forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody era
txBody)
scriptWitsNeeded' Proof era
Shelley MUtxo era
utxo TxBody era
txBody =
  forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody era
txBody)
{-# NOINLINE scriptWitsNeeded' #-}

scriptsNeeded' :: Proof era -> MUtxo era -> TxBody era -> Set ScriptHash
scriptsNeeded' :: forall era. Proof era -> MUtxo era -> TxBody era -> Set ScriptHash
scriptsNeeded' Proof era
Conway MUtxo era
utxo TxBody era
txBody =
  forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody era
txBody)
scriptsNeeded' Proof era
Babbage MUtxo era
utxo TxBody era
txBody =
  forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody era
txBody)
scriptsNeeded' Proof era
Alonzo MUtxo era
utxo TxBody era
txBody =
  forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody era
txBody)
scriptsNeeded' Proof era
Mary MUtxo era
utxo TxBody era
txBody =
  forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody era
txBody)
scriptsNeeded' Proof era
Allegra MUtxo era
utxo TxBody era
txBody =
  forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody era
txBody)
scriptsNeeded' Proof era
Shelley MUtxo era
utxo TxBody era
txBody =
  forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody era
txBody)
{-# NOINLINE scriptsNeeded' #-}

txInBalance ::
  forall era.
  EraTxOut era =>
  Set TxIn ->
  MUtxo era ->
  Coin
txInBalance :: forall era. EraTxOut era => Set TxIn -> MUtxo era -> Coin
txInBalance Set TxIn
txinSet MUtxo era
m = forall era. EraTxOut era => UTxO era -> Coin
coinBalance (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (forall k a. Ord k => Map k a -> Set k -> Map k a
restrictKeys MUtxo era
m Set TxIn
txinSet))

-- | Break a TxOut into its mandatory and optional parts
txoutFields :: Proof era -> TxOut era -> (Addr, Value era, [TxOutField era])
txoutFields :: forall era.
Proof era -> TxOut era -> (Addr, Value era, [TxOutField era])
txoutFields Proof era
Conway (BabbageTxOut Addr
addr Value era
val Datum era
d StrictMaybe (Script era)
h) = (Addr
addr, Value era
val, [forall era. Datum era -> TxOutField era
FDatum Datum era
d, forall era. StrictMaybe (Script era) -> TxOutField era
RefScript StrictMaybe (Script era)
h])
txoutFields Proof era
Babbage (BabbageTxOut Addr
addr Value era
val Datum era
d StrictMaybe (Script era)
h) = (Addr
addr, Value era
val, [forall era. Datum era -> TxOutField era
FDatum Datum era
d, forall era. StrictMaybe (Script era) -> TxOutField era
RefScript StrictMaybe (Script era)
h])
txoutFields Proof era
Alonzo (AlonzoTxOut Addr
addr Value AlonzoEra
val StrictMaybe DataHash
dh) = (Addr
addr, Value AlonzoEra
val, [forall era. StrictMaybe DataHash -> TxOutField era
DHash StrictMaybe DataHash
dh])
txoutFields Proof era
Mary (ShelleyTxOut Addr
addr Value MaryEra
val) = (Addr
addr, Value MaryEra
val, [])
txoutFields Proof era
Allegra (ShelleyTxOut Addr
addr Value AllegraEra
val) = (Addr
addr, Value AllegraEra
val, [])
txoutFields Proof era
Shelley (ShelleyTxOut Addr
addr Value ShelleyEra
val) = (Addr
addr, Value ShelleyEra
val, [])
{-# NOINLINE txoutFields #-}

injectFee :: EraTxOut era => Proof era -> Coin -> TxOut era -> TxOut era
injectFee :: forall era.
EraTxOut era =>
Proof era -> Coin -> TxOut era -> TxOut era
injectFee Proof era
_ Coin
fee TxOut era
txOut = TxOut era
txOut forall a b. a -> (a -> b) -> b
& forall era. EraTxOut era => Lens' (TxOut era) (Value era)
valueTxOutL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall t. Val t => t -> t -> t
<+> forall t s. Inject t s => t -> s
inject Coin
fee)

getTxOutRefScript :: Proof era -> TxOut era -> StrictMaybe (Script era)
getTxOutRefScript :: forall era. Proof era -> TxOut era -> StrictMaybe (Script era)
getTxOutRefScript Proof era
Conway (BabbageTxOut Addr
_ Value ConwayEra
_ Datum ConwayEra
_ StrictMaybe (Script ConwayEra)
ms) = StrictMaybe (Script ConwayEra)
ms
getTxOutRefScript Proof era
Babbage (BabbageTxOut Addr
_ Value BabbageEra
_ Datum BabbageEra
_ StrictMaybe (Script BabbageEra)
ms) = StrictMaybe (Script BabbageEra)
ms
getTxOutRefScript Proof era
_ TxOut era
_ = forall a. StrictMaybe a
SNothing
{-# NOINLINE getTxOutRefScript #-}

emptyPPUPstate :: forall era. Proof era -> ShelleyGovState era
emptyPPUPstate :: forall era. Proof era -> ShelleyGovState era
emptyPPUPstate Proof era
Conway = forall a. Default a => a
def
emptyPPUPstate Proof era
Babbage = forall a. Default a => a
def
emptyPPUPstate Proof era
Alonzo = forall a. Default a => a
def
emptyPPUPstate Proof era
Mary = forall a. Default a => a
def
emptyPPUPstate Proof era
Allegra = forall a. Default a => a
def
emptyPPUPstate Proof era
Shelley = forall a. Default a => a
def
{-# NOINLINE emptyPPUPstate #-}

maxRefInputs :: Proof era -> Int
maxRefInputs :: forall era. Proof era -> Int
maxRefInputs Proof era
Babbage = Int
3
maxRefInputs Proof era
_ = Int
0

isValid' :: Proof era -> Tx era -> IsValid
isValid' :: forall era. Proof era -> Tx era -> IsValid
isValid' Proof era
Conway Tx era
x = forall era. AlonzoTx era -> IsValid
isValid Tx era
x
isValid' Proof era
Babbage Tx era
x = forall era. AlonzoTx era -> IsValid
isValid Tx era
x
isValid' Proof era
Alonzo Tx era
x = forall era. AlonzoTx era -> IsValid
isValid Tx era
x
isValid' Proof era
_ Tx era
_ = Bool -> IsValid
IsValid Bool
True
{-# NOINLINE isValid' #-}

-- | Does the TxOut have evidence of credentials and data.
--   Evidence of data is either ScriptHash or (in Babbage) an inline Datum
--   Evidence of credentials can come from the Addr
txoutEvidence ::
  forall era.
  Proof era ->
  TxOut era ->
  ([Credential 'Payment], Maybe DataHash)
txoutEvidence :: forall era.
Proof era -> TxOut era -> ([Credential 'Payment], Maybe DataHash)
txoutEvidence Proof era
Alonzo (AlonzoTxOut Addr
addr Value AlonzoEra
_ (SJust DataHash
dh)) =
  (Addr -> [Credential 'Payment]
addrCredentials Addr
addr, forall a. a -> Maybe a
Just DataHash
dh)
txoutEvidence Proof era
Alonzo (AlonzoTxOut Addr
addr Value AlonzoEra
_ StrictMaybe DataHash
SNothing) =
  (Addr -> [Credential 'Payment]
addrCredentials Addr
addr, forall a. Maybe a
Nothing)
txoutEvidence Proof era
Conway (BabbageTxOut Addr
addr Value ConwayEra
_ Datum ConwayEra
NoDatum StrictMaybe (Script ConwayEra)
_) =
  (Addr -> [Credential 'Payment]
addrCredentials Addr
addr, forall a. Maybe a
Nothing)
txoutEvidence Proof era
Conway (BabbageTxOut Addr
addr Value ConwayEra
_ (DatumHash DataHash
dh) StrictMaybe (Script ConwayEra)
_) =
  (Addr -> [Credential 'Payment]
addrCredentials Addr
addr, forall a. a -> Maybe a
Just DataHash
dh)
txoutEvidence Proof era
Conway (BabbageTxOut Addr
addr Value era
_ (Datum BinaryData era
_d) StrictMaybe (Script era)
_) =
  (Addr -> [Credential 'Payment]
addrCredentials Addr
addr, forall a. a -> Maybe a
Just (forall era. Data era -> DataHash
hashData @era (forall era. Era era => BinaryData era -> Data era
binaryDataToData BinaryData era
_d)))
txoutEvidence Proof era
Babbage (BabbageTxOut Addr
addr Value BabbageEra
_ Datum BabbageEra
NoDatum StrictMaybe (Script BabbageEra)
_) =
  (Addr -> [Credential 'Payment]
addrCredentials Addr
addr, forall a. Maybe a
Nothing)
txoutEvidence Proof era
Babbage (BabbageTxOut Addr
addr Value BabbageEra
_ (DatumHash DataHash
dh) StrictMaybe (Script BabbageEra)
_) =
  (Addr -> [Credential 'Payment]
addrCredentials Addr
addr, forall a. a -> Maybe a
Just DataHash
dh)
txoutEvidence Proof era
Babbage (BabbageTxOut Addr
addr Value era
_ (Datum BinaryData era
_d) StrictMaybe (Script era)
_) =
  (Addr -> [Credential 'Payment]
addrCredentials Addr
addr, forall a. a -> Maybe a
Just (forall era. Data era -> DataHash
hashData @era (forall era. Era era => BinaryData era -> Data era
binaryDataToData BinaryData era
_d)))
txoutEvidence Proof era
Mary (ShelleyTxOut Addr
addr Value MaryEra
_) =
  (Addr -> [Credential 'Payment]
addrCredentials Addr
addr, forall a. Maybe a
Nothing)
txoutEvidence Proof era
Allegra (ShelleyTxOut Addr
addr Value AllegraEra
_) =
  (Addr -> [Credential 'Payment]
addrCredentials Addr
addr, forall a. Maybe a
Nothing)
txoutEvidence Proof era
Shelley (ShelleyTxOut Addr
addr Value ShelleyEra
_) =
  (Addr -> [Credential 'Payment]
addrCredentials Addr
addr, forall a. Maybe a
Nothing)
{-# NOINLINE txoutEvidence #-}

addrCredentials :: Addr -> [Credential 'Payment]
addrCredentials :: Addr -> [Credential 'Payment]
addrCredentials Addr
addr = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a. a -> [a] -> [a]
: []) (Addr -> Maybe (Credential 'Payment)
paymentCredAddr Addr
addr)

paymentCredAddr :: Addr -> Maybe (Credential 'Payment)
paymentCredAddr :: Addr -> Maybe (Credential 'Payment)
paymentCredAddr (Addr Network
_ Credential 'Payment
cred StakeReference
_) = forall a. a -> Maybe a
Just Credential 'Payment
cred
paymentCredAddr Addr
_ = forall a. Maybe a
Nothing

stakeCredAddr :: Addr -> Maybe (Credential 'Staking)
stakeCredAddr :: Addr -> Maybe (Credential 'Staking)
stakeCredAddr (Addr Network
_ Credential 'Payment
_ (StakeRefBase Credential 'Staking
cred)) = forall a. a -> Maybe a
Just Credential 'Staking
cred
stakeCredAddr Addr
_ = forall a. Maybe a
Nothing

getBody :: EraTx era => Proof era -> Tx era -> TxBody era
getBody :: forall era. EraTx era => Proof era -> Tx era -> TxBody era
getBody Proof era
_ Tx era
tx = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL

getCollateralInputs :: Proof era -> TxBody era -> Set TxIn
getCollateralInputs :: forall era. Proof era -> TxBody era -> Set TxIn
getCollateralInputs Proof era
Conway TxBody era
txBody = TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTxBody era => Lens' (TxBody era) (Set TxIn)
collateralInputsTxBodyL
getCollateralInputs Proof era
Babbage TxBody era
txBody = TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTxBody era => Lens' (TxBody era) (Set TxIn)
collateralInputsTxBodyL
getCollateralInputs Proof era
Alonzo TxBody era
txBody = TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era. AlonzoEraTxBody era => Lens' (TxBody era) (Set TxIn)
collateralInputsTxBodyL
getCollateralInputs Proof era
Mary TxBody era
_ = forall a. Set a
Set.empty
getCollateralInputs Proof era
Allegra TxBody era
_ = forall a. Set a
Set.empty
getCollateralInputs Proof era
Shelley TxBody era
_ = forall a. Set a
Set.empty
{-# NOINLINE getCollateralInputs #-}

getCollateralOutputs :: Proof era -> TxBody era -> [TxOut era]
getCollateralOutputs :: forall era. Proof era -> TxBody era -> [TxOut era]
getCollateralOutputs Proof era
Conway TxBody era
txBody =
  case TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (TxOut era))
collateralReturnTxBodyL of
    StrictMaybe (BabbageTxOut ConwayEra)
SNothing -> []
    SJust BabbageTxOut ConwayEra
x -> [BabbageTxOut ConwayEra
x]
getCollateralOutputs Proof era
Babbage TxBody era
txBody =
  case TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (TxOut era))
collateralReturnTxBodyL of
    StrictMaybe (BabbageTxOut BabbageEra)
SNothing -> []
    SJust BabbageTxOut BabbageEra
x -> [BabbageTxOut BabbageEra
x]
getCollateralOutputs Proof era
Alonzo TxBody era
_ = []
getCollateralOutputs Proof era
Mary TxBody era
_ = []
getCollateralOutputs Proof era
Allegra TxBody era
_ = []
getCollateralOutputs Proof era
Shelley TxBody era
_ = []
{-# NOINLINE getCollateralOutputs #-}

getInputs :: EraTxBody era => Proof era -> TxBody era -> Set TxIn
getInputs :: forall era. EraTxBody era => Proof era -> TxBody era -> Set TxIn
getInputs Proof era
_ TxBody era
tx = TxBody era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => Lens' (TxBody era) (Set TxIn)
inputsTxBodyL

getOutputs :: EraTxBody era => Proof era -> TxBody era -> StrictSeq (TxOut era)
getOutputs :: forall era.
EraTxBody era =>
Proof era -> TxBody era -> StrictSeq (TxOut era)
getOutputs Proof era
_ TxBody era
tx = TxBody era
tx forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxOut era))
outputsTxBodyL

getScriptWits ::
  EraTxWits era => Proof era -> TxWits era -> Map ScriptHash (Script era)
getScriptWits :: forall era.
EraTxWits era =>
Proof era -> TxWits era -> Map ScriptHash (Script era)
getScriptWits Proof era
_ TxWits era
tx = TxWits era
tx forall s a. s -> Getting a s a -> a
^. forall era.
EraTxWits era =>
Lens' (TxWits era) (Map ScriptHash (Script era))
scriptTxWitsL

allInputs :: EraTxBody era => Proof era -> TxBody era -> Set TxIn
allInputs :: forall era. EraTxBody era => Proof era -> TxBody era -> Set TxIn
allInputs Proof era
_ TxBody era
txb = TxBody era
txb forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => SimpleGetter (TxBody era) (Set TxIn)
allInputsTxBodyF

getWitnesses :: EraTx era => Proof era -> Tx era -> TxWits era
getWitnesses :: forall era. EraTx era => Proof era -> Tx era -> TxWits era
getWitnesses Proof era
_ Tx era
tx = Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxWits era)
witsTxL

primaryLanguage :: Proof era -> Maybe Language
primaryLanguage :: forall era. Proof era -> Maybe Language
primaryLanguage Proof era
Conway = forall a. a -> Maybe a
Just Language
PlutusV2
primaryLanguage Proof era
Babbage = forall a. a -> Maybe a
Just Language
PlutusV2
primaryLanguage Proof era
Alonzo = forall a. a -> Maybe a
Just Language
PlutusV1
primaryLanguage Proof era
_ = forall a. Maybe a
Nothing
{-# NOINLINE primaryLanguage #-}

alwaysTrue :: forall era. Proof era -> Maybe Language -> Natural -> Script era
alwaysTrue :: forall era. Proof era -> Maybe Language -> Natural -> Script era
alwaysTrue Proof era
Conway (Just Language
l) Natural
n = forall era.
(HasCallStack, AlonzoEraScript era) =>
Language -> Natural -> Script era
alwaysSucceedsLang @era Language
l Natural
n
alwaysTrue p :: Proof era
p@Proof era
Conway Maybe Language
Nothing Natural
_ = forall era. EraScript era => NativeScript era -> Script era
fromNativeScript forall a b. (a -> b) -> a -> b
$ forall era.
Scriptic era =>
[Proof era -> NativeScript era] -> Proof era -> NativeScript era
Scriptic.allOf [] Proof era
p
alwaysTrue Proof era
Babbage (Just Language
l) Natural
n = forall era.
(HasCallStack, AlonzoEraScript era) =>
Language -> Natural -> Script era
alwaysSucceedsLang @era Language
l Natural
n
alwaysTrue p :: Proof era
p@Proof era
Babbage Maybe Language
Nothing Natural
_ = forall era. EraScript era => NativeScript era -> Script era
fromNativeScript forall a b. (a -> b) -> a -> b
$ forall era.
Scriptic era =>
[Proof era -> NativeScript era] -> Proof era -> NativeScript era
Scriptic.allOf [] Proof era
p
alwaysTrue Proof era
Alonzo (Just Language
l) Natural
n = forall era.
(HasCallStack, AlonzoEraScript era) =>
Language -> Natural -> Script era
alwaysSucceedsLang @era Language
l Natural
n
alwaysTrue p :: Proof era
p@Proof era
Alonzo Maybe Language
Nothing Natural
_ = forall era. EraScript era => NativeScript era -> Script era
fromNativeScript forall a b. (a -> b) -> a -> b
$ forall era.
Scriptic era =>
[Proof era -> NativeScript era] -> Proof era -> NativeScript era
Scriptic.allOf [] Proof era
p
alwaysTrue p :: Proof era
p@Proof era
Mary Maybe Language
_ Natural
n = forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
n Proof era
p
alwaysTrue p :: Proof era
p@Proof era
Allegra Maybe Language
_ Natural
n = forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
n Proof era
p
alwaysTrue p :: Proof era
p@Proof era
Shelley Maybe Language
_ Natural
n = forall era. Scriptic era => Natural -> Proof era -> Script era
always Natural
n Proof era
p
{-# NOINLINE alwaysTrue #-}

alwaysFalse :: forall era. Proof era -> Maybe Language -> Natural -> Script era
alwaysFalse :: forall era. Proof era -> Maybe Language -> Natural -> Script era
alwaysFalse Proof era
Conway (Just Language
l) Natural
n = forall era.
(HasCallStack, AlonzoEraScript era) =>
Language -> Natural -> Script era
alwaysFailsLang @era Language
l Natural
n
alwaysFalse p :: Proof era
p@Proof era
Conway Maybe Language
Nothing Natural
_ = forall era. EraScript era => NativeScript era -> Script era
fromNativeScript forall a b. (a -> b) -> a -> b
$ forall era.
Scriptic era =>
[Proof era -> NativeScript era] -> Proof era -> NativeScript era
Scriptic.anyOf [] Proof era
p
alwaysFalse Proof era
Babbage (Just Language
l) Natural
n = forall era.
(HasCallStack, AlonzoEraScript era) =>
Language -> Natural -> Script era
alwaysFailsLang @era Language
l Natural
n
alwaysFalse p :: Proof era
p@Proof era
Babbage Maybe Language
Nothing Natural
_ = forall era. EraScript era => NativeScript era -> Script era
fromNativeScript forall a b. (a -> b) -> a -> b
$ forall era.
Scriptic era =>
[Proof era -> NativeScript era] -> Proof era -> NativeScript era
Scriptic.anyOf [] Proof era
p
alwaysFalse Proof era
Alonzo (Just Language
l) Natural
n = forall era.
(HasCallStack, AlonzoEraScript era) =>
Language -> Natural -> Script era
alwaysFailsLang @era Language
l Natural
n
alwaysFalse p :: Proof era
p@Proof era
Alonzo Maybe Language
Nothing Natural
_ = forall era. EraScript era => NativeScript era -> Script era
fromNativeScript forall a b. (a -> b) -> a -> b
$ forall era.
Scriptic era =>
[Proof era -> NativeScript era] -> Proof era -> NativeScript era
Scriptic.anyOf [] Proof era
p
alwaysFalse p :: Proof era
p@Proof era
Mary Maybe Language
_ Natural
n = forall era. Scriptic era => Natural -> Proof era -> Script era
never Natural
n Proof era
p
alwaysFalse p :: Proof era
p@Proof era
Allegra Maybe Language
_ Natural
n = forall era. Scriptic era => Natural -> Proof era -> Script era
never Natural
n Proof era
p
alwaysFalse p :: Proof era
p@Proof era
Shelley Maybe Language
_ Natural
n = forall era. Scriptic era => Natural -> Proof era -> Script era
never Natural
n Proof era
p
{-# NOINLINE alwaysFalse #-}

certs :: (ShelleyEraTxBody era, EraTx era) => Proof era -> Tx era -> [TxCert era]
certs :: forall era.
(ShelleyEraTxBody era, EraTx era) =>
Proof era -> Tx era -> [TxCert era]
certs Proof era
_ Tx era
tx = forall (t :: * -> *) a. Foldable t => t a -> [a]
Fold.toList forall a b. (a -> b) -> a -> b
$ Tx era
tx forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTxBody era =>
Lens' (TxBody era) (StrictSeq (TxCert era))
certsTxBodyL

-- | Create an old style RewardUpdate to be used in tests, in any Era.
createRUpdNonPulsing' ::
  forall era.
  Proof era ->
  Model era ->
  RewardUpdateOld
createRUpdNonPulsing' :: forall era. Proof era -> Model era -> RewardUpdateOld
createRUpdNonPulsing' Proof era
proof Model era
model =
  let bm :: BlocksMade
bm = Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade forall a b. (a -> b) -> a -> b
$ forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) Natural
mBcur Model era
model -- TODO or should this be mBprev?
      ss :: SnapShots
ss = forall era. ModelNewEpochState era -> SnapShots
mSnapshots Model era
model
      as :: ChainAccountState
as = forall era. ModelNewEpochState era -> ChainAccountState
mChainAccountState Model era
model
      reserves :: Coin
reserves = ChainAccountState -> Coin
casReserves ChainAccountState
as
      pp :: PParams era
pp = forall era. ModelNewEpochState era -> PParams era
mPParams Model era
model
      totalStake :: Coin
totalStake = forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr forall t. Val t => t -> t -> t
(<+>) (Integer -> Coin
Coin Integer
0) forall a b. (a -> b) -> a -> b
$ forall era.
ModelNewEpochState era -> Map (Credential 'Staking) Coin
mRewards Model era
model
      rs :: Set (Credential 'Staking)
rs = forall k a. Map k a -> Set k
Map.keysSet forall a b. (a -> b) -> a -> b
$ forall era.
ModelNewEpochState era -> Map (Credential 'Staking) Coin
mRewards Model era
model -- TODO or should we look at delegated keys instead?
      en :: EpochNo
en = forall era. ModelNewEpochState era -> EpochNo
mEL Model era
model

      -- We use testGlobals here, since this generic function is used only in tests.
      slotsPerEpoch :: EpochSize
slotsPerEpoch = case forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> EpochNo -> m EpochSize
epochInfoSize (Globals -> EpochInfo (Either Text)
epochInfo Globals
testGlobals) EpochNo
en of
        Left Text
err -> forall a. HasCallStack => [Char] -> a
error ([Char]
"Failed to calculate slots per epoch:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
err)
        Right EpochSize
x -> EpochSize
x
   in (forall r a. Reader r a -> r -> a
`runReader` Globals
testGlobals) forall a b. (a -> b) -> a -> b
$ case Proof era
proof of
        Proof era
Conway -> forall era.
EraPParams era =>
EpochSize
-> BlocksMade
-> SnapShots
-> Coin
-> PParams era
-> Coin
-> Set (Credential 'Staking)
-> NonMyopic
-> Reader Globals RewardUpdateOld
createRUpdOld_ @era EpochSize
slotsPerEpoch BlocksMade
bm SnapShots
ss Coin
reserves PParams era
pp Coin
totalStake Set (Credential 'Staking)
rs forall a. Default a => a
def
        Proof era
Babbage -> forall era.
EraPParams era =>
EpochSize
-> BlocksMade
-> SnapShots
-> Coin
-> PParams era
-> Coin
-> Set (Credential 'Staking)
-> NonMyopic
-> Reader Globals RewardUpdateOld
createRUpdOld_ @era EpochSize
slotsPerEpoch BlocksMade
bm SnapShots
ss Coin
reserves PParams era
pp Coin
totalStake Set (Credential 'Staking)
rs forall a. Default a => a
def
        Proof era
Alonzo -> forall era.
EraPParams era =>
EpochSize
-> BlocksMade
-> SnapShots
-> Coin
-> PParams era
-> Coin
-> Set (Credential 'Staking)
-> NonMyopic
-> Reader Globals RewardUpdateOld
createRUpdOld_ @era EpochSize
slotsPerEpoch BlocksMade
bm SnapShots
ss Coin
reserves PParams era
pp Coin
totalStake Set (Credential 'Staking)
rs forall a. Default a => a
def
        Proof era
Mary -> forall era.
EraPParams era =>
EpochSize
-> BlocksMade
-> SnapShots
-> Coin
-> PParams era
-> Coin
-> Set (Credential 'Staking)
-> NonMyopic
-> Reader Globals RewardUpdateOld
createRUpdOld_ @era EpochSize
slotsPerEpoch BlocksMade
bm SnapShots
ss Coin
reserves PParams era
pp Coin
totalStake Set (Credential 'Staking)
rs forall a. Default a => a
def
        Proof era
Allegra -> forall era.
EraPParams era =>
EpochSize
-> BlocksMade
-> SnapShots
-> Coin
-> PParams era
-> Coin
-> Set (Credential 'Staking)
-> NonMyopic
-> Reader Globals RewardUpdateOld
createRUpdOld_ @era EpochSize
slotsPerEpoch BlocksMade
bm SnapShots
ss Coin
reserves PParams era
pp Coin
totalStake Set (Credential 'Staking)
rs forall a. Default a => a
def
        Proof era
Shelley -> forall era.
EraPParams era =>
EpochSize
-> BlocksMade
-> SnapShots
-> Coin
-> PParams era
-> Coin
-> Set (Credential 'Staking)
-> NonMyopic
-> Reader Globals RewardUpdateOld
createRUpdOld_ @era EpochSize
slotsPerEpoch BlocksMade
bm SnapShots
ss Coin
reserves PParams era
pp Coin
totalStake Set (Credential 'Staking)
rs forall a. Default a => a
def
{-# NOINLINE createRUpdNonPulsing' #-}

languagesUsed ::
  forall era.
  Proof era ->
  Tx era ->
  UTxO era ->
  Set ScriptHash ->
  Set Language
languagesUsed :: forall era.
Proof era -> Tx era -> UTxO era -> Set ScriptHash -> Set Language
languagesUsed Proof era
proof Tx era
tx UTxO era
utxo Set ScriptHash
sNeeded = case Proof era
proof of
  Proof era
Shelley -> forall a. Set a
Set.empty
  Proof era
Allegra -> forall a. Set a
Set.empty
  Proof era
Mary -> forall a. Set a
Set.empty
  Proof era
Alonzo -> forall era.
(EraUTxO era, AlonzoEraScript era) =>
Tx era -> UTxO era -> Set ScriptHash -> Set Language
languages Tx era
tx UTxO era
utxo Set ScriptHash
sNeeded
  Proof era
Babbage -> forall era.
(EraUTxO era, AlonzoEraScript era) =>
Tx era -> UTxO era -> Set ScriptHash -> Set Language
languages Tx era
tx UTxO era
utxo Set ScriptHash
sNeeded
  Proof era
Conway -> forall era.
(EraUTxO era, AlonzoEraScript era) =>
Tx era -> UTxO era -> Set ScriptHash -> Set Language
languages Tx era
tx UTxO era
utxo Set ScriptHash
sNeeded
{-# NOINLINE languagesUsed #-}

-- | Compute the Set of Languages in an era, where 'AlonzoScripts' are used
languages ::
  forall era.
  (EraUTxO era, AlonzoEraScript era) =>
  Tx era ->
  UTxO era ->
  Set ScriptHash ->
  Set Language
languages :: forall era.
(EraUTxO era, AlonzoEraScript era) =>
Tx era -> UTxO era -> Set ScriptHash -> Set Language
languages Tx era
tx UTxO era
utxo Set ScriptHash
sNeeded = forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' forall {era}.
AlonzoEraScript era =>
Set Language -> Script era -> Set Language
accum forall a. Set a
Set.empty Map ScriptHash (Script era)
allScripts
  where
    allScripts :: Map ScriptHash (Script era)
allScripts = forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (forall era. ScriptsProvided era -> Map ScriptHash (Script era)
unScriptsProvided forall a b. (a -> b) -> a -> b
$ forall era.
EraUTxO era =>
UTxO era -> Tx era -> ScriptsProvided era
getScriptsProvided UTxO era
utxo Tx era
tx) Set ScriptHash
sNeeded
    accum :: Set Language -> Script era -> Set Language
accum Set Language
ans Script era
script =
      case forall era.
AlonzoEraScript era =>
Script era -> Maybe (PlutusScript era)
toPlutusScript Script era
script of
        Maybe (PlutusScript era)
Nothing -> Set Language
ans
        Just PlutusScript era
plutusScript -> forall a. Ord a => a -> Set a -> Set a
Set.insert (forall era. AlonzoEraScript era => PlutusScript era -> Language
plutusScriptLanguage PlutusScript era
plutusScript) Set Language
ans

-- | Compute the total Ada from Ada pots within 't'
class TotalAda t where
  totalAda :: t -> Coin

instance TotalAda ChainAccountState where
  totalAda :: ChainAccountState -> Coin
totalAda (ChainAccountState Coin
treasury Coin
reserves) = Coin
treasury forall t. Val t => t -> t -> t
<+> Coin
reserves

instance Reflect era => TotalAda (UTxOState era) where
  totalAda :: UTxOState era -> Coin
totalAda (UTxOState UTxO era
utxo Coin
_deposits Coin
fees GovState era
gs InstantStake era
_ Coin
donations) =
    forall t. TotalAda t => t -> Coin
totalAda UTxO era
utxo forall t. Val t => t -> t -> t
<+> Coin
fees forall t. Val t => t -> t -> t
<+> forall era. Reflect era => GovState era -> Coin
govStateTotalAda GovState era
gs forall t. Val t => t -> t -> t
<+> Coin
donations

-- we don't add in the _deposits, because it is invariant that this
-- is equal to the sum of the key deposit map and the pool deposit map
-- So these are accounted for in the instance (TotalAda (CertState era))
-- TODO I'm not sure this is true ^
-- Imp conformance tests show in logs that totalAda is off by the deposit amount

instance Reflect era => TotalAda (UTxO era) where
  totalAda :: UTxO era -> Coin
totalAda (UTxO Map TxIn (TxOut era)
m) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {era}. EraTxOut era => Coin -> TxOut era -> Coin
accum forall a. Monoid a => a
mempty Map TxIn (TxOut era)
m
    where
      accum :: Coin -> TxOut era -> Coin
accum Coin
ans TxOut era
txOut = (TxOut era
txOut forall s a. s -> Getting a s a -> a
^. forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
coinTxOutL) forall t. Val t => t -> t -> t
<+> Coin
ans

instance TotalAda (DState era) where
  totalAda :: DState era -> Coin
totalAda DState era
dstate =
    (forall a. Compactible a => CompactForm a -> a
UM.fromCompact forall a b. (a -> b) -> a -> b
$ forall k. UView k RDPair -> CompactForm Coin
UM.sumRewardsUView (UMap -> UView (Credential 'Staking) RDPair
UM.RewDepUView (forall era. DState era -> UMap
dsUnified DState era
dstate)))
      forall a. Semigroup a => a -> a -> a
<> (forall a. Compactible a => CompactForm a -> a
UM.fromCompact forall a b. (a -> b) -> a -> b
$ forall k. UView k RDPair -> CompactForm Coin
UM.sumDepositUView (UMap -> UView (Credential 'Staking) RDPair
UM.RewDepUView (forall era. DState era -> UMap
dsUnified DState era
dstate)))

instance TotalAda (PState era) where
  totalAda :: PState era -> Coin
totalAda PState era
pstate = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
Fold.fold (forall era. PState era -> Map (KeyHash 'StakePool) Coin
psDeposits PState era
pstate)

instance TotalAda (VState era) where
  totalAda :: VState era -> Coin
totalAda VState era
_ = forall a. Monoid a => a
mempty

instance TotalAda (ShelleyCertState era) where
  totalAda :: ShelleyCertState era -> Coin
totalAda (ShelleyCertState PState era
ps DState era
ds) = forall t. TotalAda t => t -> Coin
totalAda DState era
ds forall a. Semigroup a => a -> a -> a
<> forall t. TotalAda t => t -> Coin
totalAda PState era
ps

instance TotalAda (ShelleyGovState era) where
  totalAda :: ShelleyGovState era -> Coin
totalAda ShelleyGovState era
_ = forall a. Monoid a => a
mempty

govStateTotalAda :: forall era. Reflect era => GovState era -> Coin
govStateTotalAda :: forall era. Reflect era => GovState era -> Coin
govStateTotalAda = case forall era. Reflect era => Proof era
reify @era of
  Proof era
Shelley -> forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Mary -> forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Allegra -> forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Alonzo -> forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Babbage -> forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Conway -> forall a. Monoid a => a
mempty

certStateTotalAda :: forall era. Reflect era => CertState era -> Coin
certStateTotalAda :: forall era. Reflect era => CertState era -> Coin
certStateTotalAda = case forall era. Reflect era => Proof era
reify @era of
  Proof era
Shelley -> forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Mary -> forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Allegra -> forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Alonzo -> forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Babbage -> forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Conway -> forall a. Monoid a => a
mempty

instance Reflect era => TotalAda (LedgerState era) where
  totalAda :: LedgerState era -> Coin
totalAda (LedgerState UTxOState era
utxos CertState era
dps) = forall t. TotalAda t => t -> Coin
totalAda UTxOState era
utxos forall t. Val t => t -> t -> t
<+> forall era. Reflect era => CertState era -> Coin
certStateTotalAda CertState era
dps

instance Reflect era => TotalAda (EpochState era) where
  totalAda :: EpochState era -> Coin
totalAda EpochState era
eps = forall t. TotalAda t => t -> Coin
totalAda (forall era. EpochState era -> LedgerState era
esLState EpochState era
eps) forall t. Val t => t -> t -> t
<+> forall t. TotalAda t => t -> Coin
totalAda (forall era. EpochState era -> ChainAccountState
esChainAccountState EpochState era
eps)

instance Reflect era => TotalAda (NewEpochState era) where
  totalAda :: NewEpochState era -> Coin
totalAda NewEpochState era
nes = forall t. TotalAda t => t -> Coin
totalAda (forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes)

adaPots :: Proof era -> EpochState era -> AdaPots
adaPots :: forall era. Proof era -> EpochState era -> AdaPots
adaPots Proof era
Conway EpochState era
es = forall era.
(EraTxOut era, EraGov era, EraCertState era) =>
EpochState era -> AdaPots
totalAdaPotsES EpochState era
es
adaPots Proof era
Babbage EpochState era
es = forall era.
(EraTxOut era, EraGov era, EraCertState era) =>
EpochState era -> AdaPots
totalAdaPotsES EpochState era
es
adaPots Proof era
Alonzo EpochState era
es = forall era.
(EraTxOut era, EraGov era, EraCertState era) =>
EpochState era -> AdaPots
totalAdaPotsES EpochState era
es
adaPots Proof era
Mary EpochState era
es = forall era.
(EraTxOut era, EraGov era, EraCertState era) =>
EpochState era -> AdaPots
totalAdaPotsES EpochState era
es
adaPots Proof era
Allegra EpochState era
es = forall era.
(EraTxOut era, EraGov era, EraCertState era) =>
EpochState era -> AdaPots
totalAdaPotsES EpochState era
es
adaPots Proof era
Shelley EpochState era
es = forall era.
(EraTxOut era, EraGov era, EraCertState era) =>
EpochState era -> AdaPots
totalAdaPotsES EpochState era
es
{-# NOINLINE adaPots #-}