{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module      : LedgerState
-- Description : Operational Rules
--
-- This module implements the operation rules for treating UTxO transactions ('Tx')
-- as state transformations on a ledger state ('LedgerState'),
-- as specified in /A Simplified Formal Specification of a UTxO Ledger/.
module Shelley.Spec.Ledger.LedgerState
  ( AccountState (..),
    DPState (..),
    DState (..),
    EpochState (..),
    FutureGenDeleg (..),
    InstantaneousRewards (..),
    Ix,
    KeyPairs,
    LedgerState (..),
    PPUPState (..),
    PState (..),
    RewardAccounts,
    RewardUpdate (..),
    UTxOState (..),
    depositPoolChange,
    emptyAccount,
    emptyDPState,
    emptyDState,
    emptyEpochState,
    emptyInstantaneousRewards,
    emptyLedgerState,
    emptyPPUPState,
    emptyPState,
    emptyRewardUpdate,
    emptyUTxOState,
    pvCanFollow,
    reapRewards,
    totalInstantaneousReservesRewards,
    updatePpup,

    -- * state transitions
    emptyDelegation,

    -- * Genesis State
    genesisState,

    -- * Validation
    WitHashes (..),
    nullWitHashes,
    diffWitHashes,
    minfee,
    minfeeBound,
    txsize,
    txsizeBound,
    produced,
    consumed,
    verifiedWits,
    witsVKeyNeeded,
    witsFromWitnessSet,

    -- * DelegationState
    keyRefunds,

    -- * Epoch boundary
    stakeDistr,
    applyRUpd,
    createRUpd,
    --
    NewEpochState (..),
    getGKeys,
    updateNES,
    circulation,

    -- * Decay
    decayFactor,

    -- * Remove Bootstrap Redeem Addresses
    returnRedeemAddrsToReserves,
  )
where

import Cardano.Binary
  ( FromCBOR (..),
    ToCBOR (..),
    encodeListLen,
  )
import qualified Cardano.Ledger.Core as Core
import qualified Cardano.Ledger.Crypto as CC (Crypto)
import Cardano.Ledger.Era (Crypto, Era)
import Cardano.Ledger.Shelley (ShelleyBased)
import qualified Cardano.Ledger.Shelley as Shelley
import Cardano.Ledger.Val ((<+>), (<->), (<×>))
import qualified Cardano.Ledger.Val as Val
import Control.DeepSeq (NFData)
import Control.Monad.Trans.Reader (asks)
import Control.SetAlgebra (Bimap, biMapEmpty, dom, eval, forwards, range, (∈), (∪+), (▷), (◁))
import qualified Data.ByteString.Lazy as BSL (length)
import Data.Coerce (coerce)
import Data.Foldable (fold, toList)
import Data.Group (invert)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Ratio ((%))
import Data.Sequence.Strict (StrictSeq)
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic)
import GHC.Records (HasField (..))
import NoThunks.Class (NoThunks (..))
import Quiet
import Shelley.Spec.Ledger.Address (Addr (..), bootstrapKeyHash, isBootstrapRedeemer)
import Shelley.Spec.Ledger.Address.Bootstrap
  ( BootstrapWitness (..),
    bootstrapWitKeyHash,
    verifyBootstrapWit,
  )
import Shelley.Spec.Ledger.BaseTypes
  ( Globals (..),
    ShelleyBase,
    StrictMaybe (..),
    activeSlotVal,
    intervalValue,
    unitIntervalToRational,
  )
import Shelley.Spec.Ledger.Coin
  ( Coin (..),
    DeltaCoin (..),
    addDeltaCoin,
    rationalToCoinViaFloor,
    toDeltaCoin,
  )
import Shelley.Spec.Ledger.Credential (Credential (..))
import Shelley.Spec.Ledger.Delegation.Certificates
  ( DCert (..),
    PoolDistr (..),
    delegCWitness,
    genesisCWitness,
    isDeRegKey,
    poolCWitness,
    requiresVKeyWitness,
  )
import Shelley.Spec.Ledger.EpochBoundary
  ( BlocksMade (..),
    SnapShot (..),
    SnapShots (..),
    Stake (..),
    aggregateUtxoCoinByCredential,
    emptySnapShots,
  )
import Shelley.Spec.Ledger.Hashing (hashAnnotated)
import Shelley.Spec.Ledger.Keys
  ( DSignable,
    GenDelegPair (..),
    GenDelegs (..),
    Hash,
    KeyHash (..),
    KeyPair,
    KeyRole (..),
    VKey,
    asWitness,
  )
import Shelley.Spec.Ledger.PParams
  ( PParams,
    PParams' (..),
    ProposedPPUpdates (..),
    ProtVer (..),
    Update (..),
    emptyPPPUpdates,
    emptyPParams,
  )
import Shelley.Spec.Ledger.Rewards
  ( Likelihood (..),
    NonMyopic (..),
    applyDecay,
    emptyNonMyopic,
    reward,
  )
import Shelley.Spec.Ledger.Serialization (decodeRecordNamed, mapFromCBOR, mapToCBOR)
import Shelley.Spec.Ledger.Slot
  ( EpochNo (..),
    EpochSize,
    SlotNo (..),
  )
import Shelley.Spec.Ledger.Tx
  ( Tx (..),
    WitnessSet,
    WitnessSetHKD (..),
    addrWits,
    extractKeyHashWitnessSet,
  )
import Shelley.Spec.Ledger.TxBody
  ( EraIndependentTxBody,
    Ix,
    PoolCert (..),
    PoolParams (..),
    Ptr (..),
    RewardAcnt (..),
    TxIn (..),
    TxOut (..),
    Wdrl (..),
    WitVKey (..),
    getRwdCred,
    witKeyHash,
  )
import Shelley.Spec.Ledger.UTxO
  ( UTxO (..),
    balance,
    totalDeposits,
    txinLookup,
    txins,
    txouts,
    txup,
    verifyWitVKey,
  )

-- | Representation of a list of pairs of key pairs, e.g., pay and stake keys
type KeyPairs era = [(KeyPair 'Payment era, KeyPair 'Staking era)]

