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

-- | 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 (..), collateral')
import Cardano.Ledger.Babbage.TxBody (
  BabbageTxOut (..),
  collateralInputs',
  collateralReturn',
  referenceInputs',
  spendInputs',
 )
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.Credential (Credential, StakeReference (..))
import Cardano.Ledger.Keys (KeyRole (..))
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 (
  AccountState (..),
  CertState (..),
  DState (..),
  EpochState (..),
  LedgerState (..),
  NewEpochState (..),
  PState (..),
  UTxOState (..),
  VState (..),
 )
import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..))
import Cardano.Ledger.TxIn (TxIn (..))
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.UTxO (EraUTxO (..), UTxO (..), coinBalance, unScriptsProvided)
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 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 (EraCrypto era)) Coin ->
  Coin
depositsAndRefunds :: forall era.
(EraPParams era, ShelleyEraTxCert era) =>
PParams era
-> [TxCert era]
-> Map (Credential 'Staking (EraCrypto era)) Coin
-> Coin
depositsAndRefunds PParams era
pp [TxCert era]
certificates Map (StakeCredential (EraCrypto era)) 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 StakeCredential (EraCrypto era)
_) = 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 StakeCredential (EraCrypto era)
hk) =
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup StakeCredential (EraCrypto era)
hk Map (StakeCredential (EraCrypto era)) 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 (EraCrypto era)
_) = 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 (EraCrypto era)
_ 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 (EraCrypto era))
scriptWitsNeeded' :: forall era.
Proof era
-> MUtxo era -> TxBody era -> Set (ScriptHash (EraCrypto era))
scriptWitsNeeded' Proof era
Conway MUtxo era
utxo TxBody era
txBody = Set (ScriptHash (EraCrypto (ConwayEra StandardCrypto)))
regularScripts forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set (ScriptHash StandardCrypto)
inlineScripts
  where
    theUtxo :: UTxO (ConwayEra StandardCrypto)
theUtxo = forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO MUtxo era
utxo
    inputs :: Set (TxIn (EraCrypto (ConwayEra StandardCrypto)))
inputs = TxBody era
txBody forall s a. s -> Getting a s a -> a
^. forall era.
EraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
inputsTxBodyL
    inlineScripts :: Set (ScriptHash StandardCrypto)
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 (EraCrypto era))
-> Map (ScriptHash (EraCrypto era)) (Script era)
getReferenceScripts UTxO (ConwayEra StandardCrypto)
theUtxo Set (TxIn (EraCrypto (ConwayEra StandardCrypto)))
inputs
    regularScripts :: Set (ScriptHash (EraCrypto (ConwayEra StandardCrypto)))
regularScripts = forall era.
EraUTxO era =>
ScriptsNeeded era -> Set (ScriptHash (EraCrypto era))
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO (ConwayEra StandardCrypto)
theUtxo TxBody era
txBody)
scriptWitsNeeded' Proof era
Babbage MUtxo era
utxo TxBody era
txBody = Set (ScriptHash (EraCrypto (BabbageEra StandardCrypto)))
regularScripts forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set (ScriptHash StandardCrypto)
inlineScripts
  where
    theUtxo :: UTxO (BabbageEra StandardCrypto)
theUtxo = forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO MUtxo era
utxo
    inputs :: Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
inputs = forall era. BabbageTxBody era -> Set (TxIn (EraCrypto era))
spendInputs' TxBody era
txBody forall a. Ord a => Set a -> Set a -> Set a
`Set.union` forall era. BabbageTxBody era -> Set (TxIn (EraCrypto era))
referenceInputs' TxBody era
txBody
    inlineScripts :: Set (ScriptHash StandardCrypto)
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 (EraCrypto era))
-> Map (ScriptHash (EraCrypto era)) (Script era)
getReferenceScripts UTxO (BabbageEra StandardCrypto)
theUtxo Set (TxIn (EraCrypto (BabbageEra StandardCrypto)))
inputs
    regularScripts :: Set (ScriptHash (EraCrypto (BabbageEra StandardCrypto)))
regularScripts = forall era.
EraUTxO era =>
ScriptsNeeded era -> Set (ScriptHash (EraCrypto era))
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded UTxO (BabbageEra StandardCrypto)
theUtxo TxBody era
txBody)
scriptWitsNeeded' Proof era
Alonzo MUtxo era
utxo TxBody era
txBody =
  forall era.
