{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# 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.Plutus.Context (EraPlutusContext, mkSupportedLanguageM)
import Cardano.Ledger.Alonzo.Scripts (plutusScriptLanguage)
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),
 )
import Cardano.Ledger.Coin (Coin (..))
import Cardano.Ledger.Compactible (fromCompact)
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Credential (Credential, StakeReference (..))
import Cardano.Ledger.Plutus.Data (Datum (..), binaryDataToData, hashData)
import Cardano.Ledger.Plutus.Language (Language (..))
import Cardano.Ledger.Shelley.AdaPots (AdaPots (..), totalAdaPotsES)
import Cardano.Ledger.Shelley.LedgerState (
  EpochState (..),
  LedgerState (..),
  NewEpochState (..),
  UTxOState (..),
 )
import Cardano.Ledger.Shelley.Scripts (pattern RequireAllOf, pattern RequireAnyOf)
import Cardano.Ledger.Shelley.TxOut (ShelleyTxOut (..))
import Cardano.Ledger.TxIn (TxIn (..))
import Cardano.Ledger.Val (Val ((<+>), (<->)), inject)
import Cardano.Slotting.EpochInfo.API (epochInfoSize)
import Control.Monad.Reader (runReader)
import Control.Monad.Trans.Fail.String (errorFail)
import Data.Default (Default (def))
import qualified Data.Foldable as Fold (fold, toList)
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import Data.Maybe (maybeToList)
import Data.Maybe.Strict (StrictMaybe (..))
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.ModelState (MUtxo, Model, ModelNewEpochState (..))
import Test.Cardano.Ledger.Generic.Proof (Proof (..), Reflect (..))
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

-- | Positive numbers are "deposits owed", negative amounts are "refunds gained"
depositsAndRefunds ::
  (EraAccounts era, EraPParams era, ShelleyEraTxCert era) =>
  PParams era ->
  [TxCert era] ->
  Accounts era ->
  Coin
depositsAndRefunds :: forall era.
(EraAccounts era, EraPParams era, ShelleyEraTxCert era) =>
PParams era -> [TxCert era] -> Accounts era -> Coin
depositsAndRefunds PParams era
pp [TxCert era]
certificates Accounts era
accounts = (Coin -> TxCert era -> Coin) -> Coin -> [TxCert era] -> Coin
forall b a. (b -> a -> b) -> b -> [a] -> b
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 PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era. EraPParams era => Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
ans
    accum Coin
ans (UnRegTxCert Credential Staking
cred) =
      case Credential Staking -> Accounts era -> Maybe (AccountState era)
forall era.
EraAccounts era =>
Credential Staking -> Accounts era -> Maybe (AccountState era)
lookupAccountState Credential Staking
cred Accounts era
accounts of
        Maybe (AccountState era)
Nothing -> Coin
ans
        Just AccountState era
accountState -> Coin
ans Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (AccountState era
accountState AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
depositAccountStateL)
    accum Coin