type RewardAccounts era =
  Map (Credential 'Staking era) Coin

data FutureGenDeleg crypto = FutureGenDeleg
  { FutureGenDeleg crypto -> SlotNo
fGenDelegSlot :: !SlotNo,
    FutureGenDeleg crypto -> KeyHash 'Genesis crypto
fGenDelegGenKeyHash :: !(KeyHash 'Genesis crypto)
  }
  deriving (Int -> FutureGenDeleg crypto -> ShowS
[FutureGenDeleg crypto] -> ShowS
FutureGenDeleg crypto -> String
(Int -> FutureGenDeleg crypto -> ShowS)
-> (FutureGenDeleg crypto -> String)
-> ([FutureGenDeleg crypto] -> ShowS)
-> Show (FutureGenDeleg crypto)
forall crypto. Int -> FutureGenDeleg crypto -> ShowS
forall crypto. [FutureGenDeleg crypto] -> ShowS
forall crypto. FutureGenDeleg crypto -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FutureGenDeleg crypto] -> ShowS
$cshowList :: forall crypto. [FutureGenDeleg crypto] -> ShowS
show :: FutureGenDeleg crypto -> String
$cshow :: forall crypto. FutureGenDeleg crypto -> String
showsPrec :: Int -> FutureGenDeleg crypto -> ShowS
$cshowsPrec :: forall crypto. Int -> FutureGenDeleg crypto -> ShowS
Show, FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
(FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool)
-> (FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool)
-> Eq (FutureGenDeleg crypto)
forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
$c/= :: forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
== :: FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
$c== :: forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
Eq, Eq (FutureGenDeleg crypto)
Eq (FutureGenDeleg crypto)
-> (FutureGenDeleg crypto -> FutureGenDeleg crypto -> Ordering)
-> (FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool)
-> (FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool)
-> (FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool)
-> (FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool)
-> (FutureGenDeleg crypto
    -> FutureGenDeleg crypto -> FutureGenDeleg crypto)
-> (FutureGenDeleg crypto
    -> FutureGenDeleg crypto -> FutureGenDeleg crypto)
-> Ord (FutureGenDeleg crypto)
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Ordering
FutureGenDeleg crypto
-> FutureGenDeleg crypto -> FutureGenDeleg crypto
forall crypto. Eq (FutureGenDeleg crypto)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Ordering
forall crypto.
FutureGenDeleg crypto
-> FutureGenDeleg crypto -> FutureGenDeleg crypto
min :: FutureGenDeleg crypto
-> FutureGenDeleg crypto -> FutureGenDeleg crypto
$cmin :: forall crypto.
FutureGenDeleg crypto
-> FutureGenDeleg crypto -> FutureGenDeleg crypto
max :: FutureGenDeleg crypto
-> FutureGenDeleg crypto -> FutureGenDeleg crypto
$cmax :: forall crypto.
FutureGenDeleg crypto
-> FutureGenDeleg crypto -> FutureGenDeleg crypto
>= :: FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
$c>= :: forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
> :: FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
$c> :: forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
<= :: FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
$c<= :: forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
< :: FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
$c< :: forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Bool
compare :: FutureGenDeleg crypto -> FutureGenDeleg crypto -> Ordering
$ccompare :: forall crypto.
FutureGenDeleg crypto -> FutureGenDeleg crypto -> Ordering
$cp1Ord :: forall crypto. Eq (FutureGenDeleg crypto)
Ord, (forall x. FutureGenDeleg crypto -> Rep (FutureGenDeleg crypto) x)
-> (forall x.
    Rep (FutureGenDeleg crypto) x -> FutureGenDeleg crypto)
-> Generic (FutureGenDeleg crypto)
forall x. Rep (FutureGenDeleg crypto) x -> FutureGenDeleg crypto
forall x. FutureGenDeleg crypto -> Rep (FutureGenDeleg crypto) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall crypto x.
Rep (FutureGenDeleg crypto) x -> FutureGenDeleg crypto
forall crypto x.
FutureGenDeleg crypto -> Rep (FutureGenDeleg crypto) x
$cto :: forall crypto x.
Rep (FutureGenDeleg crypto) x -> FutureGenDeleg crypto
$cfrom :: forall crypto x.
FutureGenDeleg crypto -> Rep (FutureGenDeleg crypto) x
Generic)

instance NoThunks (FutureGenDeleg crypto)

instance NFData (FutureGenDeleg crypto)

instance CC.Crypto crypto => ToCBOR (FutureGenDeleg crypto) where
  toCBOR :: FutureGenDeleg crypto -> Encoding
toCBOR (FutureGenDeleg SlotNo
a KeyHash 'Genesis crypto
b) =
    Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SlotNo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR SlotNo
a Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> KeyHash 'Genesis crypto -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR KeyHash 'Genesis crypto
b

instance CC.Crypto crypto => FromCBOR (FutureGenDeleg crypto) where
  fromCBOR :: Decoder s (FutureGenDeleg crypto)
fromCBOR = do
    Text
-> (FutureGenDeleg crypto -> Int)
-> Decoder s (FutureGenDeleg crypto)
-> Decoder s (FutureGenDeleg crypto)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"FutureGenDeleg" (Int -> FutureGenDeleg crypto -> Int
forall a b. a -> b -> a
const Int
2) (Decoder s (FutureGenDeleg crypto)
 -> Decoder s (FutureGenDeleg crypto))
-> Decoder s (FutureGenDeleg crypto)
-> Decoder s (FutureGenDeleg crypto)
forall a b. (a -> b) -> a -> b
$ do
      SlotNo
a <- Decoder s SlotNo
forall a s. FromCBOR a => Decoder s a
fromCBOR
      KeyHash 'Genesis crypto
b <- Decoder s (KeyHash 'Genesis crypto)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      FutureGenDeleg crypto -> Decoder s (FutureGenDeleg crypto)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FutureGenDeleg crypto -> Decoder s (FutureGenDeleg crypto))
-> FutureGenDeleg crypto -> Decoder s (FutureGenDeleg crypto)
forall a b. (a -> b) -> a -> b
$ SlotNo -> KeyHash 'Genesis crypto -> FutureGenDeleg crypto
forall crypto.
SlotNo -> KeyHash 'Genesis crypto -> FutureGenDeleg crypto
FutureGenDeleg SlotNo
a KeyHash 'Genesis crypto
b

data InstantaneousRewards era = InstantaneousRewards
  { InstantaneousRewards era -> Map (Credential 'Staking era) Coin
iRReserves :: !(Map (Credential 'Staking era) Coin),
    InstantaneousRewards era -> Map (Credential 'Staking era) Coin
iRTreasury :: !(Map (Credential 'Staking era) Coin)
  }
  deriving (Int -> InstantaneousRewards era -> ShowS
[InstantaneousRewards era] -> ShowS
InstantaneousRewards era -> String
(Int -> InstantaneousRewards era -> ShowS)
-> (InstantaneousRewards era -> String)
-> ([InstantaneousRewards era] -> ShowS)
-> Show (InstantaneousRewards era)
forall era. Int -> InstantaneousRewards era -> ShowS
forall era. [InstantaneousRewards era] -> ShowS
forall era. InstantaneousRewards era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InstantaneousRewards era] -> ShowS
$cshowList :: forall era. [InstantaneousRewards era] -> ShowS
show :: InstantaneousRewards era -> String
$cshow :: forall era. InstantaneousRewards era -> String
showsPrec :: Int -> InstantaneousRewards era -> ShowS
$cshowsPrec :: forall era. Int -> InstantaneousRewards era -> ShowS
Show, InstantaneousRewards era -> InstantaneousRewards era -> Bool
(InstantaneousRewards era -> InstantaneousRewards era -> Bool)
-> (InstantaneousRewards era -> InstantaneousRewards era -> Bool)
-> Eq (InstantaneousRewards era)
forall era.
InstantaneousRewards era -> InstantaneousRewards era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InstantaneousRewards era -> InstantaneousRewards era -> Bool
$c/= :: forall era.
InstantaneousRewards era -> InstantaneousRewards era -> Bool
== :: InstantaneousRewards era -> InstantaneousRewards era -> Bool
$c== :: forall era.
InstantaneousRewards era -> InstantaneousRewards era -> Bool
Eq, (forall x.
 InstantaneousRewards era -> Rep (InstantaneousRewards era) x)
-> (forall x.
    Rep (InstantaneousRewards era) x -> InstantaneousRewards era)
-> Generic (InstantaneousRewards era)
forall x.
Rep (InstantaneousRewards era) x -> InstantaneousRewards era
forall x.
InstantaneousRewards era -> Rep (InstantaneousRewards era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x.
Rep (InstantaneousRewards era) x -> InstantaneousRewards era
forall era x.
InstantaneousRewards era -> Rep (InstantaneousRewards era) x
$cto :: forall era x.
Rep (InstantaneousRewards era) x -> InstantaneousRewards era
$cfrom :: forall era x.
InstantaneousRewards era -> Rep (InstantaneousRewards era) x
Generic)

totalInstantaneousReservesRewards :: InstantaneousRewards era -> Coin
totalInstantaneousReservesRewards :: InstantaneousRewards era -> Coin
totalInstantaneousReservesRewards (InstantaneousRewards Map (Credential 'Staking era) Coin
irR Map (Credential 'Staking era) Coin
_) = Map (Credential 'Staking era) Coin -> Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map (Credential 'Staking era) Coin
irR

instance NoThunks (InstantaneousRewards era)

instance NFData (InstantaneousRewards era)

instance
  (Era era, Core.AnnotatedData (Core.Script era)) =>
  ToCBOR (InstantaneousRewards era)
  where
  toCBOR :: InstantaneousRewards era -> Encoding
toCBOR (InstantaneousRewards Map (Credential 'Staking era) Coin
irR Map (Credential 'Staking era) Coin
irT) =
    Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (Credential 'Staking era) Coin -> Encoding
forall a b. (ToCBOR a, ToCBOR b) => Map a b -> Encoding
mapToCBOR Map (Credential 'Staking era) Coin
irR Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (Credential 'Staking era) Coin -> Encoding
forall a b. (ToCBOR a, ToCBOR b) => Map a b -> Encoding
mapToCBOR Map (Credential 'Staking era) Coin
irT

instance
  (Era era, Core.AnnotatedData (Core.Script era)) =>
  FromCBOR (InstantaneousRewards era)
  where
  fromCBOR :: Decoder s (InstantaneousRewards era)
fromCBOR = do
    Text
-> (InstantaneousRewards era -> Int)
-> Decoder s (InstantaneousRewards era)
-> Decoder s (InstantaneousRewards era)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"InstantaneousRewards" (Int -> InstantaneousRewards era -> Int
forall a b. a -> b -> a
const Int
2) (Decoder s (InstantaneousRewards era)
 -> Decoder s (InstantaneousRewards era))
-> Decoder s (InstantaneousRewards era)
-> Decoder s (InstantaneousRewards era)
forall a b. (a -> b) -> a -> b
$ do
      Map (Credential 'Staking era) Coin
irR <- Decoder s (Map (Credential 'Staking era) Coin)
forall a b s.
(Ord a, FromCBOR a, FromCBOR b) =>
Decoder s (Map a b)
mapFromCBOR
      Map (Credential 'Staking era) Coin
irT <- Decoder s (Map (Credential 'Staking era) Coin)
forall a b s.
(Ord a, FromCBOR a, FromCBOR b) =>
Decoder s (Map a b)
mapFromCBOR
      InstantaneousRewards era -> Decoder s (InstantaneousRewards era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InstantaneousRewards era -> Decoder s (InstantaneousRewards era))
-> InstantaneousRewards era -> Decoder s (InstantaneousRewards era)
forall a b. (a -> b) -> a -> b
$ Map (Credential 'Staking era) Coin
-> Map (Credential 'Staking era) Coin -> InstantaneousRewards era
forall era.
Map (Credential 'Staking era) Coin
-> Map (Credential 'Staking era) Coin -> InstantaneousRewards era
InstantaneousRewards Map (Credential 'Staking era) Coin
irR Map (Credential 'Staking era) Coin
irT

-- | State of staking pool delegations and rewards
data DState era = DState
  { -- | The active reward accounts.
    DState era -> RewardAccounts era
_rewards :: !(RewardAccounts era),
    -- | The current delegations.
    DState era
-> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
_delegations :: !(Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))),
    -- | The pointed to hash keys.
    DState era -> Bimap Ptr (Credential 'Staking era)
_ptrs :: !(Bimap Ptr (Credential 'Staking era)),
    -- | future genesis key delegations
    DState era
-> Map (FutureGenDeleg (Crypto era)) (GenDelegPair (Crypto era))
_fGenDelegs :: !(Map (FutureGenDeleg (Crypto era)) (GenDelegPair (Crypto era))),
    -- | Genesis key delegations
    DState era -> GenDelegs (Crypto era)
_genDelegs :: !(GenDelegs (Crypto era)),
    -- | Instantaneous Rewards
    DState era -> InstantaneousRewards era
_irwd :: !(InstantaneousRewards era)
  }
  deriving (Int -> DState era -> ShowS
[DState era] -> ShowS
DState era -> String
(Int -> DState era -> ShowS)
-> (DState era -> String)
-> ([DState era] -> ShowS)
-> Show (DState era)
forall era. Int -> DState era -> ShowS
forall era. [DState era] -> ShowS
forall era. DState era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DState era] -> ShowS
$cshowList :: forall era. [DState era] -> ShowS
show :: DState era -> String
$cshow :: forall era. DState era -> String
showsPrec :: Int -> DState era -> ShowS
$cshowsPrec :: forall era. Int -> DState era -> ShowS
Show, DState era -> DState era -> Bool
(DState era -> DState era -> Bool)
-> (DState era -> DState era -> Bool) -> Eq (DState era)
forall era. DState era -> DState era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DState era -> DState era -> Bool
$c/= :: forall era. DState era -> DState era -> Bool
== :: DState era -> DState era -> Bool
$c== :: forall era. DState era -> DState era -> Bool
Eq, (forall x. DState era -> Rep (DState era) x)
-> (forall x. Rep (DState era) x -> DState era)
-> Generic (DState era)
forall x. Rep (DState era) x -> DState era
forall x. DState era -> Rep (DState era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (DState era) x -> DState era
forall era x. DState era -> Rep (DState era) x
$cto :: forall era x. Rep (DState era) x -> DState era
$cfrom :: forall era x. DState era -> Rep (DState era) x
Generic)

instance NoThunks (DState era)

instance NFData (DState era)

instance
  (Era era, Core.AnnotatedData (Core.Script era)) =>
  ToCBOR (DState era)
  where
  toCBOR :: DState era -> Encoding
toCBOR (DState RewardAccounts era
rw Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
dlg Bimap Ptr (Credential 'Staking era)
p Map (FutureGenDeleg (Crypto era)) (GenDelegPair (Crypto era))
fgs GenDelegs (Crypto era)
gs InstantaneousRewards era
ir) =
    Word -> Encoding
encodeListLen Word
6
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> RewardAccounts era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR RewardAccounts era
rw
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
-> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
dlg
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Bimap Ptr (Credential 'Staking era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Bimap Ptr (Credential 'Staking era)
p
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (FutureGenDeleg (Crypto era)) (GenDelegPair (Crypto era))
-> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Map (FutureGenDeleg (Crypto era)) (GenDelegPair (Crypto era))
fgs
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> GenDelegs (Crypto era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR GenDelegs (Crypto era)
gs
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> InstantaneousRewards era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR InstantaneousRewards era
ir

instance
  (Era era, Core.AnnotatedData (Core.Script era)) =>
  FromCBOR (DState era)
  where
  fromCBOR :: Decoder s (DState era)
fromCBOR = do
    Text
-> (DState era -> Int)
-> Decoder s (DState era)
-> Decoder s (DState era)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"DState" (Int -> DState era -> Int
forall a b. a -> b -> a
const Int
6) (Decoder s (DState era) -> Decoder s (DState era))
-> Decoder s (DState era) -> Decoder s (DState era)
forall a b. (a -> b) -> a -> b
$ do
      RewardAccounts era
rw <- Decoder s (RewardAccounts era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
dlg <- Decoder
  s (Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era)))
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Bimap Ptr (Credential 'Staking era)
p <- Decoder s (Bimap Ptr (Credential 'Staking era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Map (FutureGenDeleg (Crypto era)) (GenDelegPair (Crypto era))
fgs <- Decoder
  s (Map (FutureGenDeleg (Crypto era)) (GenDelegPair (Crypto era)))
forall a s. FromCBOR a => Decoder s a
fromCBOR
      GenDelegs (Crypto era)
gs <- Decoder s (GenDelegs (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
      InstantaneousRewards era
ir <- Decoder s (InstantaneousRewards era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      DState era -> Decoder s (DState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DState era -> Decoder s (DState era))
-> DState era -> Decoder s (DState era)
forall a b. (a -> b) -> a -> b
$ RewardAccounts era
-> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
-> Bimap Ptr (Credential 'Staking era)
-> Map (FutureGenDeleg (Crypto era)) (GenDelegPair (Crypto era))
-> GenDelegs (Crypto era)
-> InstantaneousRewards era
-> DState era
forall era.
RewardAccounts era
-> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
-> Bimap Ptr (Credential 'Staking era)
-> Map (FutureGenDeleg (Crypto era)) (GenDelegPair (Crypto era))
-> GenDelegs (Crypto era)
-> InstantaneousRewards era
-> DState era
DState RewardAccounts era
rw Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
dlg Bimap Ptr (Credential 'Staking era)
p Map (FutureGenDeleg (Crypto era)) (GenDelegPair (Crypto era))
fgs GenDelegs (Crypto era)
gs InstantaneousRewards era
ir

-- | Current state of staking pools and their certificate counters.
data PState era = PState
  { -- | The pool parameters.
    PState era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
_pParams :: !(Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)),
    -- | The future pool parameters.
    PState era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
_fPParams :: !(Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)),
    -- | A map of retiring stake pools to the epoch when they retire.
    PState era -> Map (KeyHash 'StakePool (Crypto era)) EpochNo
_retiring :: !(Map (KeyHash 'StakePool (Crypto era)) EpochNo)
  }
  deriving (Int -> PState era -> ShowS
[PState era] -> ShowS
PState era -> String
(Int -> PState era -> ShowS)
-> (PState era -> String)
-> ([PState era] -> ShowS)
-> Show (PState era)
forall era. Int -> PState era -> ShowS
forall era. [PState era] -> ShowS
forall era. PState era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PState era] -> ShowS
$cshowList :: forall era. [PState era] -> ShowS
show :: PState era -> String
$cshow :: forall era. PState era -> String
showsPrec :: Int -> PState era -> ShowS
$cshowsPrec :: forall era. Int -> PState era -> ShowS
Show, PState era -> PState era -> Bool
(PState era -> PState era -> Bool)
-> (PState era -> PState era -> Bool) -> Eq (PState era)
forall era. PState era -> PState era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PState era -> PState era -> Bool
$c/= :: forall era. PState era -> PState era -> Bool
== :: PState era -> PState era -> Bool
$c== :: forall era. PState era -> PState era -> Bool
Eq, (forall x. PState era -> Rep (PState era) x)
-> (forall x. Rep (PState era) x -> PState era)
-> Generic (PState era)
forall x. Rep (PState era) x -> PState era
forall x. PState era -> Rep (PState era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (PState era) x -> PState era
forall era x. PState era -> Rep (PState era) x
$cto :: forall era x. Rep (PState era) x -> PState era
$cfrom :: forall era x. PState era -> Rep (PState era) x
Generic)

instance NoThunks (PState era)

instance NFData (PState era)

instance Era era => ToCBOR (PState era) where
  toCBOR :: PState era -> Encoding
toCBOR (PState Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
a Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
b Map (KeyHash 'StakePool (Crypto era)) EpochNo
c) =
    Word -> Encoding
encodeListLen Word
3 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
a Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
b Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (KeyHash 'StakePool (Crypto era)) EpochNo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Map (KeyHash 'StakePool (Crypto era)) EpochNo
c

instance Era era => FromCBOR (PState era) where
  fromCBOR :: Decoder s (PState era)
fromCBOR = do
    Text
-> (PState era -> Int)
-> Decoder s (PState era)
-> Decoder s (PState era)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"PState" (Int -> PState era -> Int
forall a b. a -> b -> a
const Int
3) (Decoder s (PState era) -> Decoder s (PState era))
-> Decoder s (PState era) -> Decoder s (PState era)
forall a b. (a -> b) -> a -> b
$ do
      Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
a <- Decoder s (Map (KeyHash 'StakePool (Crypto era)) (PoolParams era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
b <- Decoder s (Map (KeyHash 'StakePool (Crypto era)) (PoolParams era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Map (KeyHash 'StakePool (Crypto era)) EpochNo
c <- Decoder s (Map (KeyHash 'StakePool (Crypto era)) EpochNo)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      PState era -> Decoder s (PState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PState era -> Decoder s (PState era))
-> PState era -> Decoder s (PState era)
forall a b. (a -> b) -> a -> b
$ Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> Map (KeyHash 'StakePool (Crypto era)) EpochNo
-> PState era
forall era.
Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> Map (KeyHash 'StakePool (Crypto era)) EpochNo
-> PState era
PState Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
a Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
b Map (KeyHash 'StakePool (Crypto era)) EpochNo
c

-- | The state associated with the current stake delegation.
data DPState era = DPState
  { DPState era -> DState era
_dstate :: !(DState era),
    DPState era -> PState era
_pstate :: !(PState era)
  }
  deriving (Int -> DPState era -> ShowS
[DPState era] -> ShowS
DPState era -> String
(Int -> DPState era -> ShowS)
-> (DPState era -> String)
-> ([DPState era] -> ShowS)
-> Show (DPState era)
forall era. Int -> DPState era -> ShowS
forall era. [DPState era] -> ShowS
forall era. DPState era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DPState era] -> ShowS
$cshowList :: forall era. [DPState era] -> ShowS
show :: DPState era -> String
$cshow :: forall era. DPState era -> String
showsPrec :: Int -> DPState era -> ShowS
$cshowsPrec :: forall era. Int -> DPState era -> ShowS
Show, DPState era -> DPState era -> Bool
(DPState era -> DPState era -> Bool)
-> (DPState era -> DPState era -> Bool) -> Eq (DPState era)
forall era. DPState era -> DPState era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DPState era -> DPState era -> Bool
$c/= :: forall era. DPState era -> DPState era -> Bool
== :: DPState era -> DPState era -> Bool
$c== :: forall era. DPState era -> DPState era -> Bool
Eq, (forall x. DPState era -> Rep (DPState era) x)
-> (forall x. Rep (DPState era) x -> DPState era)
-> Generic (DPState era)
forall x. Rep (DPState era) x -> DPState era
forall x. DPState era -> Rep (DPState era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (DPState era) x -> DPState era
forall era x. DPState era -> Rep (DPState era) x
$cto :: forall era x. Rep (DPState era) x -> DPState era
$cfrom :: forall era x. DPState era -> Rep (DPState era) x
Generic)

instance NoThunks (DPState era)

instance NFData (DPState era)

instance
  (Era era, Core.AnnotatedData (Core.Script era)) =>
  ToCBOR (DPState era)
  where
  toCBOR :: DPState era -> Encoding
toCBOR (DPState DState era
ds PState era
ps) =
    Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> DState era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR DState era
ds Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PState era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PState era
ps

instance
  (Era era, Core.AnnotatedData (Core.Script era)) =>
  FromCBOR (DPState era)
  where
  fromCBOR :: Decoder s (DPState era)
fromCBOR = do
    Text
-> (DPState era -> Int)
-> Decoder s (DPState era)
-> Decoder s (DPState era)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"DPState" (Int -> DPState era -> Int
forall a b. a -> b -> a
const Int
2) (Decoder s (DPState era) -> Decoder s (DPState era))
-> Decoder s (DPState era) -> Decoder s (DPState era)
forall a b. (a -> b) -> a -> b
$ do
      DState era
ds <- Decoder s (DState era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      PState era
ps <- Decoder s (PState era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      DPState era -> Decoder s (DPState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DPState era -> Decoder s (DPState era))
-> DPState era -> Decoder s (DPState era)
forall a b. (a -> b) -> a -> b
$ DState era -> PState era -> DPState era
forall era. DState era -> PState era -> DPState era
DPState DState era
ds PState era
ps

data RewardUpdate era = RewardUpdate
  { RewardUpdate era -> Coin
deltaT :: !Coin,
    RewardUpdate era -> DeltaCoin
deltaR :: !DeltaCoin,
    RewardUpdate era -> Map (Credential 'Staking era) Coin
rs :: !(Map (Credential 'Staking era) Coin),
    RewardUpdate era -> DeltaCoin
deltaF :: !DeltaCoin,
    RewardUpdate era -> NonMyopic era
nonMyopic :: !(NonMyopic era)
  }
  deriving (Int -> RewardUpdate era -> ShowS
[RewardUpdate era] -> ShowS
RewardUpdate era -> String
(Int -> RewardUpdate era -> ShowS)
-> (RewardUpdate era -> String)
-> ([RewardUpdate era] -> ShowS)
-> Show (RewardUpdate era)
forall era. Int -> RewardUpdate era -> ShowS
forall era. [RewardUpdate era] -> ShowS
forall era. RewardUpdate era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RewardUpdate era] -> ShowS
$cshowList :: forall era. [RewardUpdate era] -> ShowS
show :: RewardUpdate era -> String
$cshow :: forall era. RewardUpdate era -> String
showsPrec :: Int -> RewardUpdate era -> ShowS
$cshowsPrec :: forall era. Int -> RewardUpdate era -> ShowS
Show, RewardUpdate era -> RewardUpdate era -> Bool
(RewardUpdate era -> RewardUpdate era -> Bool)
-> (RewardUpdate era -> RewardUpdate era -> Bool)
-> Eq (RewardUpdate era)
forall era. RewardUpdate era -> RewardUpdate era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RewardUpdate era -> RewardUpdate era -> Bool
$c/= :: forall era. RewardUpdate era -> RewardUpdate era -> Bool
== :: RewardUpdate era -> RewardUpdate era -> Bool
$c== :: forall era. RewardUpdate era -> RewardUpdate era -> Bool
Eq, (forall x. RewardUpdate era -> Rep (RewardUpdate era) x)
-> (forall x. Rep (RewardUpdate era) x -> RewardUpdate era)
-> Generic (RewardUpdate era)
forall x. Rep (RewardUpdate era) x -> RewardUpdate era
forall x. RewardUpdate era -> Rep (RewardUpdate era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (RewardUpdate era) x -> RewardUpdate era
forall era x. RewardUpdate era -> Rep (RewardUpdate era) x
$cto :: forall era x. Rep (RewardUpdate era) x -> RewardUpdate era
$cfrom :: forall era x. RewardUpdate era -> Rep (RewardUpdate era) x
Generic)

instance NoThunks (RewardUpdate era)

instance NFData (RewardUpdate era)

instance
  (Era era, Core.AnnotatedData (Core.Script era)) =>
  ToCBOR (RewardUpdate era)
  where
  toCBOR :: RewardUpdate era -> Encoding
toCBOR (RewardUpdate Coin
dt DeltaCoin
dr Map (Credential 'Staking era) Coin
rw DeltaCoin
df NonMyopic era
nm) =
    Word -> Encoding
encodeListLen Word
5
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Coin
dt
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> DeltaCoin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (DeltaCoin -> DeltaCoin
forall m. Group m => m -> m
invert DeltaCoin
dr) -- TODO change Coin serialization to use integers?
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Map (Credential 'Staking era) Coin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Map (Credential 'Staking era) Coin
rw
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> DeltaCoin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR (DeltaCoin -> DeltaCoin
forall m. Group m => m -> m
invert DeltaCoin
df) -- TODO change Coin serialization to use integers?
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> NonMyopic era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR NonMyopic era
nm

instance
  (Era era, Core.AnnotatedData (Core.Script era)) =>
  FromCBOR (RewardUpdate era)
  where
  fromCBOR :: Decoder s (RewardUpdate era)
fromCBOR = do
    Text
-> (RewardUpdate era -> Int)
-> Decoder s (RewardUpdate era)
-> Decoder s (RewardUpdate era)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"RewardUpdate" (Int -> RewardUpdate era -> Int
forall a b. a -> b -> a
const Int
5) (Decoder s (RewardUpdate era) -> Decoder s (RewardUpdate era))
-> Decoder s (RewardUpdate era) -> Decoder s (RewardUpdate era)
forall a b. (a -> b) -> a -> b
$ do
      Coin
dt <- Decoder s Coin
forall a s. FromCBOR a => Decoder s a
fromCBOR
      DeltaCoin
dr <- Decoder s DeltaCoin
forall a s. FromCBOR a => Decoder s a
fromCBOR -- TODO change Coin serialization to use integers?
      Map (Credential 'Staking era) Coin
rw <- Decoder s (Map (Credential 'Staking era) Coin)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      DeltaCoin
df <- Decoder s DeltaCoin
forall a s. FromCBOR a => Decoder s a
fromCBOR -- TODO change Coin serialization to use integers?
      NonMyopic era
nm <- Decoder s (NonMyopic era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      RewardUpdate era -> Decoder s (RewardUpdate era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardUpdate era -> Decoder s (RewardUpdate era))
-> RewardUpdate era -> Decoder s (RewardUpdate era)
forall a b. (a -> b) -> a -> b
$ Coin
-> DeltaCoin
-> Map (Credential 'Staking era) Coin
-> DeltaCoin
-> NonMyopic era
-> RewardUpdate era
forall era.
Coin
-> DeltaCoin
-> Map (Credential 'Staking era) Coin
-> DeltaCoin
-> NonMyopic era
-> RewardUpdate era
RewardUpdate Coin
dt (DeltaCoin -> DeltaCoin
forall m. Group m => m -> m
invert DeltaCoin
dr) Map (Credential 'Staking era) Coin
rw (DeltaCoin -> DeltaCoin
forall m. Group m => m -> m
invert DeltaCoin
df) NonMyopic era
nm

emptyRewardUpdate :: RewardUpdate era
emptyRewardUpdate :: RewardUpdate era
emptyRewardUpdate = Coin
-> DeltaCoin
-> Map (Credential 'Staking era) Coin
-> DeltaCoin
-> NonMyopic era
-> RewardUpdate era
forall era.
Coin
-> DeltaCoin
-> Map (Credential 'Staking era) Coin
-> DeltaCoin
-> NonMyopic era
-> RewardUpdate era
RewardUpdate (Integer -> Coin
Coin Integer
0) (Integer -> DeltaCoin
DeltaCoin Integer
0) Map (Credential 'Staking era) Coin
forall k a. Map k a
Map.empty (Integer -> DeltaCoin
DeltaCoin Integer
0) NonMyopic era
forall era. NonMyopic era
emptyNonMyopic

data AccountState = AccountState
  { AccountState -> Coin
_treasury :: !Coin,
    AccountState -> Coin
_reserves :: !Coin
  }
  deriving (Int -> AccountState -> ShowS
[AccountState] -> ShowS
AccountState -> String
(Int -> AccountState -> ShowS)
-> (AccountState -> String)
-> ([AccountState] -> ShowS)
-> Show AccountState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AccountState] -> ShowS
$cshowList :: [AccountState] -> ShowS
show :: AccountState -> String
$cshow :: AccountState -> String
showsPrec :: Int -> AccountState -> ShowS
$cshowsPrec :: Int -> AccountState -> ShowS
Show, AccountState -> AccountState -> Bool
(AccountState -> AccountState -> Bool)
-> (AccountState -> AccountState -> Bool) -> Eq AccountState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AccountState -> AccountState -> Bool
$c/= :: AccountState -> AccountState -> Bool
== :: AccountState -> AccountState -> Bool
$c== :: AccountState -> AccountState -> Bool
Eq, (forall x. AccountState -> Rep AccountState x)
-> (forall x. Rep AccountState x -> AccountState)
-> Generic AccountState
forall x. Rep AccountState x -> AccountState
forall x. AccountState -> Rep AccountState x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AccountState x -> AccountState
$cfrom :: forall x. AccountState -> Rep AccountState x
Generic)

instance ToCBOR AccountState where
  toCBOR :: AccountState -> Encoding
toCBOR (AccountState Coin
t Coin
r) =
    Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Coin
t Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Coin
r

instance FromCBOR AccountState where
  fromCBOR :: Decoder s AccountState
fromCBOR = do
    Text
-> (AccountState -> Int)
-> Decoder s AccountState
-> Decoder s AccountState
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"AccountState" (Int -> AccountState -> Int
forall a b. a -> b -> a
const Int
2) (Decoder s AccountState -> Decoder s AccountState)
-> Decoder s AccountState -> Decoder s AccountState
forall a b. (a -> b) -> a -> b
$ do
      Coin
t <- Decoder s Coin
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Coin
r <- Decoder s Coin
forall a s. FromCBOR a => Decoder s a
fromCBOR
      AccountState -> Decoder s AccountState
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AccountState -> Decoder s AccountState)
-> AccountState -> Decoder s AccountState
forall a b. (a -> b) -> a -> b
$ Coin -> Coin -> AccountState
AccountState Coin
t Coin
r

instance NoThunks AccountState

instance NFData AccountState

data EpochState era = EpochState
  { EpochState era -> AccountState
esAccountState :: !AccountState,
    EpochState era -> SnapShots era
esSnapshots :: !(SnapShots era),
    EpochState era -> LedgerState era
esLState :: !(LedgerState era),
    EpochState era -> PParams era
esPrevPp :: !(PParams era),
    EpochState era -> PParams era
esPp :: !(PParams era),
    -- | This field, esNonMyopic, does not appear in the formal spec
    -- and is not a part of the protocol. It is only used for providing
    -- data to the stake pool ranking calculation @getNonMyopicMemberRewards@.
    -- See https://hydra.iohk.io/job/Cardano/cardano-ledger-specs/specs.pool-ranking/latest/download-by-type/doc-pdf/pool-ranking
    EpochState era -> NonMyopic era
esNonMyopic :: !(NonMyopic era)
  }
  deriving ((forall x. EpochState era -> Rep (EpochState era) x)
-> (forall x. Rep (EpochState era) x -> EpochState era)
-> Generic (EpochState era)
forall x. Rep (EpochState era) x -> EpochState era
forall x. EpochState era -> Rep (EpochState era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (EpochState era) x -> EpochState era
forall era x. EpochState era -> Rep (EpochState era) x
$cto :: forall era x. Rep (EpochState era) x -> EpochState era
$cfrom :: forall era x. EpochState era -> Rep (EpochState era) x
Generic)

deriving stock instance
  ShelleyBased era =>
  Show (EpochState era)

deriving stock instance
  ShelleyBased era =>
  Eq (EpochState era)

instance NoThunks (EpochState era)

instance (Era era) => NFData (EpochState era)

instance
  ShelleyBased era =>
  ToCBOR (EpochState era)
  where
  toCBOR :: EpochState era -> Encoding
toCBOR (EpochState AccountState
a SnapShots era
s LedgerState era
l PParams era
r PParams era
p NonMyopic era
n) =
    Word -> Encoding
encodeListLen Word
6 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> AccountState -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR AccountState
a Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> SnapShots era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR SnapShots era
s Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> LedgerState era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR LedgerState era
l Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PParams era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PParams era
r Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PParams era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PParams era
p Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> NonMyopic era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR NonMyopic era
n

instance
  ShelleyBased era =>
  FromCBOR (EpochState era)
  where
  fromCBOR :: Decoder s (EpochState era)
fromCBOR = do
    Text
-> (EpochState era -> Int)
-> Decoder s (EpochState era)
-> Decoder s (EpochState era)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"EpochState" (Int -> EpochState era -> Int
forall a b. a -> b -> a
const Int
6) (Decoder s (EpochState era) -> Decoder s (EpochState era))
-> Decoder s (EpochState era) -> Decoder s (EpochState era)
forall a b. (a -> b) -> a -> b
$ do
      AccountState
a <- Decoder s AccountState
forall a s. FromCBOR a => Decoder s a
fromCBOR
      SnapShots era
s <- Decoder s (SnapShots era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      LedgerState era
l <- Decoder s (LedgerState era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      PParams era
r <- Decoder s (PParams era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      PParams era
p <- Decoder s (PParams era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      NonMyopic era
n <- Decoder s (NonMyopic era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      EpochState era -> Decoder s (EpochState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EpochState era -> Decoder s (EpochState era))
-> EpochState era -> Decoder s (EpochState era)
forall a b. (a -> b) -> a -> b
$ AccountState
-> SnapShots era
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic era
-> EpochState era
forall era.
AccountState
-> SnapShots era
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic era
-> EpochState era
EpochState AccountState
a SnapShots era
s LedgerState era
l PParams era
r PParams era
p NonMyopic era
n

emptyPPUPState :: PPUPState era
emptyPPUPState :: PPUPState era
emptyPPUPState = ProposedPPUpdates era -> ProposedPPUpdates era -> PPUPState era
forall era.
ProposedPPUpdates era -> ProposedPPUpdates era -> PPUPState era
PPUPState ProposedPPUpdates era
forall era. ProposedPPUpdates era
emptyPPPUpdates ProposedPPUpdates era
forall era. ProposedPPUpdates era
emptyPPPUpdates

emptyUTxOState :: UTxOState era
emptyUTxOState :: UTxOState era
emptyUTxOState = UTxO era -> Coin -> Coin -> PPUPState era -> UTxOState era
forall era.
UTxO era -> Coin -> Coin -> PPUPState era -> UTxOState era
UTxOState (Map (TxIn era) (TxOut era) -> UTxO era
forall era. Map (TxIn era) (TxOut era) -> UTxO era
UTxO Map (TxIn era) (TxOut era)
forall k a. Map k a
Map.empty) (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0) PPUPState era
forall era. PPUPState era
emptyPPUPState

emptyEpochState :: EpochState era
emptyEpochState :: EpochState era
emptyEpochState =
  AccountState
-> SnapShots era
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic era
-> EpochState era
forall era.
AccountState
-> SnapShots era
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic era
-> EpochState era
EpochState AccountState
emptyAccount SnapShots era
forall era. SnapShots era
emptySnapShots LedgerState era
forall era. LedgerState era
emptyLedgerState PParams era
forall era. PParams era
emptyPParams PParams era
forall era. PParams era
emptyPParams NonMyopic era
forall era. NonMyopic era
emptyNonMyopic

emptyLedgerState :: LedgerState era
emptyLedgerState :: LedgerState era
emptyLedgerState =
  UTxOState era -> DPState era -> LedgerState era
forall era. UTxOState era -> DPState era -> LedgerState era
LedgerState
    UTxOState era
forall era. UTxOState era
emptyUTxOState
    DPState era
forall era. DPState era
emptyDelegation

emptyAccount :: AccountState
emptyAccount :: AccountState
emptyAccount = Coin -> Coin -> AccountState
AccountState (Integer -> Coin
Coin Integer
0) (Integer -> Coin
Coin Integer
0)

emptyDelegation :: DPState era
emptyDelegation :: DPState era
emptyDelegation =
  DState era -> PState era -> DPState era
forall era. DState era -> PState era -> DPState era
DPState DState era
forall era. DState era
emptyDState PState era
forall era. PState era
emptyPState

emptyInstantaneousRewards :: InstantaneousRewards era
emptyInstantaneousRewards :: InstantaneousRewards era
emptyInstantaneousRewards = Map (Credential 'Staking era) Coin
-> Map (Credential 'Staking era) Coin -> InstantaneousRewards era
forall era.
Map (Credential 'Staking era) Coin
-> Map (Credential 'Staking era) Coin -> InstantaneousRewards era
InstantaneousRewards Map (Credential 'Staking era) Coin
forall k a. Map k a
Map.empty Map (Credential 'Staking era) Coin
forall k a. Map k a
Map.empty

emptyDState :: DState era
emptyDState :: DState era
emptyDState =
  RewardAccounts era
-> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
-> Bimap Ptr (Credential 'Staking era)
-> Map (FutureGenDeleg (Crypto era)) (GenDelegPair (Crypto era))
-> GenDelegs (Crypto era)
-> InstantaneousRewards era
-> DState era
forall era.
RewardAccounts era
-> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
-> Bimap Ptr (Credential 'Staking era)
-> Map (FutureGenDeleg (Crypto era)) (GenDelegPair (Crypto era))
-> GenDelegs (Crypto era)
-> InstantaneousRewards era
-> DState era
DState
    RewardAccounts era
forall k a. Map k a
Map.empty
    Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
forall k a. Map k a
Map.empty
    Bimap Ptr (Credential 'Staking era)
forall v k. BiMap v k v
biMapEmpty
    Map (FutureGenDeleg (Crypto era)) (GenDelegPair (Crypto era))
forall k a. Map k a
Map.empty
    (Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
-> GenDelegs (Crypto era)
forall crypto.
Map (KeyHash 'Genesis crypto) (GenDelegPair crypto)
-> GenDelegs crypto
GenDelegs Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
forall k a. Map k a
Map.empty)
    InstantaneousRewards era
forall era. InstantaneousRewards era
emptyInstantaneousRewards

emptyPState :: PState era
emptyPState :: PState era
emptyPState =
  Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> Map (KeyHash 'StakePool (Crypto era)) EpochNo
-> PState era
forall era.
Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> Map (KeyHash 'StakePool (Crypto era)) EpochNo
-> PState era
PState Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
forall k a. Map k a
Map.empty Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
forall k a. Map k a
Map.empty Map (KeyHash 'StakePool (Crypto era)) EpochNo
forall k a. Map k a
Map.empty

emptyDPState :: DPState era
emptyDPState :: DPState era
emptyDPState = DState era -> PState era -> DPState era
forall era. DState era -> PState era -> DPState era
DPState DState era
forall era. DState era
emptyDState PState era
forall era. PState era
emptyPState

data PPUPState era = PPUPState
  { PPUPState era -> ProposedPPUpdates era
proposals :: !(ProposedPPUpdates era),
    PPUPState era -> ProposedPPUpdates era
futureProposals :: !(ProposedPPUpdates era)
  }
  deriving (Int -> PPUPState era -> ShowS
[PPUPState era] -> ShowS
PPUPState era -> String
(Int -> PPUPState era -> ShowS)
-> (PPUPState era -> String)
-> ([PPUPState era] -> ShowS)
-> Show (PPUPState era)
forall era. Int -> PPUPState era -> ShowS
forall era. [PPUPState era] -> ShowS
forall era. PPUPState era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PPUPState era] -> ShowS
$cshowList :: forall era. [PPUPState era] -> ShowS
show :: PPUPState era -> String
$cshow :: forall era. PPUPState era -> String
showsPrec :: Int -> PPUPState era -> ShowS
$cshowsPrec :: forall era. Int -> PPUPState era -> ShowS
Show, PPUPState era -> PPUPState era -> Bool
(PPUPState era -> PPUPState era -> Bool)
-> (PPUPState era -> PPUPState era -> Bool) -> Eq (PPUPState era)
forall era. PPUPState era -> PPUPState era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PPUPState era -> PPUPState era -> Bool
$c/= :: forall era. PPUPState era -> PPUPState era -> Bool
== :: PPUPState era -> PPUPState era -> Bool
$c== :: forall era. PPUPState era -> PPUPState era -> Bool
Eq, (forall x. PPUPState era -> Rep (PPUPState era) x)
-> (forall x. Rep (PPUPState era) x -> PPUPState era)
-> Generic (PPUPState era)
forall x. Rep (PPUPState era) x -> PPUPState era
forall x. PPUPState era -> Rep (PPUPState era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (PPUPState era) x -> PPUPState era
forall era x. PPUPState era -> Rep (PPUPState era) x
$cto :: forall era x. Rep (PPUPState era) x -> PPUPState era
$cfrom :: forall era x. PPUPState era -> Rep (PPUPState era) x
Generic, PPUPState era -> ()
(PPUPState era -> ()) -> NFData (PPUPState era)
forall era. PPUPState era -> ()
forall a. (a -> ()) -> NFData a
rnf :: PPUPState era -> ()
$crnf :: forall era. PPUPState era -> ()
NFData, Context -> PPUPState era -> IO (Maybe ThunkInfo)
Proxy (PPUPState era) -> String
(Context -> PPUPState era -> IO (Maybe ThunkInfo))
-> (Context -> PPUPState era -> IO (Maybe ThunkInfo))
-> (Proxy (PPUPState era) -> String)
-> NoThunks (PPUPState era)
forall era. Context -> PPUPState era -> IO (Maybe ThunkInfo)
forall era. Proxy (PPUPState era) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy (PPUPState era) -> String
$cshowTypeOf :: forall era. Proxy (PPUPState era) -> String
wNoThunks :: Context -> PPUPState era -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall era. Context -> PPUPState era -> IO (Maybe ThunkInfo)
noThunks :: Context -> PPUPState era -> IO (Maybe ThunkInfo)
$cnoThunks :: forall era. Context -> PPUPState era -> IO (Maybe ThunkInfo)
NoThunks)

instance Era era => ToCBOR (PPUPState era) where
  toCBOR :: PPUPState era -> Encoding
toCBOR (PPUPState ProposedPPUpdates era
ppup ProposedPPUpdates era
fppup) =
    Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ProposedPPUpdates era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR ProposedPPUpdates era
ppup Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> ProposedPPUpdates era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR ProposedPPUpdates era
fppup

instance Era era => FromCBOR (PPUPState era) where
  fromCBOR :: Decoder s (PPUPState era)
fromCBOR = do
    Text
-> (PPUPState era -> Int)
-> Decoder s (PPUPState era)
-> Decoder s (PPUPState era)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"PPUPState" (Int -> PPUPState era -> Int
forall a b. a -> b -> a
const Int
2) (Decoder s (PPUPState era) -> Decoder s (PPUPState era))
-> Decoder s (PPUPState era) -> Decoder s (PPUPState era)
forall a b. (a -> b) -> a -> b
$ do
      ProposedPPUpdates era
ppup <- Decoder s (ProposedPPUpdates era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      ProposedPPUpdates era
fppup <- Decoder s (ProposedPPUpdates era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      PPUPState era -> Decoder s (PPUPState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PPUPState era -> Decoder s (PPUPState era))
-> PPUPState era -> Decoder s (PPUPState era)
forall a b. (a -> b) -> a -> b
$ ProposedPPUpdates era -> ProposedPPUpdates era -> PPUPState era
forall era.
ProposedPPUpdates era -> ProposedPPUpdates era -> PPUPState era
PPUPState ProposedPPUpdates era
ppup ProposedPPUpdates era
fppup

pvCanFollow :: ProtVer -> StrictMaybe ProtVer -> Bool
pvCanFollow :: ProtVer -> StrictMaybe ProtVer -> Bool
pvCanFollow ProtVer
_ StrictMaybe ProtVer
SNothing = Bool
True
pvCanFollow (ProtVer Natural
m Natural
n) (SJust (ProtVer Natural
m' Natural
n')) =
  (Natural
m Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1, Natural
0) (Natural, Natural) -> (Natural, Natural) -> Bool
forall a. Eq a => a -> a -> Bool
== (Natural
m', Natural
n') Bool -> Bool -> Bool
|| (Natural
m, Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
1) (Natural, Natural) -> (Natural, Natural) -> Bool
forall a. Eq a => a -> a -> Bool
== (Natural
m', Natural
n')

-- | Update the protocol parameter updates by clearing out the proposals
-- and making the future proposals become the new proposals,
-- provided the new proposals can follow (otherwise reset them).
updatePpup :: UTxOState era -> PParams era -> UTxOState era
updatePpup :: UTxOState era -> PParams era -> UTxOState era
updatePpup UTxOState era
utxoSt PParams era
pp = UTxOState era
utxoSt {_ppups :: PPUPState era
_ppups = ProposedPPUpdates era -> ProposedPPUpdates era -> PPUPState era
forall era.
ProposedPPUpdates era -> ProposedPPUpdates era -> PPUPState era
PPUPState ProposedPPUpdates era
ps ProposedPPUpdates era
forall era. ProposedPPUpdates era
emptyPPPUpdates}
  where
    (ProposedPPUpdates Map (KeyHash 'Genesis (Crypto era)) (PParamsUpdate era)
newProposals) = PPUPState era -> ProposedPPUpdates era
forall era. PPUPState era -> ProposedPPUpdates era
futureProposals (PPUPState era -> ProposedPPUpdates era)
-> (UTxOState era -> PPUPState era)
-> UTxOState era
-> ProposedPPUpdates era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxOState era -> PPUPState era
forall era. UTxOState era -> PPUPState era
_ppups (UTxOState era -> ProposedPPUpdates era)
-> UTxOState era -> ProposedPPUpdates era
forall a b. (a -> b) -> a -> b
$ UTxOState era
utxoSt
    goodPV :: PParamsUpdate era -> Bool
goodPV = ProtVer -> StrictMaybe ProtVer -> Bool
pvCanFollow (PParams era -> HKD Identity ProtVer
forall (f :: * -> *) era. PParams' f era -> HKD f ProtVer
_protocolVersion PParams era
pp) (StrictMaybe ProtVer -> Bool)
-> (PParamsUpdate era -> StrictMaybe ProtVer)
-> PParamsUpdate era
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PParamsUpdate era -> StrictMaybe ProtVer
forall (f :: * -> *) era. PParams' f era -> HKD f ProtVer
_protocolVersion
    ps :: ProposedPPUpdates era
ps = if (PParamsUpdate era -> Bool)
-> Map (KeyHash 'Genesis (Crypto era)) (PParamsUpdate era) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all PParamsUpdate era -> Bool
goodPV Map (KeyHash 'Genesis (Crypto era)) (PParamsUpdate era)
newProposals then Map (KeyHash 'Genesis (Crypto era)) (PParamsUpdate era)
-> ProposedPPUpdates era
forall era.
Map (KeyHash 'Genesis (Crypto era)) (PParamsUpdate era)
-> ProposedPPUpdates era
ProposedPPUpdates Map (KeyHash 'Genesis (Crypto era)) (PParamsUpdate era)
newProposals else ProposedPPUpdates era
forall era. ProposedPPUpdates era
emptyPPPUpdates

data UTxOState era = UTxOState
  { UTxOState era -> UTxO era
_utxo :: !(UTxO era),
    UTxOState era -> Coin
_deposited :: !Coin,
    UTxOState era -> Coin
_fees :: !Coin,
    UTxOState era -> PPUPState era
_ppups :: !(PPUPState era)
  }
  deriving ((forall x. UTxOState era -> Rep (UTxOState era) x)
-> (forall x. Rep (UTxOState era) x -> UTxOState era)
-> Generic (UTxOState era)
forall x. Rep (UTxOState era) x -> UTxOState era
forall x. UTxOState era -> Rep (UTxOState era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (UTxOState era) x -> UTxOState era
forall era x. UTxOState era -> Rep (UTxOState era) x
$cto :: forall era x. Rep (UTxOState era) x -> UTxOState era
$cfrom :: forall era x. UTxOState era -> Rep (UTxOState era) x
Generic, UTxOState era -> ()
(UTxOState era -> ()) -> NFData (UTxOState era)
forall era. Era era => UTxOState era -> ()
forall a. (a -> ()) -> NFData a
rnf :: UTxOState era -> ()
$crnf :: forall era. Era era => UTxOState era -> ()
NFData)

deriving stock instance
  ShelleyBased era =>
  Show (UTxOState era)

deriving stock instance
  ShelleyBased era =>
  Eq (UTxOState era)

instance NoThunks (UTxOState era)

instance
  ShelleyBased era =>
  ToCBOR (UTxOState era)
  where
  toCBOR :: UTxOState era -> Encoding
toCBOR (UTxOState UTxO era
ut Coin
dp Coin
fs PPUPState era
us) =
    Word -> Encoding
encodeListLen Word
4 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> UTxO era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR UTxO era
ut Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Coin
dp Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Coin -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR Coin
fs Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PPUPState era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PPUPState era
us

instance
  ShelleyBased era =>
  FromCBOR (UTxOState era)
  where
  fromCBOR :: Decoder s (UTxOState era)
fromCBOR = do
    Text
-> (UTxOState era -> Int)
-> Decoder s (UTxOState era)
-> Decoder s (UTxOState era)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"UTxOState" (Int -> UTxOState era -> Int
forall a b. a -> b -> a
const Int
4) (Decoder s (UTxOState era) -> Decoder s (UTxOState era))
-> Decoder s (UTxOState era) -> Decoder s (UTxOState era)
forall a b. (a -> b) -> a -> b
$ do
      UTxO era
ut <- Decoder s (UTxO era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Coin
dp <- Decoder s Coin
forall a s. FromCBOR a => Decoder s a
fromCBOR
      Coin
fs <- Decoder s Coin
forall a s. FromCBOR a => Decoder s a
fromCBOR
      PPUPState era
us <- Decoder s (PPUPState era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      UTxOState era -> Decoder s (UTxOState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UTxOState era -> Decoder s (UTxOState era))
-> UTxOState era -> Decoder s (UTxOState era)
forall a b. (a -> b) -> a -> b
$ UTxO era -> Coin -> Coin -> PPUPState era -> UTxOState era
forall era.
UTxO era -> Coin -> Coin -> PPUPState era -> UTxOState era
UTxOState UTxO era
ut Coin
dp Coin
fs PPUPState era
us

-- | New Epoch state and environment
data NewEpochState era = NewEpochState
  { -- | Last epoch
    NewEpochState era -> EpochNo
nesEL :: !EpochNo,
    -- | Blocks made before current epoch
    NewEpochState era -> BlocksMade era
nesBprev :: !(BlocksMade era),
    -- | Blocks made in current epoch
    NewEpochState era -> BlocksMade era
nesBcur :: !(BlocksMade era),
    -- | Epoch state before current
    NewEpochState era -> EpochState era
nesEs :: !(EpochState era),
    -- | Possible reward update
    NewEpochState era -> StrictMaybe (RewardUpdate era)
nesRu :: !(StrictMaybe (RewardUpdate era)),
    -- | Stake distribution within the stake pool
    NewEpochState era -> PoolDistr (Crypto era)
nesPd :: !(PoolDistr (Crypto era))
  }
  deriving ((forall x. NewEpochState era -> Rep (NewEpochState era) x)
-> (forall x. Rep (NewEpochState era) x -> NewEpochState era)
-> Generic (NewEpochState era)
forall x. Rep (NewEpochState era) x -> NewEpochState era
forall x. NewEpochState era -> Rep (NewEpochState era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (NewEpochState era) x -> NewEpochState era
forall era x. NewEpochState era -> Rep (NewEpochState era) x
$cto :: forall era x. Rep (NewEpochState era) x -> NewEpochState era
$cfrom :: forall era x. NewEpochState era -> Rep (NewEpochState era) x
Generic)

deriving stock instance
  ShelleyBased era =>
  Show (NewEpochState era)

deriving stock instance
  ShelleyBased era =>
  Eq (NewEpochState era)

instance (Era era) => NFData (NewEpochState era)

instance NoThunks (NewEpochState era)

instance ShelleyBased era => ToCBOR (NewEpochState era) where
  toCBOR :: NewEpochState era -> Encoding
toCBOR (NewEpochState EpochNo
e BlocksMade era
bp BlocksMade era
bc EpochState era
es StrictMaybe (RewardUpdate era)
ru PoolDistr (Crypto era)
pd) =
    Word -> Encoding
encodeListLen Word
6 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> EpochNo -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR EpochNo
e Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> BlocksMade era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR BlocksMade era
bp Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> BlocksMade era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR BlocksMade era
bc Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> EpochState era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR EpochState era
es
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> StrictMaybe (RewardUpdate era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR StrictMaybe (RewardUpdate era)
ru
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PoolDistr (Crypto era) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PoolDistr (Crypto era)
pd

instance
  ShelleyBased era =>
  FromCBOR (NewEpochState era)
  where
  fromCBOR :: Decoder s (NewEpochState era)
fromCBOR = do
    Text
-> (NewEpochState era -> Int)
-> Decoder s (NewEpochState era)
-> Decoder s (NewEpochState era)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"NewEpochState" (Int -> NewEpochState era -> Int
forall a b. a -> b -> a
const Int
6) (Decoder s (NewEpochState era) -> Decoder s (NewEpochState era))
-> Decoder s (NewEpochState era) -> Decoder s (NewEpochState era)
forall a b. (a -> b) -> a -> b
$ do
      EpochNo
e <- Decoder s EpochNo
forall a s. FromCBOR a => Decoder s a
fromCBOR
      BlocksMade era
bp <- Decoder s (BlocksMade era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      BlocksMade era
bc <- Decoder s (BlocksMade era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      EpochState era
es <- Decoder s (EpochState era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      StrictMaybe (RewardUpdate era)
ru <- Decoder s (StrictMaybe (RewardUpdate era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
      PoolDistr (Crypto era)
pd <- Decoder s (PoolDistr (Crypto era))
forall a s. FromCBOR a => Decoder s a
fromCBOR
      NewEpochState era -> Decoder s (NewEpochState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NewEpochState era -> Decoder s (NewEpochState era))
-> NewEpochState era -> Decoder s (NewEpochState era)
forall a b. (a -> b) -> a -> b
$ EpochNo
-> BlocksMade era
-> BlocksMade era
-> EpochState era
-> StrictMaybe (RewardUpdate era)
-> PoolDistr (Crypto era)
-> NewEpochState era
forall era.
EpochNo
-> BlocksMade era
-> BlocksMade era
-> EpochState era
-> StrictMaybe (RewardUpdate era)
-> PoolDistr (Crypto era)
-> NewEpochState era
NewEpochState EpochNo
e BlocksMade era
bp BlocksMade era
bc EpochState era
es StrictMaybe (RewardUpdate era)
ru PoolDistr (Crypto era)
pd

getGKeys ::
  NewEpochState era ->
  Set (KeyHash 'Genesis (Crypto era))
getGKeys :: NewEpochState era -> Set (KeyHash 'Genesis (Crypto era))
getGKeys NewEpochState era
nes = Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
-> Set (KeyHash 'Genesis (Crypto era))
forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
genDelegs
  where
    NewEpochState EpochNo
_ BlocksMade era
_ BlocksMade era
_ EpochState era
es StrictMaybe (RewardUpdate era)
_ PoolDistr (Crypto era)
_ = NewEpochState era
nes
    EpochState AccountState
_ SnapShots era
_ LedgerState era
ls PParams era
_ PParams era
_ NonMyopic era
_ = EpochState era
es
    LedgerState UTxOState era
_ (DPState (DState RewardAccounts era
_ Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
_ Bimap Ptr (Credential 'Staking era)
_ Map (FutureGenDeleg (Crypto era)) (GenDelegPair (Crypto era))
_ (GenDelegs Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
genDelegs) InstantaneousRewards era
_) PState era
_) = LedgerState era
ls

-- | The state associated with a 'Ledger'.
data LedgerState era = LedgerState
  { -- | The current unspent transaction outputs.
    LedgerState era -> UTxOState era
_utxoState :: !(UTxOState era),
    -- | The current delegation state
    LedgerState era -> DPState era
_delegationState :: !(DPState era)
  }
  deriving ((forall x. LedgerState era -> Rep (LedgerState era) x)
-> (forall x. Rep (LedgerState era) x -> LedgerState era)
-> Generic (LedgerState era)
forall x. Rep (LedgerState era) x -> LedgerState era
forall x. LedgerState era -> Rep (LedgerState era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (LedgerState era) x -> LedgerState era
forall era x. LedgerState era -> Rep (LedgerState era) x
$cto :: forall era x. Rep (LedgerState era) x -> LedgerState era
$cfrom :: forall era x. LedgerState era -> Rep (LedgerState era) x
Generic)

deriving stock instance
  ShelleyBased era =>
  Show (LedgerState era)

deriving stock instance
  ShelleyBased era =>
  Eq (LedgerState era)

instance NoThunks (LedgerState era)

instance (Era era) => NFData (LedgerState era)

instance
  ShelleyBased era =>
  ToCBOR (LedgerState era)
  where
  toCBOR :: LedgerState era -> Encoding
toCBOR (LedgerState UTxOState era
u DPState era
dp) =
    Word -> Encoding
encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> UTxOState era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR UTxOState era
u Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> DPState era -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR DPState era
dp

instance
  ShelleyBased era =>
  FromCBOR (LedgerState era)
  where
  fromCBOR :: Decoder s (LedgerState era)
fromCBOR = do
    Text
-> (LedgerState era -> Int)
-> Decoder s (LedgerState era)
-> Decoder s (LedgerState era)
forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"LedgerState" (Int -> LedgerState era -> Int
forall a b. a -> b -> a
const Int
2) (Decoder s (LedgerState era) -> Decoder s (LedgerState era))
-> Decoder s (LedgerState era) -> Decoder s (LedgerState era)
forall a b. (a -> b) -> a -> b
$ do
      UTxOState era
u <- Decoder s (UTxOState era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      DPState era
dp <- Decoder s (DPState era)
forall a s. FromCBOR a => Decoder s a
fromCBOR
      LedgerState era -> Decoder s (LedgerState era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LedgerState era -> Decoder s (LedgerState era))
-> LedgerState era -> Decoder s (LedgerState era)
forall a b. (a -> b) -> a -> b
$ UTxOState era -> DPState era -> LedgerState era
forall era. UTxOState era -> DPState era -> LedgerState era
LedgerState UTxOState era
u DPState era
dp

-- | Creates the ledger state for an empty ledger which
--  contains the specified transaction outputs.
genesisState ::
  Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era)) ->
  UTxO era ->
  LedgerState era
genesisState :: Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
-> UTxO era -> LedgerState era
genesisState Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
genDelegs0 UTxO era
utxo0 =
  UTxOState era -> DPState era -> LedgerState era
forall era. UTxOState era -> DPState era -> LedgerState era
LedgerState
    ( UTxO era -> Coin -> Coin -> PPUPState era -> UTxOState era
forall era.
UTxO era -> Coin -> Coin -> PPUPState era -> UTxOState era
UTxOState
        UTxO era
utxo0
        (Integer -> Coin
Coin Integer
0)
        (Integer -> Coin
Coin Integer
0)
        PPUPState era
forall era. PPUPState era
emptyPPUPState
    )
    (DState era -> PState era -> DPState era
forall era. DState era -> PState era -> DPState era
DPState DState era
dState PState era
forall era. PState era
emptyPState)
  where
    dState :: DState era
dState = DState era
forall era. DState era
emptyDState {_genDelegs :: GenDelegs (Crypto era)
_genDelegs = Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
-> GenDelegs (Crypto era)
forall crypto.
Map (KeyHash 'Genesis crypto) (GenDelegPair crypto)
-> GenDelegs crypto
GenDelegs Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
genDelegs0}

-- | Implementation of abstract transaction size
txsize :: Tx era -> Integer
txsize :: Tx era -> Integer
txsize = Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Integer) -> (Tx era -> Int64) -> Tx era -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int64
BSL.length (ByteString -> Int64) -> (Tx era -> ByteString) -> Tx era -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tx era -> ByteString
forall era. Tx era -> ByteString
txFullBytes

-- | Convenience Function to bound the txsize function.
-- | It can be helpful for coin selection.
txsizeBound ::
  forall era.
  ( ShelleyBased era,
    HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)),
    HasField "inputs" (Core.TxBody era) (Set (TxIn era))
  ) =>
  Tx era ->
  Integer
txsizeBound :: Tx era -> Integer
txsizeBound Tx era
tx = Integer
numInputs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
inputSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
numOutputs Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
outputSize Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
rest
  where
    uint :: Integer
uint = Integer
5
    smallArray :: Integer
smallArray = Integer
1
    hashLen :: Integer
hashLen = Integer
32
    hashObj :: Integer
hashObj = Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
hashLen
    addrHashLen :: Integer
addrHashLen = Integer
28
    addrHeader :: Integer
addrHeader = Integer
1
    address :: Integer
address = Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
addrHeader Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
addrHashLen
    txbody :: TxBody era
txbody = Tx era -> TxBodyConstraints era => TxBody era
forall era. Tx era -> TxBodyConstraints era => TxBody era
_body Tx era
tx
    numInputs :: Integer
numInputs = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> (TxBody era -> Int) -> TxBody era -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (TxIn era) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Set (TxIn era) -> Int)
-> (TxBody era -> Set (TxIn era)) -> TxBody era -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "inputs" r a => r -> a
getField @"inputs" (TxBody era -> Integer) -> TxBody era -> Integer
forall a b. (a -> b) -> a -> b
$ TxBody era
txbody
    inputSize :: Integer
inputSize = Integer
smallArray Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
uint Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
hashObj
    numOutputs :: Integer
numOutputs = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Int -> Integer) -> (TxBody era -> Int) -> TxBody era -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StrictSeq (TxOut era) -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (StrictSeq (TxOut era) -> Int)
-> (TxBody era -> StrictSeq (TxOut era)) -> TxBody era -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "outputs" r a => r -> a
getField @"outputs" (TxBody era -> Integer) -> TxBody era -> Integer
forall a b. (a -> b) -> a -> b
$ TxBody era
txbody
    outputSize :: Integer
outputSize = Integer
smallArray Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
uint Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
address
    rest :: Integer
rest = Int64 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Integer) -> Int64 -> Integer
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BSL.length (Tx era -> ByteString
forall era. Tx era -> ByteString
txFullBytes Tx era
tx)

-- | Minimum fee calculation
minfee :: PParams era -> Tx era -> Coin
minfee :: PParams era -> Tx era -> Coin
minfee PParams era
pp Tx era
tx =
  Integer -> Coin
Coin (Integer -> Coin) -> Integer -> Coin
forall a b. (a -> b) -> a -> b
$
    Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams era -> HKD Identity Natural
forall (f :: * -> *) era. PParams' f era -> HKD f Natural
_minfeeA PParams era
pp)
      Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Tx era -> Integer
forall era. Tx era -> Integer
txsize Tx era
tx Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams era -> HKD Identity Natural
forall (f :: * -> *) era. PParams' f era -> HKD f Natural
_minfeeB PParams era
pp)

-- | Minimum fee bound using txsizeBound
minfeeBound ::
  forall era.
  ( ShelleyBased era,
    HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)),
    HasField "inputs" (Core.TxBody era) (Set (TxIn era))
  ) =>
  PParams era ->
  Tx era ->
  Coin
minfeeBound :: PParams era -> Tx era -> Coin
minfeeBound PParams era
pp Tx era
tx =
  Integer -> Coin
Coin (Integer -> Coin) -> Integer -> Coin
forall a b. (a -> b) -> a -> b
$
    Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams era -> HKD Identity Natural
forall (f :: * -> *) era. PParams' f era -> HKD f Natural
_minfeeA PParams era
pp)
      Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Tx era -> Integer
forall era.
(ShelleyBased era,
 HasField "outputs" (TxBody era) (StrictSeq (TxOut era)),
 HasField "inputs" (TxBody era) (Set (TxIn era))) =>
Tx era -> Integer
txsizeBound Tx era
tx Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (PParams era -> HKD Identity Natural
forall (f :: * -> *) era. PParams' f era -> HKD f Natural
_minfeeB PParams era
pp)

-- | Compute the lovelace which are created by the transaction
produced ::
  ( ShelleyBased era,
    HasField "certs" (Core.TxBody era) (StrictSeq (DCert era)),
    HasField "outputs" (Core.TxBody era) (StrictSeq (TxOut era)),
    HasField "txfee" (Core.TxBody era) Coin
  ) =>
  PParams era ->
  Map (KeyHash 'StakePool (Crypto era)) (PoolParams era) ->
  Core.TxBody era ->
  Core.Value era
produced :: PParams era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> TxBody era
-> Value era
produced PParams era
pp Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
stakePools TxBody era
tx =
  UTxO era -> Value era
forall era. ShelleyBased era => UTxO era -> Value era
balance (TxBody era -> UTxO era
forall era.
(ShelleyBased era,
 HasField "outputs" (TxBody era) (StrictSeq (TxOut era))) =>
TxBody era -> UTxO era
txouts TxBody era
tx)
    Value era -> Value era -> Value era
forall a. Semigroup a => a -> a -> a
<> ( Coin -> Value era
forall t. Val t => Coin -> t
Val.inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$
           TxBody era -> Coin
forall k (x :: k) r a. HasField x r a => r -> a
getField @"txfee" TxBody era
tx
             Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> PParams era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> [DCert era]
-> Coin
forall era.
PParams era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> [DCert era]
-> Coin
totalDeposits PParams era
pp Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
stakePools (StrictSeq (DCert era) -> [DCert era]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (DCert era) -> [DCert era])
-> StrictSeq (DCert era) -> [DCert era]
forall a b. (a -> b) -> a -> b
$ TxBody era -> StrictSeq (DCert era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"certs" TxBody era
tx)
       )

-- | Compute the key deregistration refunds in a transaction
keyRefunds ::
  ( HasField "certs" (Core.TxBody era) (StrictSeq (DCert era))
  ) =>
  PParams era ->
  Core.TxBody era ->
  Coin
keyRefunds :: PParams era -> TxBody era -> Coin
keyRefunds PParams era
pp TxBody era
tx = ([DCert era] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DCert era]
deregistrations) Int -> Coin -> Coin
forall t i. (Val t, Integral i) => i -> t -> t
<×> (PParams era -> HKD Identity Coin
forall (f :: * -> *) era. PParams' f era -> HKD f Coin
_keyDeposit PParams era
pp)
  where
    deregistrations :: [DCert era]
deregistrations = (DCert era -> Bool) -> [DCert era] -> [DCert era]
forall a. (a -> Bool) -> [a] -> [a]
filter DCert era -> Bool
forall era. DCert era -> Bool
isDeRegKey (StrictSeq (DCert era) -> [DCert era]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (DCert era) -> [DCert era])
-> StrictSeq (DCert era) -> [DCert era]
forall a b. (a -> b) -> a -> b
$ TxBody era -> StrictSeq (DCert era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"certs" TxBody era
tx)

-- | Compute the lovelace which are destroyed by the transaction
-- TODO this is only correct for Shelley!
consumed ::
  ( ShelleyBased era,
    HasField "certs" (Core.TxBody era) (StrictSeq (DCert era)),
    HasField "inputs" (Core.TxBody era) (Set (TxIn era)),
    HasField "wdrls" (Core.TxBody era) (Wdrl era)
  ) =>
  PParams era ->
  UTxO (era) ->
  Core.TxBody era ->
  Core.Value era
consumed :: PParams era -> UTxO era -> TxBody era -> Value era
consumed PParams era
pp UTxO era
u TxBody era
tx =
  UTxO era -> Value era
forall era. ShelleyBased era => UTxO era -> Value era
balance (Exp (Map (TxIn era) (TxOut era)) -> UTxO era
forall s t. Embed s t => Exp t -> s
eval (TxBody era -> Set (TxIn era)
forall era.
HasField "inputs" (TxBody era) (Set (TxIn era)) =>
TxBody era -> Set (TxIn era)
txins TxBody era
tx Set (TxIn era) -> UTxO era -> Exp (Map (TxIn era) (TxOut era))
forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
 UTxO era
u)) Value era -> Value era -> Value era
forall a. Semigroup a => a -> a -> a
<> (Coin -> Value era
forall t. Val t => Coin -> t
Val.inject (Coin -> Value era) -> Coin -> Value era
forall a b. (a -> b) -> a -> b
$ Coin
refunds Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
withdrawals)
  where
    -- balance (UTxO (Map.restrictKeys v (txins tx))) + refunds + withdrawals
    refunds :: Coin
refunds = PParams era -> TxBody era -> Coin
forall era.
HasField "certs" (TxBody era) (StrictSeq (DCert era)) =>
PParams era -> TxBody era -> Coin
keyRefunds PParams era
pp TxBody era
tx
    withdrawals :: Coin
withdrawals = Map (RewardAcnt era) Coin -> Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map (RewardAcnt era) Coin -> Coin)
-> (Wdrl era -> Map (RewardAcnt era) Coin) -> Wdrl era -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Wdrl era -> Map (RewardAcnt era) Coin
forall era. Wdrl era -> Map (RewardAcnt era) Coin
unWdrl (Wdrl era -> Coin) -> Wdrl era -> Coin
forall a b. (a -> b) -> a -> b
$ TxBody era -> Wdrl era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"wdrls" TxBody era
tx

newtype WitHashes era = WitHashes
  {WitHashes era -> Set (KeyHash 'Witness (Crypto era))
unWitHashes :: Set (KeyHash 'Witness (Crypto era))}
  deriving (WitHashes era -> WitHashes era -> Bool
(WitHashes era -> WitHashes era -> Bool)
-> (WitHashes era -> WitHashes era -> Bool) -> Eq (WitHashes era)
forall era. WitHashes era -> WitHashes era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WitHashes era -> WitHashes era -> Bool
$c/= :: forall era. WitHashes era -> WitHashes era -> Bool
== :: WitHashes era -> WitHashes era -> Bool
$c== :: forall era. WitHashes era -> WitHashes era -> Bool
Eq, (forall x. WitHashes era -> Rep (WitHashes era) x)
-> (forall x. Rep (WitHashes era) x -> WitHashes era)
-> Generic (WitHashes era)
forall x. Rep (WitHashes era) x -> WitHashes era
forall x. WitHashes era -> Rep (WitHashes era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (WitHashes era) x -> WitHashes era
forall era x. WitHashes era -> Rep (WitHashes era) x
$cto :: forall era x. Rep (WitHashes era) x -> WitHashes era
$cfrom :: forall era x. WitHashes era -> Rep (WitHashes era) x
Generic)
  deriving (Int -> WitHashes era -> ShowS
[WitHashes era] -> ShowS
WitHashes era -> String
(Int -> WitHashes era -> ShowS)
-> (WitHashes era -> String)
-> ([WitHashes era] -> ShowS)
-> Show (WitHashes era)
forall era. Int -> WitHashes era -> ShowS
forall era. [WitHashes era] -> ShowS
forall era. WitHashes era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WitHashes era] -> ShowS
$cshowList :: forall era. [WitHashes era] -> ShowS
show :: WitHashes era -> String
$cshow :: forall era. WitHashes era -> String
showsPrec :: Int -> WitHashes era -> ShowS
$cshowsPrec :: forall era. Int -> WitHashes era -> ShowS
Show) via Quiet (WitHashes era)

instance Era era => NoThunks (WitHashes era)

-- | Check if a set of witness hashes is empty.
nullWitHashes :: WitHashes era -> Bool
nullWitHashes :: WitHashes era -> Bool
nullWitHashes (WitHashes Set (KeyHash 'Witness (Crypto era))
a) = Set (KeyHash 'Witness (Crypto era)) -> Bool
forall a. Set a -> Bool
Set.null Set (KeyHash 'Witness (Crypto era))
a

-- | Extract the difference between two sets of witness hashes.
diffWitHashes :: WitHashes era -> WitHashes era -> WitHashes era
diffWitHashes :: WitHashes era -> WitHashes era -> WitHashes era
diffWitHashes (WitHashes Set (KeyHash 'Witness (Crypto era))
x) (WitHashes Set (KeyHash 'Witness (Crypto era))
x') =
  Set (KeyHash 'Witness (Crypto era)) -> WitHashes era
forall era. Set (KeyHash 'Witness (Crypto era)) -> WitHashes era
WitHashes (Set (KeyHash 'Witness (Crypto era))
x Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.difference` Set (KeyHash 'Witness (Crypto era))
x')

-- | Extract the witness hashes from the Witness set.
witsFromWitnessSet ::
  (Era era, Core.AnnotatedData (Core.Script era)) =>
  WitnessSet era ->
  WitHashes era
witsFromWitnessSet :: WitnessSet era -> WitHashes era
witsFromWitnessSet (WitnessSet Set (WitVKey 'Witness era)
aWits Map (ScriptHash era) (Script era)
_ Set (BootstrapWitness era)
bsWits) =
  Set (KeyHash 'Witness (Crypto era)) -> WitHashes era
forall era. Set (KeyHash 'Witness (Crypto era)) -> WitHashes era
WitHashes (Set (KeyHash 'Witness (Crypto era)) -> WitHashes era)
-> Set (KeyHash 'Witness (Crypto era)) -> WitHashes era
forall a b. (a -> b) -> a -> b
$
    (WitVKey 'Witness era -> KeyHash 'Witness (Crypto era))
-> Set (WitVKey 'Witness era)
-> Set (KeyHash 'Witness (Crypto era))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map WitVKey 'Witness era -> KeyHash 'Witness (Crypto era)
forall (kr :: KeyRole) era.
WitVKey kr era -> KeyHash 'Witness (Crypto era)
witKeyHash Set (WitVKey 'Witness era)
aWits
      Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` (BootstrapWitness era -> KeyHash 'Witness (Crypto era))
-> Set (BootstrapWitness era)
-> Set (KeyHash 'Witness (Crypto era))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map BootstrapWitness era -> KeyHash 'Witness (Crypto era)
forall era.
Era era =>
BootstrapWitness era -> KeyHash 'Witness (Crypto era)
bootstrapWitKeyHash Set (BootstrapWitness era)
bsWits

-- | Collect the set of hashes of keys that needs to sign a
--  given transaction. This set consists of the txin owners,
--  certificate authors, and withdrawal reward accounts.
witsVKeyNeeded ::
  forall era.
  ( ShelleyBased era,
    HasField "wdrls" (Core.TxBody era) (Wdrl era),
    HasField "certs" (Core.TxBody era) (StrictSeq (DCert era)),
    HasField "inputs" (Core.TxBody era) (Set (TxIn era)),
    HasField "update" (Core.TxBody era) (StrictMaybe (Update era))
  ) =>
  UTxO era ->
  Tx era ->
  GenDelegs (Crypto era) ->
  WitHashes era
witsVKeyNeeded :: UTxO era -> Tx era -> GenDelegs (Crypto era) -> WitHashes era
witsVKeyNeeded UTxO era
utxo' tx :: Tx era
tx@(Tx TxBody era
txbody WitnessSet era
_ StrictMaybe MetaData
_) GenDelegs (Crypto era)
genDelegs =
  Set (KeyHash 'Witness (Crypto era)) -> WitHashes era
forall era. Set (KeyHash 'Witness (Crypto era)) -> WitHashes era
WitHashes (Set (KeyHash 'Witness (Crypto era)) -> WitHashes era)
-> Set (KeyHash 'Witness (Crypto era)) -> WitHashes era
forall a b. (a -> b) -> a -> b
$
    Set (KeyHash 'Witness (Crypto era))
certAuthors
      Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (KeyHash 'Witness (Crypto era))
inputAuthors
      Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (KeyHash 'Witness (Crypto era))
owners
      Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (KeyHash 'Witness (Crypto era))
wdrlAuthors
      Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set (KeyHash 'Witness (Crypto era))
updateKeys
  where
    inputAuthors :: Set (KeyHash 'Witness (Crypto era))
    inputAuthors :: Set (KeyHash 'Witness (Crypto era))
inputAuthors = (TxIn era
 -> Set (KeyHash 'Witness (Crypto era))
 -> Set (KeyHash 'Witness (Crypto era)))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (TxIn era)
-> Set (KeyHash 'Witness (Crypto era))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TxIn era
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
accum Set (KeyHash 'Witness (Crypto era))
forall a. Set a
Set.empty (TxBody era -> Set (TxIn era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"inputs" TxBody era
txbody)
      where
        accum :: TxIn era
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
accum TxIn era
txin Set (KeyHash 'Witness (Crypto era))
ans =
          case TxIn era -> UTxO era -> Maybe (TxOut era)
forall era. TxIn era -> UTxO era -> Maybe (TxOut era)
txinLookup TxIn era
txin UTxO era
utxo' of
            Just (TxOut (Addr Network
_ (KeyHashObj KeyHash 'Payment (Crypto era)
pay) StakeReference era
_) Value era
_) ->
              KeyHash 'Witness (Crypto era)
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => a -> Set a -> Set a
Set.insert (KeyHash 'Payment (Crypto era) -> KeyHash 'Witness (Crypto era)
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto.
HasKeyRole a =>
a r crypto -> a 'Witness crypto
asWitness KeyHash 'Payment (Crypto era)
pay) Set (KeyHash 'Witness (Crypto era))
ans
            Just (TxOut (AddrBootstrap BootstrapAddress era
bootAddr) Value era
_) ->
              KeyHash 'Witness (Crypto era)
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => a -> Set a -> Set a
Set.insert (KeyHash 'Payment (Crypto era) -> KeyHash 'Witness (Crypto era)
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto.
HasKeyRole a =>
a r crypto -> a 'Witness crypto
asWitness (BootstrapAddress era -> KeyHash 'Payment (Crypto era)
forall era.
Era era =>
BootstrapAddress era -> KeyHash 'Payment (Crypto era)
bootstrapKeyHash BootstrapAddress era
bootAddr)) Set (KeyHash 'Witness (Crypto era))
ans
            Maybe (TxOut era)
_other -> Set (KeyHash 'Witness (Crypto era))
ans
    wdrlAuthors :: Set (KeyHash 'Witness (Crypto era))
    wdrlAuthors :: Set (KeyHash 'Witness (Crypto era))
wdrlAuthors = (RewardAcnt era
 -> Coin
 -> Set (KeyHash 'Witness (Crypto era))
 -> Set (KeyHash 'Witness (Crypto era)))
-> Set (KeyHash 'Witness (Crypto era))
-> Map (RewardAcnt era) Coin
-> Set (KeyHash 'Witness (Crypto era))
forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
Map.foldrWithKey RewardAcnt era
-> Coin
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall era p.
RewardAcnt era
-> p
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
accum Set (KeyHash 'Witness (Crypto era))
forall a. Set a
Set.empty (Wdrl era -> Map (RewardAcnt era) Coin
forall era. Wdrl era -> Map (RewardAcnt era) Coin
unWdrl (TxBody era -> Wdrl era
forall k (x :: k) r a. HasField x r a => r -> a
getField @"wdrls" TxBody era
txbody))
      where
        accum :: RewardAcnt era
-> p
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
accum RewardAcnt era
key p
_ Set (KeyHash 'Witness (Crypto era))
ans = Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([Credential 'Staking era] -> Set (KeyHash 'Witness (Crypto era))
forall (r :: KeyRole) era.
[Credential r era] -> Set (KeyHash 'Witness (Crypto era))
extractKeyHashWitnessSet [RewardAcnt era -> Credential 'Staking era
forall era. RewardAcnt era -> Credential 'Staking era
getRwdCred RewardAcnt era
key]) Set (KeyHash 'Witness (Crypto era))
ans
    owners :: Set (KeyHash 'Witness (Crypto era))
    owners :: Set (KeyHash 'Witness (Crypto era))
owners = (DCert era
 -> Set (KeyHash 'Witness (Crypto era))
 -> Set (KeyHash 'Witness (Crypto era)))
-> Set (KeyHash 'Witness (Crypto era))
-> StrictSeq (DCert era)
-> Set (KeyHash 'Witness (Crypto era))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DCert era
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall era.
DCert era
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
accum Set (KeyHash 'Witness (Crypto era))
forall a. Set a
Set.empty (TxBody era -> StrictSeq (DCert era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"certs" TxBody era
txbody)
      where
        accum :: DCert era
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
accum (DCertPool (RegPool PoolParams era
pool)) Set (KeyHash 'Witness (Crypto era))
ans =
          Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
Set.union
            ((KeyHash 'Staking (Crypto era) -> KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Staking (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map KeyHash 'Staking (Crypto era) -> KeyHash 'Witness (Crypto era)
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto.
HasKeyRole a =>
a r crypto -> a 'Witness crypto
asWitness (PoolParams era -> Set (KeyHash 'Staking (Crypto era))
forall era. PoolParams era -> Set (KeyHash 'Staking (Crypto era))
_poolOwners PoolParams era
pool))
            Set (KeyHash 'Witness (Crypto era))
ans
        accum DCert era
_cert Set (KeyHash 'Witness (Crypto era))
ans = Set (KeyHash 'Witness (Crypto era))
ans
    cwitness :: DCert era -> Set (KeyHash 'Witness (Crypto era))
cwitness (DCertDeleg DelegCert era
dc) = [Credential 'Staking era] -> Set (KeyHash 'Witness (Crypto era))
forall (r :: KeyRole) era.
[Credential r era] -> Set (KeyHash 'Witness (Crypto era))
extractKeyHashWitnessSet [DelegCert era -> Credential 'Staking era
forall era. DelegCert era -> Credential 'Staking era
delegCWitness DelegCert era
dc]
    cwitness (DCertPool PoolCert era
pc) = [Credential 'StakePool era] -> Set (KeyHash 'Witness (Crypto era))
forall (r :: KeyRole) era.
[Credential r era] -> Set (KeyHash 'Witness (Crypto era))
extractKeyHashWitnessSet [PoolCert era -> Credential 'StakePool era
forall era. PoolCert era -> Credential 'StakePool era
poolCWitness PoolCert era
pc]
    cwitness (DCertGenesis GenesisDelegCert era
gc) = KeyHash 'Witness (Crypto era)
-> Set (KeyHash 'Witness (Crypto era))
forall a. a -> Set a
Set.singleton (KeyHash 'Genesis (Crypto era) -> KeyHash 'Witness (Crypto era)
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto.
HasKeyRole a =>
a r crypto -> a 'Witness crypto
asWitness (KeyHash 'Genesis (Crypto era) -> KeyHash 'Witness (Crypto era))
-> KeyHash 'Genesis (Crypto era) -> KeyHash 'Witness (Crypto era)
forall a b. (a -> b) -> a -> b
$ GenesisDelegCert era -> KeyHash 'Genesis (Crypto era)
forall era. GenesisDelegCert era -> KeyHash 'Genesis (Crypto era)
genesisCWitness GenesisDelegCert era
gc)
    cwitness DCert era
c = String -> Set (KeyHash 'Witness (Crypto era))
forall a. HasCallStack => String -> a
error (String -> Set (KeyHash 'Witness (Crypto era)))
-> String -> Set (KeyHash 'Witness (Crypto era))
forall a b. (a -> b) -> a -> b
$ DCert era -> String
forall a. Show a => a -> String
show DCert era
c String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" does not have a witness"
    -- key reg requires no witness but this is already filtered outby requiresVKeyWitness
    -- before the call to `cwitness`, so this error should never be reached.

    certAuthors :: Set (KeyHash 'Witness (Crypto era))
    certAuthors :: Set (KeyHash 'Witness (Crypto era))
certAuthors = (DCert era
 -> Set (KeyHash 'Witness (Crypto era))
 -> Set (KeyHash 'Witness (Crypto era)))
-> Set (KeyHash 'Witness (Crypto era))
-> StrictSeq (DCert era)
-> Set (KeyHash 'Witness (Crypto era))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr DCert era
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall era.
DCert era
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
accum Set (KeyHash 'Witness (Crypto era))
forall a. Set a
Set.empty (TxBody era -> StrictSeq (DCert era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"certs" TxBody era
txbody)
      where
        accum :: DCert era
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
accum DCert era
cert Set (KeyHash 'Witness (Crypto era))
ans | DCert era -> Bool
forall era. DCert era -> Bool
requiresVKeyWitness DCert era
cert = Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall a. Ord a => Set a -> Set a -> Set a
Set.union (DCert era -> Set (KeyHash 'Witness (Crypto era))
forall era. DCert era -> Set (KeyHash 'Witness (Crypto era))
cwitness DCert era
cert) Set (KeyHash 'Witness (Crypto era))
ans
        accum DCert era
_cert Set (KeyHash 'Witness (Crypto era))
ans = Set (KeyHash 'Witness (Crypto era))
ans
    updateKeys :: Set (KeyHash 'Witness (Crypto era))
    updateKeys :: Set (KeyHash 'Witness (Crypto era))
updateKeys = KeyHash 'Witness (Crypto era) -> KeyHash 'Witness (Crypto era)
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto.
HasKeyRole a =>
a r crypto -> a 'Witness crypto
asWitness (KeyHash 'Witness (Crypto era) -> KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall b a. Ord b => (a -> b) -> Set a -> Set b
`Set.map` Maybe (Update era)
-> GenDelegs (Crypto era) -> Set (KeyHash 'Witness (Crypto era))
forall era.
Maybe (Update era)
-> GenDelegs (Crypto era) -> Set (KeyHash 'Witness (Crypto era))
propWits (Tx era -> Maybe (Update era)
forall era.
(ShelleyBased era,
 HasField "update" (TxBody era) (StrictMaybe (Update era))) =>
Tx era -> Maybe (Update era)
txup Tx era
tx) GenDelegs (Crypto era)
genDelegs

-- | Given a ledger state, determine if the UTxO witnesses in a given
--  transaction are correct.
verifiedWits ::
  ( Shelley.TxBodyConstraints era,
    Core.AnnotatedData (Core.Script era),
    DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody)
  ) =>
  Tx era ->
  Either [VKey 'Witness (Crypto era)] ()
verifiedWits :: Tx era -> Either [VKey 'Witness (Crypto era)] ()
verifiedWits (Tx TxBody era
txbody WitnessSet era
wits StrictMaybe MetaData
_) =
  case ([VKey 'Witness (Crypto era)]
failed [VKey 'Witness (Crypto era)]
-> [VKey 'Witness (Crypto era)] -> [VKey 'Witness (Crypto era)]
forall a. Semigroup a => a -> a -> a
<> [VKey 'Witness (Crypto era)]
failedBootstrap) of
    [] -> () -> Either [VKey 'Witness (Crypto era)] ()
forall a b. b -> Either a b
Right ()
    [VKey 'Witness (Crypto era)]
nonEmpty -> [VKey 'Witness (Crypto era)]
-> Either [VKey 'Witness (Crypto era)] ()
forall a b. a -> Either a b
Left [VKey 'Witness (Crypto era)]
nonEmpty
  where
    wvkKey :: WitVKey kr era -> VKey kr (Crypto era)
wvkKey (WitVKey VKey kr (Crypto era)
k SignedDSIGN (Crypto era) (Hash (Crypto era) EraIndependentTxBody)
_) = VKey kr (Crypto era)
k
    failed :: [VKey 'Witness (Crypto era)]
failed =
      WitVKey 'Witness era -> VKey 'Witness (Crypto era)
forall era (kr :: KeyRole).
(Era era, Typeable kr) =>
WitVKey kr era -> VKey kr (Crypto era)
wvkKey
        (WitVKey 'Witness era -> VKey 'Witness (Crypto era))
-> [WitVKey 'Witness era] -> [VKey 'Witness (Crypto era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (WitVKey 'Witness era -> Bool)
-> [WitVKey 'Witness era] -> [WitVKey 'Witness era]
forall a. (a -> Bool) -> [a] -> [a]
filter
          (Bool -> Bool
not (Bool -> Bool)
-> (WitVKey 'Witness era -> Bool) -> WitVKey 'Witness era -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash (Crypto era) EraIndependentTxBody
-> WitVKey 'Witness era -> Bool
forall (kr :: KeyRole) era.
(Typeable kr, Era era,
 DSignable (Crypto era) (Hash (Crypto era) EraIndependentTxBody)) =>
Hash (Crypto era) EraIndependentTxBody -> WitVKey kr era -> Bool
verifyWitVKey (Hash (HASH (Crypto era)) (HashIndex (TxBody era))
-> Hash (Crypto era) EraIndependentTxBody
coerce (Hash (HASH (Crypto era)) (HashIndex (TxBody era))
 -> Hash (Crypto era) EraIndependentTxBody)
-> (TxBody era
    -> Hash (HASH (Crypto era)) (HashIndex (TxBody era)))
-> TxBody era
-> Hash (Crypto era) EraIndependentTxBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody era -> Hash (HASH (Crypto era)) (HashIndex (TxBody era))
forall a e.
HashAnnotated a e =>
a -> Hash (HASH (Crypto e)) (HashIndex a)
hashAnnotated (TxBody era -> Hash (Crypto era) EraIndependentTxBody)
-> TxBody era -> Hash (Crypto era) EraIndependentTxBody
forall a b. (a -> b) -> a -> b
$ TxBody era
txbody))
          (Set (WitVKey 'Witness era) -> [WitVKey 'Witness era]
forall a. Set a -> [a]
Set.toList (Set (WitVKey 'Witness era) -> [WitVKey 'Witness era])
-> Set (WitVKey 'Witness era) -> [WitVKey 'Witness era]
forall a b. (a -> b) -> a -> b
$ WitnessSet era
-> (Era era, AnnotatedData (Script era)) =>
   Set (WitVKey 'Witness era)
forall era.
WitnessSet era
-> (Era era, AnnotatedData (Script era)) =>
   Set (WitVKey 'Witness era)
addrWits WitnessSet era
wits)
    failedBootstrap :: [VKey 'Witness (Crypto era)]
failedBootstrap =
      BootstrapWitness era -> VKey 'Witness (Crypto era)
forall era.
BootstrapWitness era -> Era era => VKey 'Witness (Crypto era)
bwKey
        (BootstrapWitness era -> VKey 'Witness (Crypto era))
-> [BootstrapWitness era] -> [VKey 'Witness (Crypto era)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (BootstrapWitness era -> Bool)
-> [BootstrapWitness era] -> [BootstrapWitness era]
forall a. (a -> Bool) -> [a] -> [a]
filter
          (Bool -> Bool
not (Bool -> Bool)
-> (BootstrapWitness era -> Bool) -> BootstrapWitness era -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash (Crypto era) EraIndependentTxBody
-> BootstrapWitness era -> Bool
forall era.
(Era era,
 Signable
   (DSIGN (Crypto era)) (Hash (Crypto era) EraIndependentTxBody)) =>
Hash (Crypto era) EraIndependentTxBody
-> BootstrapWitness era -> Bool
verifyBootstrapWit (Hash (HASH (Crypto era)) (HashIndex (TxBody era))
-> Hash (Crypto era) EraIndependentTxBody
coerce (Hash (HASH (Crypto era)) (HashIndex (TxBody era))
 -> Hash (Crypto era) EraIndependentTxBody)
-> (TxBody era
    -> Hash (HASH (Crypto era)) (HashIndex (TxBody era)))
-> TxBody era
-> Hash (Crypto era) EraIndependentTxBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxBody era -> Hash (HASH (Crypto era)) (HashIndex (TxBody era))
forall a e.
HashAnnotated a e =>
a -> Hash (HASH (Crypto e)) (HashIndex a)
hashAnnotated (TxBody era -> Hash (Crypto era) EraIndependentTxBody)
-> TxBody era -> Hash (Crypto era) EraIndependentTxBody
forall a b. (a -> b) -> a -> b
$ TxBody era
txbody))
          (Set (BootstrapWitness era) -> [BootstrapWitness era]
forall a. Set a -> [a]
Set.toList (Set (BootstrapWitness era) -> [BootstrapWitness era])
-> Set (BootstrapWitness era) -> [BootstrapWitness era]
forall a b. (a -> b) -> a -> b
$ WitnessSet era
-> (Era era, AnnotatedData (Script era)) =>
   Set (BootstrapWitness era)
forall era.
WitnessSet era
-> (Era era, AnnotatedData (Script era)) =>
   Set (BootstrapWitness era)
bootWits WitnessSet era
wits)

-- | Calculate the set of hash keys of the required witnesses for update
-- proposals.
propWits ::
  Maybe (Update era) ->
  GenDelegs (Crypto era) ->
  Set (KeyHash 'Witness (Crypto era))
propWits :: Maybe (Update era)
-> GenDelegs (Crypto era) -> Set (KeyHash 'Witness (Crypto era))
propWits Maybe (Update era)
Nothing GenDelegs (Crypto era)
_ = Set (KeyHash 'Witness (Crypto era))
forall a. Set a
Set.empty
propWits (Just (Update (ProposedPPUpdates Map (KeyHash 'Genesis (Crypto era)) (PParamsUpdate era)
pup) EpochNo
_)) (GenDelegs Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
genDelegs) =
  (KeyHash 'GenesisDelegate (Crypto era)
 -> KeyHash 'Witness (Crypto era))
-> Set (KeyHash 'GenesisDelegate (Crypto era))
-> Set (KeyHash 'Witness (Crypto era))
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map KeyHash 'GenesisDelegate (Crypto era)
-> KeyHash 'Witness (Crypto era)
forall (a :: KeyRole -> * -> *) (r :: KeyRole) crypto.
HasKeyRole a =>
a r crypto -> a 'Witness crypto
asWitness (Set (KeyHash 'GenesisDelegate (Crypto era))
 -> Set (KeyHash 'Witness (Crypto era)))
-> ([KeyHash 'GenesisDelegate (Crypto era)]
    -> Set (KeyHash 'GenesisDelegate (Crypto era)))
-> [KeyHash 'GenesisDelegate (Crypto era)]
-> Set (KeyHash 'Witness (Crypto era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KeyHash 'GenesisDelegate (Crypto era)]
-> Set (KeyHash 'GenesisDelegate (Crypto era))
forall a. Ord a => [a] -> Set a
Set.fromList ([KeyHash 'GenesisDelegate (Crypto era)]
 -> Set (KeyHash 'Witness (Crypto era)))
-> [KeyHash 'GenesisDelegate (Crypto era)]
-> Set (KeyHash 'Witness (Crypto era))
forall a b. (a -> b) -> a -> b
$ Map
  (KeyHash 'Genesis (Crypto era))
  (KeyHash 'GenesisDelegate (Crypto era))
-> [KeyHash 'GenesisDelegate (Crypto era)]
forall k a. Map k a -> [a]
Map.elems Map
  (KeyHash 'Genesis (Crypto era))
  (KeyHash 'GenesisDelegate (Crypto era))
updateKeys
  where
    updateKeys' :: Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
updateKeys' = Exp
  (Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era)))
-> Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
forall s t. Embed s t => Exp t -> s
eval (Map (KeyHash 'Genesis (Crypto era)) (PParamsUpdate era)
-> Set (KeyHash 'Genesis (Crypto era))
forall k a. Map k a -> Set k
Map.keysSet Map (KeyHash 'Genesis (Crypto era)) (PParamsUpdate era)
pup Set (KeyHash 'Genesis (Crypto era))
-> Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
-> Exp
     (Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era)))
forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
 Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
genDelegs)
    updateKeys :: Map
  (KeyHash 'Genesis (Crypto era))
  (KeyHash 'GenesisDelegate (Crypto era))
updateKeys = (GenDelegPair (Crypto era)
 -> KeyHash 'GenesisDelegate (Crypto era))
-> Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
-> Map
     (KeyHash 'Genesis (Crypto era))
     (KeyHash 'GenesisDelegate (Crypto era))
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map GenDelegPair (Crypto era) -> KeyHash 'GenesisDelegate (Crypto era)
forall crypto.
GenDelegPair crypto -> KeyHash 'GenesisDelegate crypto
genDelegKeyHash Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
updateKeys'

-- Functions for stake delegation model

-- | Calculate the change to the deposit pool for a given transaction.
depositPoolChange ::
  ( HasField "certs" (Core.TxBody era) (StrictSeq (DCert era))
  ) =>
  LedgerState era ->
  PParams era ->
  Core.TxBody era ->
  Coin
depositPoolChange :: LedgerState era -> PParams era -> TxBody era -> Coin
depositPoolChange LedgerState era
ls PParams era
pp TxBody era
tx = (Coin
currentPool Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> Coin
txDeposits) Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> Coin
txRefunds
  where
    -- Note that while (currentPool + txDeposits) >= txRefunds,
    -- it could be that txDeposits < txRefunds. We keep the parenthesis above
    -- to emphasize this point.

    currentPool :: Coin
currentPool = (UTxOState era -> Coin
forall era. UTxOState era -> Coin
_deposited (UTxOState era -> Coin)
-> (LedgerState era -> UTxOState era) -> LedgerState era -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
_utxoState) LedgerState era
ls
    txDeposits :: Coin
txDeposits =
      PParams era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> [DCert era]
-> Coin
forall era.
PParams era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> [DCert era]
-> Coin
totalDeposits PParams era
pp ((PState era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
forall era.
PState era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
_pParams (PState era
 -> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era))
-> (LedgerState era -> PState era)
-> LedgerState era
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DPState era -> PState era
forall era. DPState era -> PState era
_pstate (DPState era -> PState era)
-> (LedgerState era -> DPState era)
-> LedgerState era
-> PState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState era -> DPState era
forall era. LedgerState era -> DPState era
_delegationState) LedgerState era
ls) (StrictSeq (DCert era) -> [DCert era]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (StrictSeq (DCert era) -> [DCert era])
-> StrictSeq (DCert era) -> [DCert era]
forall a b. (a -> b) -> a -> b
$ TxBody era -> StrictSeq (DCert era)
forall k (x :: k) r a. HasField x r a => r -> a
getField @"certs" TxBody era
tx)
    txRefunds :: Coin
txRefunds = PParams era -> TxBody era -> Coin
forall era.
HasField "certs" (TxBody era) (StrictSeq (DCert era)) =>
PParams era -> TxBody era -> Coin
keyRefunds PParams era
pp TxBody era
tx

reapRewards ::
  RewardAccounts era ->
  RewardAccounts era ->
  RewardAccounts era
reapRewards :: RewardAccounts era -> RewardAccounts era -> RewardAccounts era
reapRewards RewardAccounts era
dStateRewards RewardAccounts era
withdrawals =
  (Credential 'Staking era -> Coin -> Coin)
-> RewardAccounts era -> RewardAccounts era
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Credential 'Staking era -> Coin -> Coin
removeRewards RewardAccounts era
dStateRewards
  where
    removeRewards :: Credential 'Staking era -> Coin -> Coin
removeRewards Credential 'Staking era
k Coin
v = if Credential 'Staking era
k Credential 'Staking era -> RewardAccounts era -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` RewardAccounts era
withdrawals then Integer -> Coin
Coin Integer
0 else Coin
v

---------------------------------
-- epoch boundary calculations --
---------------------------------

stakeDistr ::
  forall era.
  ShelleyBased era =>
  UTxO era ->
  DState era ->
  PState era ->
  SnapShot era
stakeDistr :: UTxO era -> DState era -> PState era -> SnapShot era
stakeDistr UTxO era
u DState era
ds PState era
ps =
  Stake era
-> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> SnapShot era
forall era.
Stake era
-> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> SnapShot era
SnapShot
    (Map (Credential 'Staking era) Coin -> Stake era
forall era. Map (Credential 'Staking era) Coin -> Stake era
Stake (Map (Credential 'Staking era) Coin -> Stake era)
-> Map (Credential 'Staking era) Coin -> Stake era
forall a b. (a -> b) -> a -> b
$ Exp (Map (Credential 'Staking era) Coin)
-> Map (Credential 'Staking era) Coin
forall s t. Embed s t => Exp t -> s
eval (Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
-> Exp (Sett (Credential 'Staking era) ())
forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
activeDelegs Exp (Sett (Credential 'Staking era) ())
-> Map (Credential 'Staking era) Coin
-> Exp (Map (Credential 'Staking era) Coin)
forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
 Map (Credential 'Staking era) Coin
stakeRelation))
    Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
delegs
    Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
poolParams
  where
    DState Map (Credential 'Staking era) Coin
rewards' Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
delegs Bimap Ptr (Credential 'Staking era)
ptrs' Map (FutureGenDeleg (Crypto era)) (GenDelegPair (Crypto era))
_ GenDelegs (Crypto era)
_ InstantaneousRewards era
_ = DState era
ds
    PState Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
poolParams Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
_ Map (KeyHash 'StakePool (Crypto era)) EpochNo
_ = PState era
ps
    stakeRelation :: Map (Credential 'Staking era) Coin
    stakeRelation :: Map (Credential 'Staking era) Coin
stakeRelation = Map Ptr (Credential 'Staking era)
-> UTxO era
-> Map (Credential 'Staking era) Coin
-> Map (Credential 'Staking era) Coin
forall era.
ShelleyBased era =>
Map Ptr (Credential 'Staking era)
-> UTxO era
-> Map (Credential 'Staking era) Coin
-> Map (Credential 'Staking era) Coin
aggregateUtxoCoinByCredential (Bimap Ptr (Credential 'Staking era)
-> Map Ptr (Credential 'Staking era)
forall v k. BiMap v k v -> Map k v
forwards Bimap Ptr (Credential 'Staking era)
ptrs') UTxO era
u Map (Credential 'Staking era) Coin
rewards'
    activeDelegs :: Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
    activeDelegs :: Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
activeDelegs = Exp
  (Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era)))
-> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
forall s t. Embed s t => Exp t -> s
eval ((Map (Credential 'Staking era) Coin
-> Exp (Sett (Credential 'Staking era) ())
forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom Map (Credential 'Staking era) Coin
rewards' Exp (Sett (Credential 'Staking era) ())
-> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
-> Exp
     (Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era)))
forall k s1 s2 (f :: * -> * -> *) v.
(Ord k, HasExp s1 (Sett k ()), HasExp s2 (f k v)) =>
s1 -> s2 -> Exp (f k v)
 Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
delegs) Exp
  (Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era)))
-> Exp (Sett (KeyHash 'StakePool (Crypto era)) ())
-> Exp
     (Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era)))
forall k (g :: * -> * -> *) v s1 (f :: * -> * -> *) s2.
(Ord k, Iter g, Ord v, HasExp s1 (f k v), HasExp s2 (g v ())) =>
s1 -> s2 -> Exp (f k v)
 Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> Exp (Sett (KeyHash 'StakePool (Crypto era)) ())
forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
poolParams)

-- | Apply a reward update
applyRUpd ::
  RewardUpdate era ->
  EpochState era ->
  EpochState era
applyRUpd :: RewardUpdate era -> EpochState era -> EpochState era
applyRUpd RewardUpdate era
ru (EpochState AccountState
as SnapShots era
ss LedgerState era
ls PParams era
pr PParams era
pp NonMyopic era
_nm) = AccountState
-> SnapShots era
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic era
-> EpochState era
forall era.
AccountState
-> SnapShots era
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic era
-> EpochState era
EpochState AccountState
as' SnapShots era
ss LedgerState era
ls' PParams era
pr PParams era
pp NonMyopic era
nm'
  where
    utxoState_ :: UTxOState era
utxoState_ = LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
_utxoState LedgerState era
ls
    delegState :: DPState era
delegState = LedgerState era -> DPState era
forall era. LedgerState era -> DPState era
_delegationState LedgerState era
ls
    dState :: DState era
dState = DPState era -> DState era
forall era. DPState era -> DState era
_dstate DPState era
delegState
    (Map (Credential 'Staking era) Coin
regRU, Map (Credential 'Staking era) Coin
unregRU) =
      (Credential 'Staking era -> Coin -> Bool)
-> Map (Credential 'Staking era) Coin
-> (Map (Credential 'Staking era) Coin,
    Map (Credential 'Staking era) Coin)
forall k a. (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partitionWithKey
        (\Credential 'Staking era
k Coin
_ -> Exp Bool -> Bool
forall s t. Embed s t => Exp t -> s
eval (Credential 'Staking era
k Credential 'Staking era
-> Exp (Sett (Credential 'Staking era) ()) -> Exp Bool
forall k (g :: * -> * -> *) s.
(Show k, Ord k, Iter g, HasExp s (g k ())) =>
k -> s -> Exp Bool
 Map (Credential 'Staking era) Coin
-> Exp (Sett (Credential 'Staking era) ())
forall k s (f :: * -> * -> *) v.
(Ord k, HasExp s (f k v)) =>
s -> Exp (Sett k ())
dom (DState era -> Map (Credential 'Staking era) Coin
forall era. DState era -> RewardAccounts era
_rewards DState era
dState)))
        (RewardUpdate era -> Map (Credential 'Staking era) Coin
forall era. RewardUpdate era -> Map (Credential 'Staking era) Coin
rs RewardUpdate era
ru)
    as' :: AccountState
as' =
      AccountState
as
        { _treasury :: Coin
_treasury = AccountState -> Coin
_treasury AccountState
as Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> RewardUpdate era -> Coin
forall era. RewardUpdate era -> Coin
deltaT RewardUpdate era
ru Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Set Coin -> Coin
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (Map (Credential 'Staking era) Coin -> Set Coin
forall (f :: * -> * -> *) v k. (Basic f, Ord v) => f k v -> Set v
range Map (Credential 'Staking era) Coin
unregRU),
          _reserves :: Coin
_reserves = Coin -> DeltaCoin -> Coin
addDeltaCoin (AccountState -> Coin
_reserves AccountState
as) (RewardUpdate era -> DeltaCoin
forall era. RewardUpdate era -> DeltaCoin
deltaR RewardUpdate era
ru)
        }
    ls' :: LedgerState era
ls' =
      LedgerState era
ls
        { _utxoState :: UTxOState era
_utxoState =
            UTxOState era
utxoState_ {_fees :: Coin
_fees = UTxOState era -> Coin
forall era. UTxOState era -> Coin
_fees UTxOState era
utxoState_ Coin -> DeltaCoin -> Coin
`addDeltaCoin` RewardUpdate era -> DeltaCoin
forall era. RewardUpdate era -> DeltaCoin
deltaF RewardUpdate era
ru},
          _delegationState :: DPState era
_delegationState =
            DPState era
delegState
              { _dstate :: DState era
_dstate =
                  DState era
dState
                    { _rewards :: Map (Credential 'Staking era) Coin
_rewards = Exp (Map (Credential 'Staking era) Coin)
-> Map (Credential 'Staking era) Coin
forall s t. Embed s t => Exp t -> s
eval (DState era -> Map (Credential 'Staking era) Coin
forall era. DState era -> RewardAccounts era
_rewards DState era
dState Map (Credential 'Staking era) Coin
-> Map (Credential 'Staking era) Coin
-> Exp (Map (Credential 'Staking era) Coin)
forall k n s1 (f :: * -> * -> *) s2.
(Ord k, Monoid n, HasExp s1 (f k n), HasExp s2 (f k n)) =>
s1 -> s2 -> Exp (f k n)
∪+ Map (Credential 'Staking era) Coin
regRU)
                    }
              }
        }
    nm' :: NonMyopic era
nm' = RewardUpdate era -> NonMyopic era
forall era. RewardUpdate era -> NonMyopic era
nonMyopic RewardUpdate era
ru

decayFactor :: Float
decayFactor :: Float
decayFactor = Float
0.9

updateNonMypopic ::
  NonMyopic era ->
  Coin ->
  Map (KeyHash 'StakePool (Crypto era)) Likelihood ->
  NonMyopic era
updateNonMypopic :: NonMyopic era
-> Coin
-> Map (KeyHash 'StakePool (Crypto era)) Likelihood
-> NonMyopic era
updateNonMypopic NonMyopic era
nm Coin
rPot Map (KeyHash 'StakePool (Crypto era)) Likelihood
newLikelihoods =
  NonMyopic era
nm
    { likelihoodsNM :: Map (KeyHash 'StakePool (Crypto era)) Likelihood
likelihoodsNM = Map (KeyHash 'StakePool (Crypto era)) Likelihood
updatedLikelihoods,
      rewardPotNM :: Coin
rewardPotNM = Coin
rPot
    }
  where
    history :: Map (KeyHash 'StakePool (Crypto era)) Likelihood
history = NonMyopic era -> Map (KeyHash 'StakePool (Crypto era)) Likelihood
forall era.
NonMyopic era -> Map (KeyHash 'StakePool (Crypto era)) Likelihood
likelihoodsNM NonMyopic era
nm
    performance :: KeyHash 'StakePool (Crypto era) -> Likelihood -> Likelihood
performance KeyHash 'StakePool (Crypto era)
kh Likelihood
newPerf =
      Likelihood -> Maybe Likelihood -> Likelihood
forall a. a -> Maybe a -> a
fromMaybe
        Likelihood
forall a. Monoid a => a
mempty
        (Float -> Likelihood -> Likelihood
applyDecay Float
decayFactor (Likelihood -> Likelihood) -> Maybe Likelihood -> Maybe Likelihood
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyHash 'StakePool (Crypto era)
-> Map (KeyHash 'StakePool (Crypto era)) Likelihood
-> Maybe Likelihood
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool (Crypto era)
kh Map (KeyHash 'StakePool (Crypto era)) Likelihood
history)
        Likelihood -> Likelihood -> Likelihood
forall a. Semigroup a => a -> a -> a
<> Likelihood
newPerf
    updatedLikelihoods :: Map (KeyHash 'StakePool (Crypto era)) Likelihood
updatedLikelihoods = (KeyHash 'StakePool (Crypto era) -> Likelihood -> Likelihood)
-> Map (KeyHash 'StakePool (Crypto era)) Likelihood
-> Map (KeyHash 'StakePool (Crypto era)) Likelihood
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey KeyHash 'StakePool (Crypto era) -> Likelihood -> Likelihood
performance Map (KeyHash 'StakePool (Crypto era)) Likelihood
newLikelihoods

-- | Create a reward update
createRUpd ::
  EpochSize ->
  BlocksMade era ->
  EpochState era ->
  Coin ->
  ShelleyBase (RewardUpdate era)
createRUpd :: EpochSize
-> BlocksMade era
-> EpochState era
-> Coin
-> ShelleyBase (RewardUpdate era)
createRUpd EpochSize
slotsPerEpoch b :: BlocksMade era
b@(BlocksMade Map (KeyHash 'StakePool (Crypto era)) Natural
b') es :: EpochState era
es@(EpochState AccountState
acnt SnapShots era
ss LedgerState era
ls PParams era
pr PParams era
_ NonMyopic era
nm) Coin
maxSupply = do
  ActiveSlotCoeff
asc <- (Globals -> ActiveSlotCoeff)
-> ReaderT Globals Identity ActiveSlotCoeff
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> ActiveSlotCoeff
activeSlotCoeff
  let SnapShot Stake era
stake' Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
delegs' Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
poolParams = SnapShots era -> SnapShot era
forall era. SnapShots era -> SnapShot era
_pstakeGo SnapShots era
ss
      Coin Integer
reserves = AccountState -> Coin
_reserves AccountState
acnt
      ds :: DState era
ds = DPState era -> DState era
forall era. DPState era -> DState era
_dstate (DPState era -> DState era) -> DPState era -> DState era
forall a b. (a -> b) -> a -> b
$ LedgerState era -> DPState era
forall era. LedgerState era -> DPState era
_delegationState LedgerState era
ls
      -- reserves and rewards change
      deltaR1 :: Coin
deltaR1 =
        ( Rational -> Coin
rationalToCoinViaFloor (Rational -> Coin) -> Rational -> Coin
forall a b. (a -> b) -> a -> b
$
            Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
min Rational
1 Rational
eta
              Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* UnitInterval -> Rational
unitIntervalToRational (PParams era -> HKD Identity UnitInterval
forall (f :: * -> *) era. PParams' f era -> HKD f UnitInterval
_rho PParams era
pr)
              Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
reserves
        )
      d :: Rational
d = UnitInterval -> Rational
unitIntervalToRational (PParams era -> HKD Identity UnitInterval
forall (f :: * -> *) era. PParams' f era -> HKD f UnitInterval
_d PParams era
pr)
      expectedBlocks :: Integer
expectedBlocks =
        Rational -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (Rational -> Integer) -> Rational -> Integer
forall a b. (a -> b) -> a -> b
$
          (Rational
1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
d) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* UnitInterval -> Rational
unitIntervalToRational (ActiveSlotCoeff -> UnitInterval
activeSlotVal ActiveSlotCoeff
asc) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* EpochSize -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral EpochSize
slotsPerEpoch
      -- TODO asc is a global constant, and slotsPerEpoch should not change often at all,
      -- it would be nice to not have to compute expectedBlocks every epoch
      eta :: Rational
eta
        | UnitInterval -> Ratio Word64
intervalValue (PParams era -> HKD Identity UnitInterval
forall (f :: * -> *) era. PParams' f era -> HKD f UnitInterval
_d PParams era
pr) Ratio Word64 -> Ratio Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Ratio Word64
0.8 = Rational
1
        | Bool
otherwise = Integer
blocksMade Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Integer
expectedBlocks
      Coin Integer
rPot = SnapShots era -> Coin
forall era. SnapShots era -> Coin
_feeSS SnapShots era
ss Coin -> Coin -> Coin
forall a. Semigroup a => a -> a -> a
<> Coin
deltaR1
      deltaT1 :: Integer
deltaT1 = Ratio Word64 -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
floor (Ratio Word64 -> Integer) -> Ratio Word64 -> Integer
forall a b. (a -> b) -> a -> b
$ UnitInterval -> Ratio Word64
intervalValue (PParams era -> HKD Identity UnitInterval
forall (f :: * -> *) era. PParams' f era -> HKD f UnitInterval
_tau PParams era
pr) Ratio Word64 -> Ratio Word64 -> Ratio Word64
forall a. Num a => a -> a -> a
* Integer -> Ratio Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
rPot
      _R :: Coin
_R = Integer -> Coin
Coin (Integer -> Coin) -> Integer -> Coin
forall a b. (a -> b) -> a -> b
$ Integer
rPot Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
deltaT1
      totalStake :: Coin
totalStake = EpochState era -> Coin -> Coin
forall era. EpochState era -> Coin -> Coin
circulation EpochState era
es Coin
maxSupply
      (Map (Credential 'Staking era) Coin
rs_, Map (KeyHash 'StakePool (Crypto era)) Likelihood
newLikelihoods) =
        PParams era
-> BlocksMade era
-> Coin
-> Set (Credential 'Staking era)
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> Stake era
-> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
-> Coin
-> ActiveSlotCoeff
-> EpochSize
-> (Map (Credential 'Staking era) Coin,
    Map (KeyHash 'StakePool (Crypto era)) Likelihood)
forall era.
PParams era
-> BlocksMade era
-> Coin
-> Set (Credential 'Staking era)
-> Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
-> Stake era
-> Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
-> Coin
-> ActiveSlotCoeff
-> EpochSize
-> (Map (Credential 'Staking era) Coin,
    Map (KeyHash 'StakePool (Crypto era)) Likelihood)
reward
          PParams era
pr
          BlocksMade era
b
          Coin
_R
          (Map (Credential 'Staking era) Coin -> Set (Credential 'Staking era)
forall k a. Map k a -> Set k
Map.keysSet (Map (Credential 'Staking era) Coin
 -> Set (Credential 'Staking era))
-> Map (Credential 'Staking era) Coin
-> Set (Credential 'Staking era)
forall a b. (a -> b) -> a -> b
$ DState era -> Map (Credential 'Staking era) Coin
forall era. DState era -> RewardAccounts era
_rewards DState era
ds)
          Map (KeyHash 'StakePool (Crypto era)) (PoolParams era)
poolParams
          Stake era
stake'
          Map (Credential 'Staking era) (KeyHash 'StakePool (Crypto era))
delegs'
          Coin
totalStake
          ActiveSlotCoeff
asc
          EpochSize
slotsPerEpoch
      deltaR2 :: Coin
deltaR2 = Coin
_R Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> ((Coin -> Coin -> Coin)
-> Coin -> Map (Credential 'Staking era) Coin -> Coin
forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
(<+>) Coin
forall a. Monoid a => a
mempty Map (Credential 'Staking era) Coin
rs_)
      blocksMade :: Integer
blocksMade = Natural -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Natural -> Integer) -> Natural -> Integer
forall a b. (a -> b) -> a -> b
$ (Natural -> Natural -> Natural)
-> Natural
-> Map (KeyHash 'StakePool (Crypto era)) Natural
-> Natural
forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
(+) Natural
0 Map (KeyHash 'StakePool (Crypto era)) Natural
b' :: Integer
  RewardUpdate era -> ShelleyBase (RewardUpdate era)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RewardUpdate era -> ShelleyBase (RewardUpdate era))
-> RewardUpdate era -> ShelleyBase (RewardUpdate era)
forall a b. (a -> b) -> a -> b
$
    RewardUpdate :: forall era.
Coin
-> DeltaCoin
-> Map (Credential 'Staking era) Coin
-> DeltaCoin
-> NonMyopic era
-> RewardUpdate era
RewardUpdate
      { deltaT :: Coin
deltaT = (Integer -> Coin
Coin Integer
deltaT1),
        deltaR :: DeltaCoin
deltaR = ((DeltaCoin -> DeltaCoin
forall m. Group m => m -> m
invert (DeltaCoin -> DeltaCoin) -> DeltaCoin -> DeltaCoin
forall a b. (a -> b) -> a -> b
$ Coin -> DeltaCoin
toDeltaCoin Coin
deltaR1) DeltaCoin -> DeltaCoin -> DeltaCoin
forall a. Semigroup a => a -> a -> a
<> Coin -> DeltaCoin
toDeltaCoin Coin
deltaR2),
        rs :: Map (Credential 'Staking era) Coin
rs = Map (Credential 'Staking era) Coin
rs_,
        deltaF :: DeltaCoin
deltaF = (DeltaCoin -> DeltaCoin
forall m. Group m => m -> m
invert (Coin -> DeltaCoin
toDeltaCoin (Coin -> DeltaCoin) -> Coin -> DeltaCoin
forall a b. (a -> b) -> a -> b
$ SnapShots era -> Coin
forall era. SnapShots era -> Coin
_feeSS SnapShots era
ss)),
        nonMyopic :: NonMyopic era
nonMyopic = (NonMyopic era
-> Coin
-> Map (KeyHash 'StakePool (Crypto era)) Likelihood
-> NonMyopic era
forall era.
NonMyopic era
-> Coin
-> Map (KeyHash 'StakePool (Crypto era)) Likelihood
-> NonMyopic era
updateNonMypopic NonMyopic era
nm Coin
_R Map (KeyHash 'StakePool (Crypto era)) Likelihood
newLikelihoods)
      }

-- | Calculate the current circulation
--
-- This is used in the rewards calculation, and for API endpoints for pool ranking.
circulation :: EpochState era -> Coin -> Coin
circulation :: EpochState era -> Coin -> Coin
circulation (EpochState AccountState
acnt SnapShots era
_ LedgerState era
_ PParams era
_ PParams era
_ NonMyopic era
_) Coin
supply =
  Coin
supply Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> (AccountState -> Coin
_reserves AccountState
acnt)

-- | Update new epoch state
updateNES ::
  NewEpochState era ->
  BlocksMade era ->
  LedgerState era ->
  NewEpochState era
updateNES :: NewEpochState era
-> BlocksMade era -> LedgerState era -> NewEpochState era
updateNES
  ( NewEpochState
      EpochNo
eL
      BlocksMade era
bprev
      BlocksMade era
_
      (EpochState AccountState
acnt SnapShots era
ss LedgerState era
_ PParams era
pr PParams era
pp NonMyopic era
nm)
      StrictMaybe (RewardUpdate era)
ru
      PoolDistr (Crypto era)
pd
    )
  BlocksMade era
bcur
  LedgerState era
ls =
    EpochNo
-> BlocksMade era
-> BlocksMade era
-> EpochState era
-> StrictMaybe (RewardUpdate era)
-> PoolDistr (Crypto era)
-> NewEpochState era
forall era.
EpochNo
-> BlocksMade era
-> BlocksMade era
-> EpochState era
-> StrictMaybe (RewardUpdate era)
-> PoolDistr (Crypto era)
-> NewEpochState era
NewEpochState EpochNo
eL BlocksMade era
bprev BlocksMade era
bcur (AccountState
-> SnapShots era
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic era
-> EpochState era
forall era.
AccountState
-> SnapShots era
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic era
-> EpochState era
EpochState AccountState
acnt SnapShots era
ss LedgerState era
ls PParams era
pr PParams era
pp NonMyopic era
nm) StrictMaybe (RewardUpdate era)
ru PoolDistr (Crypto era)
pd

returnRedeemAddrsToReserves ::
  ShelleyBased era =>
  EpochState era ->
  EpochState era
returnRedeemAddrsToReserves :: EpochState era -> EpochState era
returnRedeemAddrsToReserves EpochState era
es = EpochState era
es {esAccountState :: AccountState
esAccountState = AccountState
acnt', esLState :: LedgerState era
esLState = LedgerState era
ls'}
  where
    ls :: LedgerState era
ls = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
es
    us :: UTxOState era
us = LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
_utxoState LedgerState era
ls
    UTxO Map (TxIn era) (TxOut era)
utxo = UTxOState era -> UTxO era
forall era. UTxOState era -> UTxO era
_utxo UTxOState era
us
    (Map (TxIn era) (TxOut era)
redeemers, Map (TxIn era) (TxOut era)
nonredeemers) = (TxOut era -> Bool)
-> Map (TxIn era) (TxOut era)
-> (Map (TxIn era) (TxOut era), Map (TxIn era) (TxOut era))
forall a k. (a -> Bool) -> Map k a -> (Map k a, Map k a)
Map.partition (\(TxOut Addr era
a Value era
_) -> Addr era -> Bool
forall era. Addr era -> Bool
isBootstrapRedeemer Addr era
a) Map (TxIn era) (TxOut era)
utxo
    acnt :: AccountState
acnt = EpochState era -> AccountState
forall era. EpochState era -> AccountState
esAccountState EpochState era
es
    acnt' :: AccountState
acnt' = AccountState
acnt {_reserves :: Coin
_reserves = (AccountState -> Coin
_reserves AccountState
acnt) Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<+> (Value era -> Coin
forall t. Val t => t -> Coin
Val.coin (Value era -> Coin) -> (UTxO era -> Value era) -> UTxO era -> Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTxO era -> Value era
forall era. ShelleyBased era => UTxO era -> Value era
balance (UTxO era -> Coin) -> UTxO era -> Coin
forall a b. (a -> b) -> a -> b
$ Map (TxIn era) (TxOut era) -> UTxO era
forall era. Map (TxIn era) (TxOut era) -> UTxO era
UTxO Map (TxIn era) (TxOut era)
redeemers)}
    us' :: UTxOState era
us' = UTxOState era
us {_utxo :: UTxO era
_utxo = Map (TxIn era) (TxOut era) -> UTxO era
forall era. Map (TxIn era) (TxOut era) -> UTxO era
UTxO Map (TxIn era) (TxOut era)
nonredeemers}
    ls' :: LedgerState era
ls' = LedgerState era
ls {_utxoState :: UTxOState era
_utxoState = UTxOState era
us'}