EraUTxO era =>
ScriptsNeeded era -> Set (ScriptHash (EraCrypto era))
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map (TxIn (EraCrypto era)) (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 (EraCrypto era))
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map (TxIn (EraCrypto era)) (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 (EraCrypto era))
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map (TxIn (EraCrypto era)) (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 (EraCrypto era))
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody era
txBody)
{-# NOINLINE scriptWitsNeeded' #-}

scriptsNeeded' :: Proof era -> MUtxo era -> TxBody era -> Set (ScriptHash (EraCrypto era))
scriptsNeeded' :: forall era.
Proof era
-> MUtxo era -> TxBody era -> Set (ScriptHash (EraCrypto era))
scriptsNeeded' Proof era
Conway MUtxo era
utxo TxBody era
txBody =
  forall era.
EraUTxO era =>
ScriptsNeeded era -> Set (ScriptHash (EraCrypto era))
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map (TxIn (EraCrypto era)) (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 (EraCrypto era))
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map (TxIn (EraCrypto era)) (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 (EraCrypto era))
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map (TxIn (EraCrypto era)) (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 (EraCrypto era))
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map (TxIn (EraCrypto era)) (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 (EraCrypto era))
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map (TxIn (EraCrypto era)) (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 (EraCrypto era))
getScriptsHashesNeeded (forall era.
EraUTxO era =>
UTxO era -> TxBody era -> ScriptsNeeded era
getScriptsNeeded (forall era. Map (TxIn (EraCrypto era)) (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody era
txBody)
{-# NOINLINE scriptsNeeded' #-}

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

-- | Break a TxOut into its mandatory and optional parts
txoutFields :: Proof era -> TxOut era -> (Addr (EraCrypto era), Value era, [TxOutField era])
txoutFields :: forall era.
Proof era
-> TxOut era -> (Addr (EraCrypto era), Value era, [TxOutField era])
txoutFields Proof era
Conway (BabbageTxOut Addr (EraCrypto era)
addr Value era
val Datum era
d StrictMaybe (Script era)
h) = (Addr (EraCrypto era)
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 (EraCrypto era)
addr Value era
val Datum era
d StrictMaybe (Script era)
h) = (Addr (EraCrypto era)
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 (EraCrypto (AlonzoEra StandardCrypto))
addr Value (AlonzoEra StandardCrypto)
val StrictMaybe (DataHash (EraCrypto (AlonzoEra StandardCrypto)))
dh) = (Addr (EraCrypto (AlonzoEra StandardCrypto))
addr, Value (AlonzoEra StandardCrypto)
val, [forall era.
StrictMaybe (DataHash (EraCrypto era)) -> TxOutField era
DHash StrictMaybe (DataHash (EraCrypto (AlonzoEra StandardCrypto)))
dh])
txoutFields Proof era
Mary (ShelleyTxOut Addr (EraCrypto (MaryEra StandardCrypto))
addr Value (MaryEra StandardCrypto)
val) = (Addr (EraCrypto (MaryEra StandardCrypto))
addr, Value (MaryEra StandardCrypto)
val, [])
txoutFields Proof era
Allegra (ShelleyTxOut Addr (EraCrypto (AllegraEra StandardCrypto))
addr Value (AllegraEra StandardCrypto)
val) = (Addr (EraCrypto (AllegraEra StandardCrypto))
addr, Value (AllegraEra StandardCrypto)
val, [])
txoutFields Proof era
Shelley (ShelleyTxOut Addr (EraCrypto (ShelleyEra StandardCrypto))
addr Value (ShelleyEra StandardCrypto)
val) = (Addr (EraCrypto (ShelleyEra StandardCrypto))
addr, Value (ShelleyEra StandardCrypto)
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 (EraCrypto (ConwayEra StandardCrypto))
_ Value (ConwayEra StandardCrypto)
_ Datum (ConwayEra StandardCrypto)
_ StrictMaybe (Script (ConwayEra StandardCrypto))
ms) = StrictMaybe (Script (ConwayEra StandardCrypto))
ms
getTxOutRefScript Proof era
Babbage (BabbageTxOut Addr (EraCrypto (BabbageEra StandardCrypto))
_ Value (BabbageEra StandardCrypto)
_ Datum (BabbageEra StandardCrypto)
_ StrictMaybe (Script (BabbageEra StandardCrypto))
ms) = StrictMaybe (Script (BabbageEra StandardCrypto))
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 (EraCrypto era)], Maybe (DataHash (EraCrypto era)))
txoutEvidence :: forall era.
Proof era
-> TxOut era
-> ([Credential 'Payment (EraCrypto era)],
    Maybe (DataHash (EraCrypto era)))
txoutEvidence Proof era
Alonzo (AlonzoTxOut Addr (EraCrypto (AlonzoEra StandardCrypto))
addr Value (AlonzoEra StandardCrypto)
_ (SJust DataHash (EraCrypto (AlonzoEra StandardCrypto))
dh)) =
  (forall c. Addr c -> [Credential 'Payment c]
addrCredentials Addr (EraCrypto (AlonzoEra StandardCrypto))
addr, forall a. a -> Maybe a
Just DataHash (EraCrypto (AlonzoEra StandardCrypto))
dh)
txoutEvidence Proof era
Alonzo (AlonzoTxOut Addr (EraCrypto (AlonzoEra StandardCrypto))
addr Value (AlonzoEra StandardCrypto)
_ StrictMaybe (DataHash (EraCrypto (AlonzoEra StandardCrypto)))
SNothing) =
  (forall c. Addr c -> [Credential 'Payment c]
addrCredentials Addr (EraCrypto (AlonzoEra StandardCrypto))
addr, forall a. Maybe a
Nothing)
txoutEvidence Proof era
Conway (BabbageTxOut Addr (EraCrypto (ConwayEra StandardCrypto))
addr Value (ConwayEra StandardCrypto)
_ Datum (ConwayEra StandardCrypto)
NoDatum StrictMaybe (Script (ConwayEra StandardCrypto))
_) =
  (forall c. Addr c -> [Credential 'Payment c]
addrCredentials Addr (EraCrypto (ConwayEra StandardCrypto))
addr, forall a. Maybe a
Nothing)
txoutEvidence Proof era
Conway (BabbageTxOut Addr (EraCrypto (ConwayEra StandardCrypto))
addr Value (ConwayEra StandardCrypto)
_ (DatumHash DataHash (EraCrypto (ConwayEra StandardCrypto))
dh) StrictMaybe (Script (ConwayEra StandardCrypto))
_) =
  (forall c. Addr c -> [Credential 'Payment c]
addrCredentials Addr (EraCrypto (ConwayEra StandardCrypto))
addr, forall a. a -> Maybe a
Just DataHash (EraCrypto (ConwayEra StandardCrypto))
dh)
txoutEvidence Proof era
Conway (BabbageTxOut Addr (EraCrypto era)
addr Value era
_ (Datum BinaryData era
_d) StrictMaybe (Script era)
_) =
  (forall c. Addr c -> [Credential 'Payment c]
addrCredentials Addr (EraCrypto era)
addr, forall a. a -> Maybe a
Just (forall era. Era era => Data era -> DataHash (EraCrypto era)
hashData @era (forall era. Era era => BinaryData era -> Data era
binaryDataToData BinaryData era
_d)))
txoutEvidence Proof era
Babbage (BabbageTxOut Addr (EraCrypto (BabbageEra StandardCrypto))
addr Value (BabbageEra StandardCrypto)
_ Datum (BabbageEra StandardCrypto)
NoDatum StrictMaybe (Script (BabbageEra StandardCrypto))
_) =
  (forall c. Addr c -> [Credential 'Payment c]
addrCredentials Addr (EraCrypto (BabbageEra StandardCrypto))
addr, forall a. Maybe a
Nothing)
txoutEvidence Proof era
Babbage (BabbageTxOut Addr (EraCrypto (BabbageEra StandardCrypto))
addr Value (BabbageEra StandardCrypto)
_ (DatumHash DataHash (EraCrypto (BabbageEra StandardCrypto))
dh) StrictMaybe (Script (BabbageEra StandardCrypto))
_) =
  (forall c. Addr c -> [Credential 'Payment c]
addrCredentials Addr (EraCrypto (BabbageEra StandardCrypto))
addr, forall a. a -> Maybe a
Just DataHash (EraCrypto (BabbageEra StandardCrypto))
dh)
txoutEvidence Proof era
Babbage (BabbageTxOut Addr (EraCrypto era)
addr Value era
_ (Datum BinaryData era
_d) StrictMaybe (Script era)
_) =
  (forall c. Addr c -> [Credential 'Payment c]
addrCredentials Addr (EraCrypto era)
addr, forall a. a -> Maybe a
Just (forall era. Era era => Data era -> DataHash (EraCrypto era)
hashData @era (forall era. Era era => BinaryData era -> Data era
binaryDataToData BinaryData era
_d)))
txoutEvidence Proof era
Mary (ShelleyTxOut Addr (EraCrypto (MaryEra StandardCrypto))
addr Value (MaryEra StandardCrypto)
_) =
  (forall c. Addr c -> [Credential 'Payment c]
addrCredentials Addr (EraCrypto (MaryEra StandardCrypto))
addr, forall a. Maybe a
Nothing)
txoutEvidence Proof era
Allegra (ShelleyTxOut Addr (EraCrypto (AllegraEra StandardCrypto))
addr Value (AllegraEra StandardCrypto)
_) =
  (forall c. Addr c -> [Credential 'Payment c]
addrCredentials Addr (EraCrypto (AllegraEra StandardCrypto))
addr, forall a. Maybe a
Nothing)
txoutEvidence Proof era
Shelley (ShelleyTxOut Addr (EraCrypto (ShelleyEra StandardCrypto))
addr Value (ShelleyEra StandardCrypto)
_) =
  (forall c. Addr c -> [Credential 'Payment c]
addrCredentials Addr (EraCrypto (ShelleyEra StandardCrypto))
addr, forall a. Maybe a
Nothing)
{-# NOINLINE txoutEvidence #-}

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

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

stakeCredAddr :: Addr c -> Maybe (Credential 'Staking c)
stakeCredAddr :: forall c. Addr c -> Maybe (Credential 'Staking c)
stakeCredAddr (Addr Network
_ PaymentCredential c
_ (StakeRefBase StakeCredential c
cred)) = forall a. a -> Maybe a
Just StakeCredential c
cred
stakeCredAddr Addr c
_ = 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 (EraCrypto era))
getCollateralInputs :: forall era. Proof era -> TxBody era -> Set (TxIn (EraCrypto era))
getCollateralInputs Proof era
Conway TxBody era
tx = TxBody era
tx forall s a. s -> Getting a s a -> a
^. forall era.
AlonzoEraTxBody era =>
Lens' (TxBody era) (Set (TxIn (EraCrypto era)))
collateralInputsTxBodyL
getCollateralInputs Proof era
Babbage TxBody era
tx = forall era. BabbageTxBody era -> Set (TxIn (EraCrypto era))
collateralInputs' TxBody era
tx
getCollateralInputs Proof era
Alonzo TxBody era
tx = forall era. AlonzoTxBody era -> Set (TxIn (EraCrypto era))
collateral' TxBody era
tx
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
tx = case TxBody era
tx forall s a. s -> Getting a s a -> a
^. forall era.
BabbageEraTxBody era =>
Lens' (TxBody era) (StrictMaybe (TxOut era))
collateralReturnTxBodyL of StrictMaybe (TxOut (ConwayEra StandardCrypto))
SNothing -> []; SJust TxOut (ConwayEra StandardCrypto)
x -> [TxOut (ConwayEra StandardCrypto)
x]
getCollateralOutputs Proof era
Babbage TxBody era
tx = case forall era. BabbageTxBody era -> StrictMaybe (TxOut era)
collateralReturn' TxBody era
tx of StrictMaybe (TxOut (BabbageEra StandardCrypto))
SNothing -> []; SJust TxOut (BabbageEra StandardCrypto)
x -> [TxOut (BabbageEra StandardCrypto)
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 (EraCrypto era))
getInputs :: forall era.
EraTxBody era =>
Proof era -> TxBody era -> Set (TxIn (EraCrypto era))
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 (EraCrypto era)))
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 (EraCrypto era)) (Script era)
getScriptWits :: forall era.
EraTxWits era =>
Proof era
-> TxWits era -> Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era)) (Script era))
scriptTxWitsL

allInputs :: EraTxBody era => Proof era -> TxBody era -> Set (TxIn (EraCrypto era))
allInputs :: forall era.
EraTxBody era =>
Proof era -> TxBody era -> Set (TxIn (EraCrypto era))
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 (EraCrypto era)))
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
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
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
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
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
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
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 (EraCrypto era)
createRUpdNonPulsing' :: forall era.
Proof era -> Model era -> RewardUpdateOld (EraCrypto era)
createRUpdNonPulsing' Proof era
proof Model era
model =
  let bm :: BlocksMade (EraCrypto era)
bm = forall c. Map (KeyHash 'StakePool c) Natural -> BlocksMade c
BlocksMade forall a b. (a -> b) -> a -> b
$ forall era.
ModelNewEpochState era
-> Map (KeyHash 'StakePool (EraCrypto era)) Natural
mBcur Model era
model -- TODO or should this be mBprev?
      ss :: SnapShots (EraCrypto era)
ss = forall era. ModelNewEpochState era -> SnapShots (EraCrypto era)
mSnapshots Model era
model
      as :: AccountState
as = forall era. ModelNewEpochState era -> AccountState
mAccountState Model era
model
      reserves :: Coin
reserves = AccountState -> Coin
asReserves AccountState
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 (EraCrypto era)) Coin
mRewards Model era
model
      rs :: Set (Credential 'Staking (EraCrypto era))
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 (EraCrypto era)) 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 (EraCrypto era)
-> SnapShots (EraCrypto era)
-> Coin
-> PParams era
-> Coin
-> Set (Credential 'Staking (EraCrypto era))
-> NonMyopic (EraCrypto era)
-> ShelleyBase (RewardUpdateOld (EraCrypto era))
createRUpdOld_ @era EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
bm SnapShots (EraCrypto era)
ss Coin
reserves PParams era
pp Coin
totalStake Set (Credential 'Staking (EraCrypto era))
rs forall a. Default a => a
def
        Proof era
Babbage -> forall era.
EraPParams era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> SnapShots (EraCrypto era)
-> Coin
-> PParams era
-> Coin
-> Set (Credential 'Staking (EraCrypto era))
-> NonMyopic (EraCrypto era)
-> ShelleyBase (RewardUpdateOld (EraCrypto era))
createRUpdOld_ @era EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
bm SnapShots (EraCrypto era)
ss Coin
reserves PParams era
pp Coin
totalStake Set (Credential 'Staking (EraCrypto era))
rs forall a. Default a => a
def
        Proof era
Alonzo -> forall era.
EraPParams era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> SnapShots (EraCrypto era)
-> Coin
-> PParams era
-> Coin
-> Set (Credential 'Staking (EraCrypto era))
-> NonMyopic (EraCrypto era)
-> ShelleyBase (RewardUpdateOld (EraCrypto era))
createRUpdOld_ @era EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
bm SnapShots (EraCrypto era)
ss Coin
reserves PParams era
pp Coin
totalStake Set (Credential 'Staking (EraCrypto era))
rs forall a. Default a => a
def
        Proof era
Mary -> forall era.
EraPParams era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> SnapShots (EraCrypto era)
-> Coin
-> PParams era
-> Coin
-> Set (Credential 'Staking (EraCrypto era))
-> NonMyopic (EraCrypto era)
-> ShelleyBase (RewardUpdateOld (EraCrypto era))
createRUpdOld_ @era EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
bm SnapShots (EraCrypto era)
ss Coin
reserves PParams era
pp Coin
totalStake Set (Credential 'Staking (EraCrypto era))
rs forall a. Default a => a
def
        Proof era
Allegra -> forall era.
EraPParams era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> SnapShots (EraCrypto era)
-> Coin
-> PParams era
-> Coin
-> Set (Credential 'Staking (EraCrypto era))
-> NonMyopic (EraCrypto era)
-> ShelleyBase (RewardUpdateOld (EraCrypto era))
createRUpdOld_ @era EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
bm SnapShots (EraCrypto era)
ss Coin
reserves PParams era
pp Coin
totalStake Set (Credential 'Staking (EraCrypto era))
rs forall a. Default a => a
def
        Proof era
Shelley -> forall era.
EraPParams era =>
EpochSize
-> BlocksMade (EraCrypto era)
-> SnapShots (EraCrypto era)
-> Coin
-> PParams era
-> Coin
-> Set (Credential 'Staking (EraCrypto era))
-> NonMyopic (EraCrypto era)
-> ShelleyBase (RewardUpdateOld (EraCrypto era))
createRUpdOld_ @era EpochSize
slotsPerEpoch BlocksMade (EraCrypto era)
bm SnapShots (EraCrypto era)
ss Coin
reserves PParams era
pp Coin
totalStake Set (Credential 'Staking (EraCrypto era))
rs forall a. Default a => a
def
{-# NOINLINE createRUpdNonPulsing' #-}

languagesUsed ::
  forall era.
  Proof era ->
  Tx era ->
  UTxO era ->
  Set (ScriptHash (EraCrypto era)) ->
  Set Language
languagesUsed :: forall era.
Proof era
-> Tx era
-> UTxO era
-> Set (ScriptHash (EraCrypto era))
-> Set Language
languagesUsed Proof era
proof Tx era
tx UTxO era
utxo Set (ScriptHash (EraCrypto era))
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 (EraCrypto era)) -> Set Language
languages Tx era
tx UTxO era
utxo Set (ScriptHash (EraCrypto era))
sNeeded
  Proof era
Babbage -> forall era.
(EraUTxO era, AlonzoEraScript era) =>
Tx era
-> UTxO era -> Set (ScriptHash (EraCrypto era)) -> Set Language
languages Tx era
tx UTxO era
utxo Set (ScriptHash (EraCrypto era))
sNeeded
  Proof era
Conway -> forall era.
(EraUTxO era, AlonzoEraScript era) =>
Tx era
-> UTxO era -> Set (ScriptHash (EraCrypto era)) -> Set Language
languages Tx era
tx UTxO era
utxo Set (ScriptHash (EraCrypto era))
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 (EraCrypto era)) ->
  Set Language
languages :: forall era.
(EraUTxO era, AlonzoEraScript era) =>
Tx era
-> UTxO era -> Set (ScriptHash (EraCrypto era)) -> Set Language
languages Tx era
tx UTxO era
utxo Set (ScriptHash (EraCrypto era))
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 (EraCrypto era)) (Script era)
allScripts
  where
    allScripts :: Map (ScriptHash (EraCrypto era)) (Script era)
allScripts = forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (forall era.
ScriptsProvided era
-> Map (ScriptHash (EraCrypto era)) (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 (EraCrypto era))
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 AccountState where
  totalAda :: AccountState -> Coin
totalAda (AccountState 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 IncrementalStake (EraCrypto 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))

instance Reflect era => TotalAda (UTxO era) where
  totalAda :: UTxO era -> Coin
totalAda (UTxO Map (TxIn (EraCrypto era)) (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 (EraCrypto era)) (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 c k. UView c k RDPair -> CompactForm Coin
UM.sumRewardsUView (forall c. UMap c -> UView c (Credential 'Staking c) RDPair
UM.RewDepUView (forall era. DState era -> UMap (EraCrypto era)
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 c k. UView c k RDPair -> CompactForm Coin
UM.sumDepositUView (forall c. UMap c -> UView c (Credential 'Staking c) RDPair
UM.RewDepUView (forall era. DState era -> UMap (EraCrypto era)
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 (EraCrypto era)) 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 (CertState era) where
  totalAda :: CertState era -> Coin
totalAda (CertState VState era
ds PState era
ps DState era
vs) = forall t. TotalAda t => t -> Coin
totalAda VState era
ds forall a. Semigroup a => a -> a -> a
<> forall t. TotalAda t => t -> Coin
totalAda PState era
ps forall a. Semigroup a => a -> a -> a
<> forall t. TotalAda t => t -> Coin
totalAda DState era
vs

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

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 t. TotalAda t => t -> Coin
totalAda 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 -> AccountState
esAccountState 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) => EpochState era -> AdaPots
totalAdaPotsES EpochState era
es
adaPots Proof era
Babbage EpochState era
es = forall era. (EraTxOut era, EraGov era) => EpochState era -> AdaPots
totalAdaPotsES EpochState era
es
adaPots Proof era
Alonzo EpochState era
es = forall era. (EraTxOut era, EraGov era) => EpochState era -> AdaPots
totalAdaPotsES EpochState era
es
adaPots Proof era
Mary EpochState era
es = forall era. (EraTxOut era, EraGov era) => EpochState era -> AdaPots
totalAdaPotsES EpochState era
es
adaPots Proof era
Allegra EpochState era
es = forall era. (EraTxOut era, EraGov era) => EpochState era -> AdaPots
totalAdaPotsES EpochState era
es
adaPots Proof era
Shelley EpochState era
es = forall era. (EraTxOut era, EraGov era) => EpochState era -> AdaPots
totalAdaPotsES EpochState era
es
{-# NOINLINE adaPots #-}