ans (RegPoolTxCert StakePoolParams
_) = PParams era
pp PParams era -> Getting Coin (PParams era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (PParams era) Coin
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppPoolDepositL Coin -> Coin -> Coin
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 TopTx era -> Set ScriptHash
scriptWitsNeeded' :: forall era.
Proof era -> MUtxo era -> TxBody TopTx era -> Set ScriptHash
scriptWitsNeeded' Proof era
Conway MUtxo era
utxo TxBody TopTx era
txBody = Set ScriptHash
regularScripts Set ScriptHash -> Set ScriptHash -> Set ScriptHash
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ScriptHash
inlineScripts
  where
    theUtxo :: UTxO era
theUtxo = MUtxo era -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo
    inputs :: Set TxIn
inputs = TxBody TopTx era
txBody TxBody TopTx era
-> Getting (Set TxIn) (TxBody TopTx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody TopTx era) (Set TxIn)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL
    inlineScripts :: Set ScriptHash
inlineScripts = Map ScriptHash (AlonzoScript ConwayEra) -> Set ScriptHash
forall k a. Map k a -> Set k
Map.keysSet (Map ScriptHash (AlonzoScript ConwayEra) -> Set ScriptHash)
-> Map ScriptHash (AlonzoScript ConwayEra) -> Set ScriptHash
forall a b. (a -> b) -> a -> b
$ UTxO era -> Set TxIn -> Map ScriptHash (Script era)
forall era.
BabbageEraTxOut era =>
UTxO era -> Set TxIn -> Map ScriptHash (Script era)
getReferenceScripts UTxO era
theUtxo Set TxIn
inputs
    regularScripts :: Set ScriptHash
regularScripts = ScriptsNeeded ConwayEra -> Set ScriptHash
forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (UTxO era -> TxBody TopTx era -> ScriptsNeeded era
forall era (t :: TxLevel).
EraUTxO era =>
UTxO era -> TxBody t era -> ScriptsNeeded era
forall (t :: TxLevel).
UTxO era -> TxBody t era -> ScriptsNeeded era
getScriptsNeeded UTxO era
theUtxo TxBody TopTx era
txBody)
scriptWitsNeeded' Proof era
Babbage MUtxo era
utxo TxBody TopTx era
txBody = Set ScriptHash
regularScripts Set ScriptHash -> Set ScriptHash -> Set ScriptHash
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set ScriptHash
inlineScripts
  where
    theUtxo :: UTxO era
theUtxo = MUtxo era -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo
    inputs :: Set TxIn
inputs = (TxBody TopTx era
txBody TxBody TopTx era
-> Getting (Set TxIn) (TxBody TopTx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody TopTx era) (Set TxIn)
forall era (l :: TxLevel).
EraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
inputsTxBodyL) Set TxIn -> Set TxIn -> Set TxIn
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (TxBody TopTx era
txBody TxBody TopTx era
-> Getting (Set TxIn) (TxBody TopTx era) (Set TxIn) -> Set TxIn
forall s a. s -> Getting a s a -> a
^. Getting (Set TxIn) (TxBody TopTx era) (Set TxIn)
forall era (l :: TxLevel).
BabbageEraTxBody era =>
Lens' (TxBody l era) (Set TxIn)
forall (l :: TxLevel). Lens' (TxBody l era) (Set TxIn)
referenceInputsTxBodyL)
    inlineScripts :: Set ScriptHash
inlineScripts = Map ScriptHash (AlonzoScript BabbageEra) -> Set ScriptHash
forall k a. Map k a -> Set k
Map.keysSet (Map ScriptHash (AlonzoScript BabbageEra) -> Set ScriptHash)
-> Map ScriptHash (AlonzoScript BabbageEra) -> Set ScriptHash
forall a b. (a -> b) -> a -> b
$ UTxO era -> Set TxIn -> Map ScriptHash (Script era)
forall era.
BabbageEraTxOut era =>
UTxO era -> Set TxIn -> Map ScriptHash (Script era)
getReferenceScripts UTxO era
theUtxo Set TxIn
inputs
    regularScripts :: Set ScriptHash
regularScripts = ScriptsNeeded BabbageEra -> Set ScriptHash
forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (UTxO era -> TxBody TopTx era -> ScriptsNeeded era
forall era (t :: TxLevel).
EraUTxO era =>
UTxO era -> TxBody t era -> ScriptsNeeded era
forall (t :: TxLevel).
UTxO era -> TxBody t era -> ScriptsNeeded era
getScriptsNeeded UTxO era
theUtxo TxBody TopTx era
txBody)
scriptWitsNeeded' Proof era
Alonzo MUtxo era
utxo TxBody TopTx era
txBody =
  ScriptsNeeded AlonzoEra -> Set ScriptHash
forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (UTxO era -> TxBody TopTx era -> ScriptsNeeded era
forall era (t :: TxLevel).
EraUTxO era =>
UTxO era -> TxBody t era -> ScriptsNeeded era
forall (t :: TxLevel).
UTxO era -> TxBody t era -> ScriptsNeeded era
getScriptsNeeded (MUtxo era -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody TopTx era
txBody)
scriptWitsNeeded' Proof era
Mary MUtxo era
utxo TxBody TopTx era
txBody =
  ScriptsNeeded MaryEra -> Set ScriptHash
forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (UTxO era -> TxBody TopTx era -> ScriptsNeeded era
forall era (t :: TxLevel).
EraUTxO era =>
UTxO era -> TxBody t era -> ScriptsNeeded era
forall (t :: TxLevel).
UTxO era -> TxBody t era -> ScriptsNeeded era
getScriptsNeeded (MUtxo era -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody TopTx era
txBody)
scriptWitsNeeded' Proof era
Allegra MUtxo era
utxo TxBody TopTx era
txBody =
  ScriptsNeeded AllegraEra -> Set ScriptHash
forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (UTxO era -> TxBody TopTx era -> ScriptsNeeded era
forall era (t :: TxLevel).
EraUTxO era =>
UTxO era -> TxBody t era -> ScriptsNeeded era
forall (t :: TxLevel).
UTxO era -> TxBody t era -> ScriptsNeeded era
getScriptsNeeded (MUtxo era -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody TopTx era
txBody)
scriptWitsNeeded' Proof era
Shelley MUtxo era
utxo TxBody TopTx era
txBody =
  ScriptsNeeded ShelleyEra -> Set ScriptHash
forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (UTxO era -> TxBody TopTx era -> ScriptsNeeded era
forall era (t :: TxLevel).
EraUTxO era =>
UTxO era -> TxBody t era -> ScriptsNeeded era
forall (t :: TxLevel).
UTxO era -> TxBody t era -> ScriptsNeeded era
getScriptsNeeded (MUtxo era -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody TopTx era
txBody)
{-# NOINLINE scriptWitsNeeded' #-}

scriptsNeeded' :: EraUTxO era => MUtxo era -> TxBody TopTx era -> Set ScriptHash
scriptsNeeded' :: forall era.
EraUTxO era =>
MUtxo era -> TxBody TopTx era -> Set ScriptHash
scriptsNeeded' MUtxo era
utxo TxBody TopTx era
txBody =
  ScriptsNeeded era -> Set ScriptHash
forall era. EraUTxO era => ScriptsNeeded era -> Set ScriptHash
getScriptsHashesNeeded (UTxO era -> TxBody TopTx era -> ScriptsNeeded era
forall era (t :: TxLevel).
EraUTxO era =>
UTxO era -> TxBody t era -> ScriptsNeeded era
forall (t :: TxLevel).
UTxO era -> TxBody t era -> ScriptsNeeded era
getScriptsNeeded (MUtxo era -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO MUtxo era
utxo) TxBody TopTx 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 = UTxO era -> Coin
forall era. EraTxOut era => UTxO era -> Coin
sumCoinUTxO (MUtxo era -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (MUtxo era -> Set TxIn -> MUtxo era
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys MUtxo era
m Set TxIn
txinSet))

injectFee :: EraTxOut era => Coin -> TxOut era -> TxOut era
injectFee :: forall era. EraTxOut era => Coin -> TxOut era -> TxOut era
injectFee Coin
fee TxOut era
txOut = TxOut era
txOut TxOut era -> (TxOut era -> TxOut era) -> TxOut era
forall a b. a -> (a -> b) -> b
& (Value era -> Identity (Value era))
-> TxOut era -> Identity (TxOut era)
forall era. EraTxOut era => Lens' (TxOut era) (Value era)
Lens' (TxOut era) (Value era)
valueTxOutL ((Value era -> Identity (Value era))
 -> TxOut era -> Identity (TxOut era))
-> (Value era -> Value era) -> TxOut era -> TxOut era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Value era -> Value era -> Value era
forall t. Val t => t -> t -> t
<+> Coin -> Value era
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 era)
StrictMaybe (Script ConwayEra)
ms
getTxOutRefScript Proof era
Babbage (BabbageTxOut Addr
_ Value BabbageEra
_ Datum BabbageEra
_ StrictMaybe (Script BabbageEra)
ms) = StrictMaybe (Script era)
StrictMaybe (Script BabbageEra)
ms
getTxOutRefScript Proof era
_ TxOut era
_ = StrictMaybe (Script 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 = ShelleyGovState era
forall a. Default a => a
def
emptyPPUPstate Proof era
Babbage = ShelleyGovState era
forall a. Default a => a
def
emptyPPUPstate Proof era
Alonzo = ShelleyGovState era
forall a. Default a => a
def
emptyPPUPstate Proof era
Mary = ShelleyGovState era
forall a. Default a => a
def
emptyPPUPstate Proof era
Allegra = ShelleyGovState era
forall a. Default a => a
def
emptyPPUPstate Proof era
Shelley = ShelleyGovState era
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 TopTx era -> IsValid
isValid' :: forall era. Proof era -> Tx TopTx era -> IsValid
isValid' Proof era
Conway Tx TopTx era
x = Tx TopTx era
x Tx TopTx era -> Getting IsValid (Tx TopTx era) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx TopTx era) IsValid
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
isValidTxL
isValid' Proof era
Babbage Tx TopTx era
x = Tx TopTx era
x Tx TopTx era -> Getting IsValid (Tx TopTx era) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx TopTx era) IsValid
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
isValidTxL
isValid' Proof era
Alonzo Tx TopTx era
x = Tx TopTx era
x Tx TopTx era -> Getting IsValid (Tx TopTx era) IsValid -> IsValid
forall s a. s -> Getting a s a -> a
^. Getting IsValid (Tx TopTx era) IsValid
forall era. AlonzoEraTx era => Lens' (Tx TopTx era) IsValid
Lens' (Tx TopTx era) IsValid
isValidTxL
isValid' Proof era
_ Tx TopTx 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, DataHash -> Maybe DataHash
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, Maybe DataHash
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, Maybe DataHash
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, DataHash -> Maybe DataHash
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, DataHash -> Maybe DataHash
forall a. a -> Maybe a
Just (forall era. Data era -> DataHash
hashData @era (BinaryData era -> Data 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, Maybe DataHash
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, DataHash -> Maybe DataHash
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, DataHash -> Maybe DataHash
forall a. a -> Maybe a
Just (forall era. Data era -> DataHash
hashData @era (BinaryData era -> Data 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, Maybe DataHash
forall a. Maybe a
Nothing)
txoutEvidence Proof era
Allegra (ShelleyTxOut Addr
addr Value AllegraEra
_) =
  (Addr -> [Credential Payment]
addrCredentials Addr
addr, Maybe DataHash
forall a. Maybe a
Nothing)
txoutEvidence Proof era
Shelley (ShelleyTxOut Addr
addr Value ShelleyEra
_) =
  (Addr -> [Credential Payment]
addrCredentials Addr
addr, Maybe DataHash
forall a. Maybe a
Nothing)
{-# NOINLINE txoutEvidence #-}

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

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

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

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

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

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

alwaysSucceedsLang' :: forall era. EraPlutusContext era => Language -> Natural -> Script era
alwaysSucceedsLang' :: forall era.
EraPlutusContext era =>
Language -> Natural -> Script era
alwaysSucceedsLang' Language
l =
  PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript (PlutusScript era -> Script era)
-> (Natural -> PlutusScript era) -> Natural -> Script era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SupportedLanguage era -> Natural -> PlutusScript era
forall era. SupportedLanguage era -> Natural -> PlutusScript era
alwaysSucceedsLang (Fail (SupportedLanguage era) -> SupportedLanguage era
forall a. HasCallStack => Fail a -> a
errorFail (forall era (m :: * -> *).
(EraPlutusContext era, MonadFail m) =>
Language -> m (SupportedLanguage era)
mkSupportedLanguageM @era Language
l))

alwaysFailsLang' :: forall era. EraPlutusContext era => Language -> Natural -> Script era
alwaysFailsLang' :: forall era.
EraPlutusContext era =>
Language -> Natural -> Script era
alwaysFailsLang' Language
l =
  PlutusScript era -> Script era
forall era. AlonzoEraScript era => PlutusScript era -> Script era
fromPlutusScript (PlutusScript era -> Script era)
-> (Natural -> PlutusScript era) -> Natural -> Script era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SupportedLanguage era -> Natural -> PlutusScript era
forall era. SupportedLanguage era -> Natural -> PlutusScript era
alwaysFailsLang (Fail (SupportedLanguage era) -> SupportedLanguage era
forall a. HasCallStack => Fail a -> a
errorFail (forall era (m :: * -> *).
(EraPlutusContext era, MonadFail m) =>
Language -> m (SupportedLanguage era)
mkSupportedLanguageM @era Language
l))

alwaysTrue :: forall era. EraPlutusContext era => Maybe Language -> Natural -> Script era
alwaysTrue :: forall era.
EraPlutusContext era =>
Maybe Language -> Natural -> Script era
alwaysTrue (Just Language
l) Natural
n = forall era.
EraPlutusContext era =>
Language -> Natural -> Script era
alwaysSucceedsLang' @era Language
l Natural
n
alwaysTrue Maybe Language
Nothing Natural
_ = NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript (NativeScript era -> Script era) -> NativeScript era -> Script era
forall a b. (a -> b) -> a -> b
$ StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAllOf StrictSeq (NativeScript era)
forall a. Monoid a => a
mempty
{-# NOINLINE alwaysTrue #-}

alwaysFalse :: forall era. EraPlutusContext era => Maybe Language -> Natural -> Script era
alwaysFalse :: forall era.
EraPlutusContext era =>
Maybe Language -> Natural -> Script era
alwaysFalse (Just Language
l) Natural
n = forall era.
EraPlutusContext era =>
Language -> Natural -> Script era
alwaysFailsLang' @era Language
l Natural
n
alwaysFalse Maybe Language
Nothing Natural
_ = NativeScript era -> Script era
forall era. EraScript era => NativeScript era -> Script era
fromNativeScript (NativeScript era -> Script era) -> NativeScript era -> Script era
forall a b. (a -> b) -> a -> b
$ StrictSeq (NativeScript era) -> NativeScript era
forall era.
ShelleyEraScript era =>
StrictSeq (NativeScript era) -> NativeScript era
RequireAnyOf StrictSeq (NativeScript era)
forall a. Monoid a => a
mempty
{-# NOINLINE alwaysFalse #-}

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

-- | Create an old style RewardUpdate to be used in tests, in any Era.
createRUpdNonPulsing' ::
  forall era.
  ( EraPParams era
  , EraAccounts era
  ) =>
  Model era ->
  RewardUpdateOld
createRUpdNonPulsing' :: forall era.
(EraPParams era, EraAccounts era) =>
Model era -> RewardUpdateOld
createRUpdNonPulsing' Model era
model =
  let bm :: BlocksMade
bm = Map (KeyHash StakePool) Natural -> BlocksMade
BlocksMade (Map (KeyHash StakePool) Natural -> BlocksMade)
-> Map (KeyHash StakePool) Natural -> BlocksMade
forall a b. (a -> b) -> a -> b
$ Model era -> Map (KeyHash StakePool) Natural
forall era.
ModelNewEpochState era -> Map (KeyHash StakePool) Natural
mBcur Model era
model -- TODO or should this be mBprev?
      ss :: SnapShots
ss = Model era -> SnapShots
forall era. ModelNewEpochState era -> SnapShots
mSnapshots Model era
model
      as :: ChainAccountState
as = Model era -> ChainAccountState
forall era. ModelNewEpochState era -> ChainAccountState
mChainAccountState Model era
model
      reserves :: Coin
reserves = ChainAccountState -> Coin
casReserves ChainAccountState
as
      pp :: PParams era
pp = Model era -> PParams era
forall era. ModelNewEpochState era -> PParams era
mPParams Model era
model
      totalStake :: Coin
totalStake = CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin) -> CompactForm Coin -> Coin
forall a b. (a -> b) -> a -> b
$ (AccountState era -> CompactForm Coin)
-> Map (Credential Staking) (AccountState era) -> CompactForm Coin
forall m a. Monoid m => (a -> m) -> Map (Credential Staking) a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL) (Model era -> Accounts era
forall era. ModelNewEpochState era -> Accounts era
mAccounts Model era
model Accounts era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (Accounts era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential Staking) (AccountState era))
  (Accounts era)
  (Map (Credential Staking) (AccountState era))
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL)
      rs :: Set (Credential Staking)
rs = Map (Credential Staking) (AccountState era)
-> Set (Credential Staking)
forall k a. Map k a -> Set k
Map.keysSet (Model era -> Accounts era
forall era. ModelNewEpochState era -> Accounts era
mAccounts Model era
model Accounts era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (Accounts era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. Getting
  (Map (Credential Staking) (AccountState era))
  (Accounts era)
  (Map (Credential Staking) (AccountState era))
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL) -- TODO or should we look at delegated keys instead?
      en :: EpochNo
en = Model era -> EpochNo
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 EpochInfo (Either Text) -> EpochNo -> Either Text EpochSize
forall (m :: * -> *).
HasCallStack =>
EpochInfo m -> EpochNo -> m EpochSize
epochInfoSize (Globals -> EpochInfo (Either Text)
epochInfo Globals
testGlobals) EpochNo
en of
        Left Text
err -> String -> EpochSize
forall a. HasCallStack => String -> a
error (String
"Failed to calculate slots per epoch:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
err)
        Right EpochSize
x -> EpochSize
x
   in (Reader Globals RewardUpdateOld -> Globals -> RewardUpdateOld
forall r a. Reader r a -> r -> a
`runReader` Globals
testGlobals) (Reader Globals RewardUpdateOld -> RewardUpdateOld)
-> Reader Globals RewardUpdateOld -> RewardUpdateOld
forall a b. (a -> b) -> a -> b
$
        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 NonMyopic
forall a. Default a => a
def
{-# NOINLINE createRUpdNonPulsing' #-}

languagesUsed ::
  forall era.
  Proof era ->
  Tx TopTx era ->
  UTxO era ->
  Set ScriptHash ->
  Set Language
languagesUsed :: forall era.
Proof era
-> Tx TopTx era -> UTxO era -> Set ScriptHash -> Set Language
languagesUsed Proof era
proof Tx TopTx era
tx UTxO era
utxo Set ScriptHash
sNeeded = case Proof era
proof of
  Proof era
Shelley -> Set Language
forall a. Set a
Set.empty
  Proof era
Allegra -> Set Language
forall a. Set a
Set.empty
  Proof era
Mary -> Set Language
forall a. Set a
Set.empty
  Proof era
Alonzo -> Tx TopTx era -> UTxO era -> Set ScriptHash -> Set Language
forall era.
(EraUTxO era, AlonzoEraScript era) =>
Tx TopTx era -> UTxO era -> Set ScriptHash -> Set Language
languages Tx TopTx era
tx UTxO era
utxo Set ScriptHash
sNeeded
  Proof era
Babbage -> Tx TopTx era -> UTxO era -> Set ScriptHash -> Set Language
forall era.
(EraUTxO era, AlonzoEraScript era) =>
Tx TopTx era -> UTxO era -> Set ScriptHash -> Set Language
languages Tx TopTx era
tx UTxO era
utxo Set ScriptHash
sNeeded
  Proof era
Conway -> Tx TopTx era -> UTxO era -> Set ScriptHash -> Set Language
forall era.
(EraUTxO era, AlonzoEraScript era) =>
Tx TopTx era -> UTxO era -> Set ScriptHash -> Set Language
languages Tx TopTx 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 TopTx era ->
  UTxO era ->
  Set ScriptHash ->
  Set Language
languages :: forall era.
(EraUTxO era, AlonzoEraScript era) =>
Tx TopTx era -> UTxO era -> Set ScriptHash -> Set Language
languages Tx TopTx era
tx UTxO era
utxo Set ScriptHash
sNeeded = (Set Language -> Script era -> Set Language)
-> Set Language -> Map ScriptHash (Script era) -> Set Language
forall a b k. (a -> b -> a) -> a -> Map k b -> a
Map.foldl' Set Language -> Script era -> Set Language
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 AlonzoEraScript era) =>
Set Language -> Script era -> Set Language
accum Set Language
forall a. Set a
Set.empty Map ScriptHash (Script era)
allScripts
  where
    allScripts :: Map ScriptHash (Script era)
allScripts = Map ScriptHash (Script era)
-> Set ScriptHash -> Map ScriptHash (Script era)
forall k a. Ord k => Map k a -> Set k -> Map k a
Map.restrictKeys (ScriptsProvided era -> Map ScriptHash (Script era)
forall era. ScriptsProvided era -> Map ScriptHash (Script era)
unScriptsProvided (ScriptsProvided era -> Map ScriptHash (Script era))
-> ScriptsProvided era -> Map ScriptHash (Script era)
forall a b. (a -> b) -> a -> b
$ UTxO era -> Tx TopTx era -> ScriptsProvided era
forall era (t :: TxLevel).
EraUTxO era =>
UTxO era -> Tx t era -> ScriptsProvided era
forall (t :: TxLevel). UTxO era -> Tx t era -> ScriptsProvided era
getScriptsProvided UTxO era
utxo Tx TopTx era
tx) Set ScriptHash
sNeeded
    accum :: Set Language -> Script era -> Set Language
accum Set Language
ans Script era
script =
      case Script era -> Maybe (PlutusScript era)
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 -> Language -> Set Language -> Set Language
forall a. Ord a => a -> Set a -> Set a
Set.insert (PlutusScript era -> Language
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 Coin -> Coin -> Coin
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) =
    UTxO era -> Coin
forall t. TotalAda t => t -> Coin
totalAda UTxO era
utxo Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
fees Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> GovState era -> Coin
forall era. Reflect era => GovState era -> Coin
govStateTotalAda GovState era
gs Coin -> Coin -> Coin
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) = (Coin -> TxOut era -> Coin) -> Coin -> Map TxIn (TxOut era) -> Coin
forall b a. (b -> a -> b) -> b -> Map TxIn a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Coin -> TxOut era -> Coin
forall {era}.
(Assert
   (OrdCond
      (CmpNat (ProtVerLow era) (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerLow era)) 'True 'True 'False)
   (TypeError ...),
 Assert
   (OrdCond (CmpNat 0 (ProtVerHigh era)) 'True 'True 'False)
   (TypeError ...),
 EraTxOut era) =>
Coin -> TxOut era -> Coin
accum Coin
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 TxOut era -> Getting Coin (TxOut era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. Getting Coin (TxOut era) Coin
forall era. (HasCallStack, EraTxOut era) => Lens' (TxOut era) Coin
Lens' (TxOut era) Coin
coinTxOutL) Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
ans

instance EraAccounts era => TotalAda (DState era) where
  totalAda :: DState era -> Coin
totalAda DState era
dState =
    CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin) -> CompactForm Coin -> Coin
forall a b. (a -> b) -> a -> b
$
      (AccountState era -> CompactForm Coin)
-> Map (Credential Staking) (AccountState era) -> CompactForm Coin
forall m a. Monoid m => (a -> m) -> Map (Credential Staking) a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\AccountState era
as -> (AccountState era
as AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
balanceAccountStateL) CompactForm Coin -> CompactForm Coin -> CompactForm Coin
forall a. Semigroup a => a -> a -> a
<> (AccountState era
as AccountState era
-> Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. Getting (CompactForm Coin) (AccountState era) (CompactForm Coin)
forall era.
EraAccounts era =>
Lens' (AccountState era) (CompactForm Coin)
Lens' (AccountState era) (CompactForm Coin)
depositAccountStateL)) (Map (Credential Staking) (AccountState era) -> CompactForm Coin)
-> Map (Credential Staking) (AccountState era) -> CompactForm Coin
forall a b. (a -> b) -> a -> b
$
        DState era
dState DState era
-> Getting
     (Map (Credential Staking) (AccountState era))
     (DState era)
     (Map (Credential Staking) (AccountState era))
-> Map (Credential Staking) (AccountState era)
forall s a. s -> Getting a s a -> a
^. (Accounts era
 -> Const
      (Map (Credential Staking) (AccountState era)) (Accounts era))
-> DState era
-> Const (Map (Credential Staking) (AccountState era)) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era
  -> Const
       (Map (Credential Staking) (AccountState era)) (Accounts era))
 -> DState era
 -> Const
      (Map (Credential Staking) (AccountState era)) (DState era))
-> ((Map (Credential Staking) (AccountState era)
     -> Const
          (Map (Credential Staking) (AccountState era))
          (Map (Credential Staking) (AccountState era)))
    -> Accounts era
    -> Const
         (Map (Credential Staking) (AccountState era)) (Accounts era))
-> Getting
     (Map (Credential Staking) (AccountState era))
     (DState era)
     (Map (Credential Staking) (AccountState era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (Credential Staking) (AccountState era)
 -> Const
      (Map (Credential Staking) (AccountState era))
      (Map (Credential Staking) (AccountState era)))
-> Accounts era
-> Const
     (Map (Credential Staking) (AccountState era)) (Accounts era)
forall era.
EraAccounts era =>
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
Lens' (Accounts era) (Map (Credential Staking) (AccountState era))
accountsMapL

instance TotalAda (PState era) where
  totalAda :: PState era -> Coin
totalAda PState era
pstate = Map (KeyHash StakePool) Coin -> Coin
forall m. Monoid m => Map (KeyHash StakePool) m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
Fold.fold (CompactForm Coin -> Coin
forall a. Compactible a => CompactForm a -> a
fromCompact (CompactForm Coin -> Coin)
-> (StakePoolState -> CompactForm Coin) -> StakePoolState -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StakePoolState -> CompactForm Coin
spsDeposit (StakePoolState -> Coin)
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) Coin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PState era -> Map (KeyHash StakePool) StakePoolState
forall era. PState era -> Map (KeyHash StakePool) StakePoolState
psStakePools PState era
pstate)

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

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

instance TotalAda (ShelleyGovState era) where
  totalAda :: ShelleyGovState era -> Coin
totalAda ShelleyGovState era
_ = Coin
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 -> GovState era -> Coin
ShelleyGovState ShelleyEra -> Coin
forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Mary -> GovState era -> Coin
ShelleyGovState MaryEra -> Coin
forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Allegra -> GovState era -> Coin
ShelleyGovState AllegraEra -> Coin
forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Alonzo -> GovState era -> Coin
ShelleyGovState AlonzoEra -> Coin
forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Babbage -> GovState era -> Coin
ShelleyGovState BabbageEra -> Coin
forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Conway -> GovState era -> Coin
ConwayGovState ConwayEra -> Coin
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 -> CertState era -> Coin
ShelleyCertState ShelleyEra -> Coin
forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Mary -> CertState era -> Coin
ShelleyCertState MaryEra -> Coin
forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Allegra -> CertState era -> Coin
ShelleyCertState AllegraEra -> Coin
forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Alonzo -> CertState era -> Coin
ShelleyCertState AlonzoEra -> Coin
forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Babbage -> CertState era -> Coin
ShelleyCertState BabbageEra -> Coin
forall t. TotalAda t => t -> Coin
totalAda
  Proof era
Conway -> CertState era -> Coin
ConwayCertState ConwayEra -> Coin
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) = UTxOState era -> Coin
forall t. TotalAda t => t -> Coin
totalAda UTxOState era
utxos Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> CertState era -> Coin
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 = LedgerState era -> Coin
forall t. TotalAda t => t -> Coin
totalAda (EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
eps) Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> ChainAccountState -> Coin
forall t. TotalAda t => t -> Coin
totalAda (EpochState era -> ChainAccountState
forall era. EpochState era -> ChainAccountState
esChainAccountState EpochState era
eps)

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