{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

-- | The data types in this file constitute a Model of the NewEpochState
--   sufficient for generating transactions that can run in the
--   MockChain STS instance. This is a model so we drop some details of the
--   real NewEpochState, and add some additional details specific to Tx generation.
--   Dropped details include
--   1) Efficiency concerns
--      a) Pulsing Reward updates
--      b) Inverse of the Rewards Map
--      c) esNonMyopic field
--      d) _stakeDistro, Incremental Stake distribution
--   2) Transaction features that make changes to the Protocol Parameters
--   3) Using Hashes of the TxBody as the Ix, instead we maintain an index of
--      an arbitrary Hash to the sequence (Count) in which the TxBody was generated.
--   Additional details
--   1) Utxo entries to pay fees. It is incredibly hard to generate Txs with the
--      correct fees. So we keep a small set of UtxoEntrys, where it is allowed to
--      mutate the value field of the TxOut. We have to be sure these entries are carefully
--      managed, as they do not follow the rules of the real world.
--   Additional comments
--   1) We include data in the Model for Epoch boundary computations, but we do not
--      do anything with them at this time.
module Test.Cardano.Ledger.Generic.ModelState where

import Cardano.Ledger.BaseTypes (BlocksMade (..))
import Cardano.Ledger.Coin (Coin (..), CompactForm (CompactCoin))
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.EpochBoundary (SnapShots, emptySnapShots)
import Cardano.Ledger.Hashes (GenDelegs (..))
import Cardano.Ledger.PoolDistr (IndividualPoolStake (..), PoolDistr (..))
import Cardano.Ledger.PoolParams (PoolParams (..))
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.LedgerState (
  AccountState (..),
  CertState (..),
  DState (..),
  EpochState (..),
  IncrementalStake (..),
  InstantaneousRewards (..),
  LedgerState (..),
  NewEpochState (..),
  PState (..),
  StashedAVVMAddresses,
  UTxOState (..),
  VState (..),
  completeRupd,
  curPParamsEpochStateL,
  prevPParamsEpochStateL,
  smartUTxOState,
 )
import Cardano.Ledger.Shelley.PoolRank (NonMyopic (..))
import Cardano.Ledger.Shelley.RewardUpdate (PulsingRewUpdate (..), RewardUpdate (..))
import Cardano.Ledger.Slot (EpochNo (..))
import Cardano.Ledger.TxIn (TxId (..), TxIn (..))
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.UTxO (UTxO (..))
import Control.Monad.Trans ()
import Data.Default (Default (def))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.Maybe as Maybe
import Data.Maybe.Strict (StrictMaybe (..))
import Data.Text (Text)
import GHC.Natural (Natural)
import Lens.Micro ((&), (.~))
import Lens.Micro.Extras (view)
import Test.Cardano.Ledger.Generic.PrettyCore (
  PDoc,
  PrettyA (..),
  credSummary,
  keyHashSummary,
  pcAccountState,
  pcCoin,
  pcCredential,
  pcIndividualPoolStake,
  pcKeyHash,
  pcPoolParams,
  pcTxId,
  pcTxIn,
  pcTxOut,
  ppEpochNo,
  ppInt,
  ppMap,
  ppNatural,
  ppRecord,
  ppString,
 )
import Test.Cardano.Ledger.Generic.Proof (
  BabbageEra,
  Proof (..),
  Reflect (..),
 )
import Test.Cardano.Ledger.Shelley.Utils (runShelleyBase)

-- =============================================

-- | MUtxo = Model UTxO. In the Model we represent the
--   UTxO as a Map (not a newtype around a Map)
type MUtxo era = Map TxIn (TxOut era)

pcMUtxo :: Reflect era => Proof era -> MUtxo era -> PDoc
pcMUtxo :: forall era. Reflect era => Proof era -> MUtxo era -> PDoc
pcMUtxo Proof era
proof MUtxo era
m = forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap TxIn -> PDoc
pcTxIn (forall era. Reflect era => Proof era -> TxOut era -> PDoc
pcTxOut Proof era
proof) MUtxo era
m

-- ===========================================================

data ModelNewEpochState era = ModelNewEpochState
  { -- PState fields
    forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams
mPoolParams :: !(Map (KeyHash 'StakePool) PoolParams)
  , forall era. ModelNewEpochState era -> Map (KeyHash 'StakePool) Coin
mPoolDeposits :: !(Map (KeyHash 'StakePool) Coin)
  , -- DState state fields
    forall era.
ModelNewEpochState era -> Map (Credential 'Staking) Coin
mRewards :: !(Map (Credential 'Staking) Coin)
  , forall era.
ModelNewEpochState era
-> Map (Credential 'Staking) (KeyHash 'StakePool)
mDelegations :: !(Map (Credential 'Staking) (KeyHash 'StakePool))
  , forall era.
ModelNewEpochState era -> Map (Credential 'Staking) Coin
mKeyDeposits :: !(Map (Credential 'Staking) Coin)
  , --  _fGenDelegs,  _genDelegs, and _irwd, are for
    --  changing the PParams and are abstracted away

    -- UTxO state fields (and extra stuff)
    forall era. ModelNewEpochState era -> Map TxIn (TxOut era)
mUTxO :: !(Map TxIn (TxOut era))
  , forall era. ModelNewEpochState era -> Map TxIn (TxOut era)
mMutFee :: !(Map TxIn (TxOut era))
  -- ^ The current UTxO
  , -- _ppups is for changing PParams, and _stakeDistro is for efficiency
    -- and are abstracted away.

    -- EpochState fields
    forall era. ModelNewEpochState era -> AccountState
mAccountState :: !AccountState
  , -- esPrevPp and esPp are for changing PParams
    -- esNonMyopic is for efficiency, and all are abstracted away

    -- Model NewEpochState fields
    forall era.
ModelNewEpochState era
-> Map (KeyHash 'StakePool) IndividualPoolStake
mPoolDistr :: !(Map (KeyHash 'StakePool) IndividualPoolStake)
  , forall era. ModelNewEpochState era -> PParams era
mPParams :: !(PParams era)
  , forall era. ModelNewEpochState era -> Coin
mDeposited :: !Coin
  , forall era. ModelNewEpochState era -> Coin
mFees :: !Coin
  , forall era. ModelNewEpochState era -> Int
mCount :: !Int
  , forall era. ModelNewEpochState era -> Map Int TxId
mIndex :: !(Map Int TxId)
  , -- below here NO EFFECT until we model EpochBoundary
    forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams
mFPoolParams :: !(Map (KeyHash 'StakePool) PoolParams)
  , forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) EpochNo
mRetiring :: !(Map (KeyHash 'StakePool) EpochNo)
  , forall era. ModelNewEpochState era -> SnapShots
mSnapshots :: !SnapShots
  , forall era. ModelNewEpochState era -> EpochNo
mEL :: !EpochNo -- The current epoch,
  , forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) Natural
mBprev :: !(Map (KeyHash 'StakePool) Natural) --  Blocks made before current epoch, NO EFFECT until we model EpochBoundar
  , forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) Natural
mBcur :: !(Map (KeyHash 'StakePool) Natural)
  , forall era. ModelNewEpochState era -> StrictMaybe RewardUpdate
mRu :: !(StrictMaybe RewardUpdate) -- Possible reward update
  }

type UtxoEntry era = (TxIn, TxOut era)

type Model era = ModelNewEpochState era

-- ======================================================================
-- Empty or default values, these are usefull for many things, not the
-- least of, for making Model instances.

blocksMadeZero :: BlocksMade
blocksMadeZero :: BlocksMade
blocksMadeZero = Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade forall k a. Map k a
Map.empty

poolDistrZero :: PoolDistr
poolDistrZero :: PoolDistr
poolDistrZero = Map (KeyHash 'StakePool) IndividualPoolStake
-> CompactForm Coin -> PoolDistr
PoolDistr forall k a. Map k a
Map.empty forall a b. (a -> b) -> a -> b
$ Word64 -> CompactForm Coin
CompactCoin Word64
1

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

utxoZero :: UTxO era
utxoZero :: forall era. UTxO era
utxoZero = forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall k a. Map k a
Map.empty

genDelegsZero :: GenDelegs
genDelegsZero :: GenDelegs
genDelegsZero = Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs
GenDelegs forall k a. Map k a
Map.empty

instantaneousRewardsZero :: InstantaneousRewards
instantaneousRewardsZero :: InstantaneousRewards
instantaneousRewardsZero = Map (Credential 'Staking) Coin
-> Map (Credential 'Staking) Coin
-> DeltaCoin
-> DeltaCoin
-> InstantaneousRewards
InstantaneousRewards forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty

dStateZero :: DState c
dStateZero :: forall c. DState c
dStateZero =
  DState
    { dsUnified :: UMap
dsUnified = UMap
UM.empty
    , dsFutureGenDelegs :: Map FutureGenDeleg GenDelegPair
dsFutureGenDelegs = forall k a. Map k a
Map.empty
    , dsGenDelegs :: GenDelegs
dsGenDelegs = GenDelegs
genDelegsZero
    , dsIRewards :: InstantaneousRewards
dsIRewards = InstantaneousRewards
instantaneousRewardsZero
    }

pStateZero :: PState c
pStateZero :: forall c. PState c
pStateZero =
  PState
    { psStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
psStakePoolParams = forall k a. Map k a
Map.empty
    , psFutureStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
psFutureStakePoolParams = forall k a. Map k a
Map.empty
    , psRetiring :: Map (KeyHash 'StakePool) EpochNo
psRetiring = forall k a. Map k a
Map.empty
    , psDeposits :: Map (KeyHash 'StakePool) Coin
psDeposits = forall k a. Map k a
Map.empty
    }

dPStateZero :: CertState era
dPStateZero :: forall era. CertState era
dPStateZero = forall era. VState era -> PState era -> DState era -> CertState era
CertState forall a. Default a => a
def forall c. PState c
pStateZero forall c. DState c
dStateZero

incrementalStakeZero :: IncrementalStake
incrementalStakeZero :: IncrementalStake
incrementalStakeZero = Map (Credential 'Staking) (CompactForm Coin)
-> Map Ptr (CompactForm Coin) -> IncrementalStake
IStake forall k a. Map k a
Map.empty forall k a. Map k a
Map.empty

nonMyopicZero :: NonMyopic
nonMyopicZero :: NonMyopic
nonMyopicZero = Map (KeyHash 'StakePool) Likelihood -> Coin -> NonMyopic
NonMyopic forall k a. Map k a
Map.empty forall a. Monoid a => a
mempty

pParamsZeroByProof :: Proof era -> PParams era
pParamsZeroByProof :: forall era. Proof era -> PParams era
pParamsZeroByProof Proof era
Conway = forall a. Default a => a
def
pParamsZeroByProof Proof era
Babbage = forall a. Default a => a
def
pParamsZeroByProof Proof era
Alonzo = forall a. Default a => a
def
pParamsZeroByProof Proof era
Mary = forall a. Default a => a
def
pParamsZeroByProof Proof era
Allegra = forall a. Default a => a
def
pParamsZeroByProof Proof era
Shelley = forall a. Default a => a
def

uTxOStateZero :: forall era. Reflect era => UTxOState era
uTxOStateZero :: forall era. Reflect era => UTxOState era
uTxOStateZero =
  forall era.
EraTxOut era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState
    forall era. Reflect era => PParams era
pParamsZero
    forall era. UTxO era
utxoZero
    forall a. Monoid a => a
mempty
    forall a. Monoid a => a
mempty
    forall era. EraGov era => GovState era
emptyGovState
    forall a. Monoid a => a
mempty

pParamsZero :: Reflect era => PParams era
pParamsZero :: forall era. Reflect era => PParams era
pParamsZero = forall era a. Reflect era => (Proof era -> a) -> a
lift forall era. Proof era -> PParams era
pParamsZeroByProof

ledgerStateZero :: forall era. Reflect era => LedgerState era
ledgerStateZero :: forall era. Reflect era => LedgerState era
ledgerStateZero = forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState forall era. Reflect era => UTxOState era
uTxOStateZero forall era. CertState era
dPStateZero

epochStateZero :: Reflect era => EpochState era
epochStateZero :: forall era. Reflect era => EpochState era
epochStateZero =
  forall era.
AccountState
-> LedgerState era -> SnapShots -> NonMyopic -> EpochState era
EpochState
    AccountState
accountStateZero
    forall era. Reflect era => LedgerState era
ledgerStateZero
    SnapShots
emptySnapShots
    NonMyopic
nonMyopicZero
    forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era. Reflect era => PParams era
pParamsZero
    forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era. Reflect era => PParams era
pParamsZero

newEpochStateZero :: forall era. Reflect era => NewEpochState era
newEpochStateZero :: forall era. Reflect era => NewEpochState era
newEpochStateZero =
  forall era.
EpochNo
-> BlocksMade
-> BlocksMade
-> EpochState era
-> StrictMaybe PulsingRewUpdate
-> PoolDistr
-> StashedAVVMAddresses era
-> NewEpochState era
NewEpochState
    (Word64 -> EpochNo
EpochNo Word64
0)
    BlocksMade
blocksMadeZero
    BlocksMade
blocksMadeZero
    forall era. Reflect era => EpochState era
epochStateZero
    forall a. StrictMaybe a
SNothing
    PoolDistr
poolDistrZero
    (forall era. Proof era -> StashedAVVMAddresses era
stashedAVVMAddressesZero (forall era. Reflect era => Proof era
reify :: Proof era))

stashedAVVMAddressesZero :: Proof era -> StashedAVVMAddresses era
stashedAVVMAddressesZero :: forall era. Proof era -> StashedAVVMAddresses era
stashedAVVMAddressesZero Proof era
Shelley = forall era. UTxO era
utxoZero
stashedAVVMAddressesZero Proof era
Conway = ()
stashedAVVMAddressesZero Proof era
Babbage = ()
stashedAVVMAddressesZero Proof era
Alonzo = ()
stashedAVVMAddressesZero Proof era
Mary = ()
stashedAVVMAddressesZero Proof era
Allegra = ()

mNewEpochStateZero :: Reflect era => ModelNewEpochState era
mNewEpochStateZero :: forall era. Reflect era => ModelNewEpochState era
mNewEpochStateZero =
  ModelNewEpochState
    { mPoolParams :: Map (KeyHash 'StakePool) PoolParams
mPoolParams = forall k a. Map k a
Map.empty
    , mPoolDeposits :: Map (KeyHash 'StakePool) Coin
mPoolDeposits = forall k a. Map k a
Map.empty
    , mRewards :: Map (Credential 'Staking) Coin
mRewards = forall k a. Map k a
Map.empty
    , mDelegations :: Map (Credential 'Staking) (KeyHash 'StakePool)
mDelegations = forall k a. Map k a
Map.empty
    , mKeyDeposits :: Map (Credential 'Staking) Coin
mKeyDeposits = forall k a. Map k a
Map.empty
    , mUTxO :: Map TxIn (TxOut era)
mUTxO = forall k a. Map k a
Map.empty
    , mMutFee :: Map TxIn (TxOut era)
mMutFee = forall k a. Map k a
Map.empty
    , mAccountState :: AccountState
mAccountState = AccountState
accountStateZero
    , mPoolDistr :: Map (KeyHash 'StakePool) IndividualPoolStake
mPoolDistr = forall k a. Map k a
Map.empty
    , mPParams :: PParams era
mPParams = forall era. Reflect era => PParams era
pParamsZero
    , mDeposited :: Coin
mDeposited = Integer -> Coin
Coin Integer
0
    , mFees :: Coin
mFees = Integer -> Coin
Coin Integer
0
    , mCount :: Int
mCount = Int
0
    , mIndex :: Map Int TxId
mIndex = forall k a. Map k a
Map.empty
    , -- below here NO EFFECT until we model EpochBoundary
      mFPoolParams :: Map (KeyHash 'StakePool) PoolParams
mFPoolParams = forall k a. Map k a
Map.empty
    , mRetiring :: Map (KeyHash 'StakePool) EpochNo
mRetiring = forall k a. Map k a
Map.empty
    , mSnapshots :: SnapShots
mSnapshots = SnapShots
emptySnapShots
    , mEL :: EpochNo
mEL = Word64 -> EpochNo
EpochNo Word64
0
    , mBprev :: Map (KeyHash 'StakePool) Natural
mBprev = forall k a. Map k a
Map.empty
    , mBcur :: Map (KeyHash 'StakePool) Natural
mBcur = forall k a. Map k a
Map.empty
    , mRu :: StrictMaybe RewardUpdate
mRu = forall a. StrictMaybe a
SNothing
    }

testNES :: NewEpochState BabbageEra
testNES :: NewEpochState BabbageEra
testNES = forall era. Reflect era => NewEpochState era
newEpochStateZero

testMNES :: ModelNewEpochState BabbageEra
testMNES :: ModelNewEpochState BabbageEra
testMNES = forall era. Reflect era => ModelNewEpochState era
mNewEpochStateZero

-- ======================================================================

class Extract t era where
  extract :: ModelNewEpochState era -> t

instance Extract (DState era) era where
  extract :: ModelNewEpochState era -> DState era
extract ModelNewEpochState era
x =
    forall era.
UMap
-> Map FutureGenDeleg GenDelegPair
-> GenDelegs
-> InstantaneousRewards
-> DState era
DState
      (Map (Credential 'Staking) RDPair
-> Map Ptr (Credential 'Staking)
-> Map (Credential 'Staking) (KeyHash 'StakePool)
-> Map (Credential 'Staking) DRep
-> UMap
UM.unify (forall era.
ModelNewEpochState era -> Map (Credential 'Staking) RDPair
makeRewards ModelNewEpochState era
x) forall k a. Map k a
Map.empty (forall era.
ModelNewEpochState era
-> Map (Credential 'Staking) (KeyHash 'StakePool)
mDelegations ModelNewEpochState era
x) forall k a. Map k a
Map.empty)
      forall k a. Map k a
Map.empty
      GenDelegs
genDelegsZero
      InstantaneousRewards
instantaneousRewardsZero

makeRewards :: ModelNewEpochState era -> Map.Map (Credential 'Staking) UM.RDPair
makeRewards :: forall era.
ModelNewEpochState era -> Map (Credential 'Staking) RDPair
makeRewards ModelNewEpochState era
mnes = forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey Credential 'Staking -> Coin -> RDPair
f Map (Credential 'Staking) Coin
credRewMap
  where
    credRewMap :: Map (Credential 'Staking) Coin
credRewMap = forall era.
ModelNewEpochState era -> Map (Credential 'Staking) Coin
mRewards ModelNewEpochState era
mnes
    credDepMap :: Map (Credential 'Staking) Coin
credDepMap = forall era.
ModelNewEpochState era -> Map (Credential 'Staking) Coin
mKeyDeposits ModelNewEpochState era
mnes
    f :: Credential 'Staking -> Coin -> RDPair
f Credential 'Staking
cred Coin
rew = case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'Staking
cred Map (Credential 'Staking) Coin
credDepMap of
      Just Coin
dep -> CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair (HasCallStack => Coin -> CompactForm Coin
UM.compactCoinOrError Coin
rew) (HasCallStack => Coin -> CompactForm Coin
UM.compactCoinOrError Coin
dep)
      Maybe Coin
Nothing -> forall a. HasCallStack => [Char] -> a
error ([Char]
"In makeRewards the reward and deposit maps are not in synch " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Credential 'Staking
cred)

instance Extract (PState era) era where
  extract :: ModelNewEpochState era -> PState era
extract ModelNewEpochState era
x = forall era.
Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) PoolParams
-> Map (KeyHash 'StakePool) EpochNo
-> Map (KeyHash 'StakePool) Coin
-> PState era
PState (forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams
mPoolParams ModelNewEpochState era
x) (forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams
mFPoolParams ModelNewEpochState era
x) (forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) EpochNo
mRetiring ModelNewEpochState era
x) forall k a. Map k a
Map.empty

instance Extract (VState era) era where
  extract :: ModelNewEpochState era -> VState era
extract ModelNewEpochState era
_ = forall era.
Map (Credential 'DRepRole) DRepState
-> CommitteeState era -> EpochNo -> VState era
VState forall a. Default a => a
def forall a. Default a => a
def (Word64 -> EpochNo
EpochNo Word64
0)

instance Extract (CertState era) era where
  extract :: ModelNewEpochState era -> CertState era
extract ModelNewEpochState era
x = forall era. VState era -> PState era -> DState era -> CertState era
CertState (forall t era. Extract t era => ModelNewEpochState era -> t
extract ModelNewEpochState era
x) (forall t era. Extract t era => ModelNewEpochState era -> t
extract ModelNewEpochState era
x) (forall t era. Extract t era => ModelNewEpochState era -> t
extract ModelNewEpochState era
x)

instance Reflect era => Extract (UTxOState era) era where
  extract :: ModelNewEpochState era -> UTxOState era
extract ModelNewEpochState era
x =
    forall era.
EraTxOut era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState
      (forall era. ModelNewEpochState era -> PParams era
mPParams ModelNewEpochState era
x)
      (forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (forall era. ModelNewEpochState era -> Map TxIn (TxOut era)
mUTxO ModelNewEpochState era
x))
      (forall era. ModelNewEpochState era -> Coin
mDeposited ModelNewEpochState era
x)
      (forall era. ModelNewEpochState era -> Coin
mFees ModelNewEpochState era
x)
      forall era. EraGov era => GovState era
emptyGovState
      forall a. Monoid a => a
mempty

instance Reflect era => Extract (LedgerState era) era where
  extract :: ModelNewEpochState era -> LedgerState era
extract ModelNewEpochState era
x = forall era. UTxOState era -> CertState era -> LedgerState era
LedgerState (forall t era. Extract t era => ModelNewEpochState era -> t
extract ModelNewEpochState era
x) (forall t era. Extract t era => ModelNewEpochState era -> t
extract ModelNewEpochState era
x)

instance Reflect era => Extract (EpochState era) era where
  extract :: ModelNewEpochState era -> EpochState era
extract ModelNewEpochState era
x =
    forall era.
AccountState
-> LedgerState era -> SnapShots -> NonMyopic -> EpochState era
EpochState
      (forall era. ModelNewEpochState era -> AccountState
mAccountState ModelNewEpochState era
x)
      (forall t era. Extract t era => ModelNewEpochState era -> t
extract ModelNewEpochState era
x)
      (forall era. ModelNewEpochState era -> SnapShots
mSnapshots ModelNewEpochState era
x)
      NonMyopic
nonMyopicZero
      forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era. ModelNewEpochState era -> PParams era
mPParams ModelNewEpochState era
x
      forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (EpochState era) (PParams era)
prevPParamsEpochStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era. ModelNewEpochState era -> PParams era
mPParams ModelNewEpochState era
x

instance forall era. Reflect era => Extract (NewEpochState era) era where
  extract :: ModelNewEpochState era -> NewEpochState era
extract ModelNewEpochState era
x =
    forall era.
EpochNo
-> BlocksMade
-> BlocksMade
-> EpochState era
-> StrictMaybe PulsingRewUpdate
-> PoolDistr
-> StashedAVVMAddresses era
-> NewEpochState era
NewEpochState
      (forall era. ModelNewEpochState era -> EpochNo
mEL ModelNewEpochState era
x)
      (Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade (forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) Natural
mBprev ModelNewEpochState era
x))
      (Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade (forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) Natural
mBcur ModelNewEpochState era
x))
      (forall t era. Extract t era => ModelNewEpochState era -> t
extract ModelNewEpochState era
x)
      (RewardUpdate -> PulsingRewUpdate
Complete forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall era. ModelNewEpochState era -> StrictMaybe RewardUpdate
mRu ModelNewEpochState era
x)
      (Map (KeyHash 'StakePool) IndividualPoolStake
-> CompactForm Coin -> PoolDistr
PoolDistr (forall era.
ModelNewEpochState era
-> Map (KeyHash 'StakePool) IndividualPoolStake
mPoolDistr ModelNewEpochState era
x) (Word64 -> CompactForm Coin
CompactCoin Word64
1))
      (forall era. Proof era -> StashedAVVMAddresses era
stashedAVVMAddressesZero (forall era. Reflect era => Proof era
reify :: Proof era))

abstract :: EraGov era => NewEpochState era -> ModelNewEpochState era
abstract :: forall era.
EraGov era =>
NewEpochState era -> ModelNewEpochState era
abstract NewEpochState era
x =
  ModelNewEpochState
    { mPoolParams :: Map (KeyHash 'StakePool) PoolParams
mPoolParams = (forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psStakePoolParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> PState era
certPState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> CertState era
lsCertState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs) NewEpochState era
x
    , mPoolDeposits :: Map (KeyHash 'StakePool) Coin
mPoolDeposits = (forall era. PState era -> Map (KeyHash 'StakePool) Coin
psDeposits forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> PState era
certPState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> CertState era
lsCertState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs) NewEpochState era
x
    , mRewards :: Map (Credential 'Staking) Coin
mRewards = (UMap -> Map (Credential 'Staking) Coin
UM.rewardMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. DState era -> UMap
dsUnified forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> DState era
certDState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> CertState era
lsCertState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs) NewEpochState era
x
    , mDelegations :: Map (Credential 'Staking) (KeyHash 'StakePool)
mDelegations = (UMap -> Map (Credential 'Staking) (KeyHash 'StakePool)
UM.sPoolMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. DState era -> UMap
dsUnified forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> DState era
certDState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> CertState era
lsCertState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs) NewEpochState era
x
    , mKeyDeposits :: Map (Credential 'Staking) Coin
mKeyDeposits = (UMap -> Map (Credential 'Staking) Coin
UM.depositMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. DState era -> UMap
dsUnified forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> DState era
certDState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> CertState era
lsCertState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs) NewEpochState era
x
    , mUTxO :: Map TxIn (TxOut era)
mUTxO = (forall era. UTxO era -> Map TxIn (TxOut era)
unUTxO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. UTxOState era -> UTxO era
utxosUtxo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> UTxOState era
lsUTxOState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs) NewEpochState era
x
    , mMutFee :: Map TxIn (TxOut era)
mMutFee = forall k a. Map k a
Map.empty
    , mAccountState :: AccountState
mAccountState = (forall era. EpochState era -> AccountState
esAccountState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs) NewEpochState era
x
    , mPoolDistr :: Map (KeyHash 'StakePool) IndividualPoolStake
mPoolDistr = (PoolDistr -> Map (KeyHash 'StakePool) IndividualPoolStake
unPoolDistr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> PoolDistr
nesPd) NewEpochState era
x
    , mPParams :: PParams era
mPParams = (forall a s. Getting a s a -> s -> a
view forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs) NewEpochState era
x
    , mDeposited :: Coin
mDeposited = (forall era. UTxOState era -> Coin
utxosDeposited forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> UTxOState era
lsUTxOState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs) NewEpochState era
x
    , mFees :: Coin
mFees = (forall era. UTxOState era -> Coin
utxosFees forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> UTxOState era
lsUTxOState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs) NewEpochState era
x
    , mCount :: Int
mCount = Int
0
    , mIndex :: Map Int TxId
mIndex = forall k a. Map k a
Map.empty
    , -- below here NO EFFECT until we model EpochBoundary
      mFPoolParams :: Map (KeyHash 'StakePool) PoolParams
mFPoolParams = (forall era. PState era -> Map (KeyHash 'StakePool) PoolParams
psFutureStakePoolParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> PState era
certPState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> CertState era
lsCertState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs) NewEpochState era
x
    , mRetiring :: Map (KeyHash 'StakePool) EpochNo
mRetiring = (forall era. PState era -> Map (KeyHash 'StakePool) EpochNo
psRetiring forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. CertState era -> PState era
certPState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. LedgerState era -> CertState era
lsCertState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EpochState era -> LedgerState era
esLState forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs) NewEpochState era
x
    , mSnapshots :: SnapShots
mSnapshots = (forall era. EpochState era -> SnapShots
esSnapshots forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. NewEpochState era -> EpochState era
nesEs) NewEpochState era
x
    , mEL :: EpochNo
mEL = forall era. NewEpochState era -> EpochNo
nesEL NewEpochState era
x
    , mBprev :: Map (KeyHash 'StakePool) Natural
mBprev = BlocksMade -> Map (KeyHash 'StakePool) Natural
unBlocksMade (forall era. NewEpochState era -> BlocksMade
nesBprev NewEpochState era
x)
    , mBcur :: Map (KeyHash 'StakePool) Natural
mBcur = BlocksMade -> Map (KeyHash 'StakePool) Natural
unBlocksMade (forall era. NewEpochState era -> BlocksMade
nesBcur NewEpochState era
x)
    , mRu :: StrictMaybe RewardUpdate
mRu = case forall era. NewEpochState era -> StrictMaybe PulsingRewUpdate
nesRu NewEpochState era
x of
        StrictMaybe PulsingRewUpdate
SNothing -> forall a. StrictMaybe a
SNothing -- <- There is no way to complete (nesRu x) to get a RewardUpdate
        SJust PulsingRewUpdate
pru -> forall a. a -> StrictMaybe a
SJust (PulsingRewUpdate -> RewardUpdate
complete PulsingRewUpdate
pru)
    }

complete :: PulsingRewUpdate -> RewardUpdate
complete :: PulsingRewUpdate -> RewardUpdate
complete (Complete RewardUpdate
r) = RewardUpdate
r
complete (Pulsing RewardSnapShot
rewsnap Pulser
pulser) = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. ShelleyBase a -> a
runShelleyBase (PulsingRewUpdate -> ShelleyBase (RewardUpdate, RewardEvent)
completeRupd (RewardSnapShot -> Pulser -> PulsingRewUpdate
Pulsing RewardSnapShot
rewsnap Pulser
pulser))

-- =====================================================================

pcModelNewEpochState :: Reflect era => Proof era -> ModelNewEpochState era -> PDoc
pcModelNewEpochState :: forall era.
Reflect era =>
Proof era -> ModelNewEpochState era -> PDoc
pcModelNewEpochState Proof era
proof ModelNewEpochState era
x =
  Text -> [(Text, PDoc)] -> PDoc
ppRecord Text
"ModelNewEpochState" forall a b. (a -> b) -> a -> b
$
    [ (Text
"poolparams", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap forall (keyrole :: KeyRole). KeyHash keyrole -> PDoc
keyHashSummary PoolParams -> PDoc
pcPoolParams (forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams
mPoolParams ModelNewEpochState era
x))
    , (Text
"pool deposits", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap forall (keyrole :: KeyRole). KeyHash keyrole -> PDoc
keyHashSummary Coin -> PDoc
pcCoin (forall era. ModelNewEpochState era -> Map (KeyHash 'StakePool) Coin
mPoolDeposits ModelNewEpochState era
x))
    , (Text
"rewards", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap forall (keyrole :: KeyRole). Credential keyrole -> PDoc
credSummary Coin -> PDoc
pcCoin (forall era.
ModelNewEpochState era -> Map (Credential 'Staking) Coin
mRewards ModelNewEpochState era
x))
    , (Text
"delegations", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap forall (keyrole :: KeyRole). Credential keyrole -> PDoc
pcCredential forall (keyrole :: KeyRole). KeyHash keyrole -> PDoc
pcKeyHash (forall era.
ModelNewEpochState era
-> Map (Credential 'Staking) (KeyHash 'StakePool)
mDelegations ModelNewEpochState era
x))
    , (Text
"key deposits", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap forall (keyrole :: KeyRole). Credential keyrole -> PDoc
credSummary Coin -> PDoc
pcCoin (forall era.
ModelNewEpochState era -> Map (Credential 'Staking) Coin
mKeyDeposits ModelNewEpochState era
x))
    , (Text
"utxo", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap TxIn -> PDoc
pcTxIn (forall era. Reflect era => Proof era -> TxOut era -> PDoc
pcTxOut Proof era
proof) (forall era. ModelNewEpochState era -> Map TxIn (TxOut era)
mUTxO ModelNewEpochState era
x))
    , (Text
"mutFees", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap TxIn -> PDoc
pcTxIn (forall era. Reflect era => Proof era -> TxOut era -> PDoc
pcTxOut Proof era
proof) (forall era. ModelNewEpochState era -> Map TxIn (TxOut era)
mMutFee ModelNewEpochState era
x))
    , (Text
"account", AccountState -> PDoc
pcAccountState (forall era. ModelNewEpochState era -> AccountState
mAccountState ModelNewEpochState era
x))
    , (Text
"pool distr", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap forall (keyrole :: KeyRole). KeyHash keyrole -> PDoc
pcKeyHash IndividualPoolStake -> PDoc
pcIndividualPoolStake (forall era.
ModelNewEpochState era
-> Map (KeyHash 'StakePool) IndividualPoolStake
mPoolDistr ModelNewEpochState era
x))
    , (Text
"protocol params", forall a. [Char] -> Doc a
ppString [Char]
"PParams ...")
    , (Text
"deposited", Coin -> PDoc
pcCoin (forall era. ModelNewEpochState era -> Coin
mDeposited ModelNewEpochState era
x))
    , (Text
"fees", Coin -> PDoc
pcCoin (forall era. ModelNewEpochState era -> Coin
mFees ModelNewEpochState era
x))
    , (Text
"count", forall a. Int -> Doc a
ppInt (forall era. ModelNewEpochState era -> Int
mCount ModelNewEpochState era
x))
    , (Text
"index", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap forall a. Int -> Doc a
ppInt TxId -> PDoc
pcTxId (forall era. ModelNewEpochState era -> Map Int TxId
mIndex ModelNewEpochState era
x))
    -- Add additional EpochBoundary fields here
    ]
      forall a. [a] -> [a] -> [a]
++ forall a. [Maybe a] -> [a]
Maybe.catMaybes (forall era.
Proof era -> ModelNewEpochState era -> [Maybe (Text, PDoc)]
epochBoundaryPDoc Proof era
proof ModelNewEpochState era
x)

epochBoundaryPDoc :: Proof era -> ModelNewEpochState era -> [Maybe (Text, PDoc)]
epochBoundaryPDoc :: forall era.
Proof era -> ModelNewEpochState era -> [Maybe (Text, PDoc)]
epochBoundaryPDoc Proof era
_proof ModelNewEpochState era
x =
  [ if forall k a. Map k a -> Bool
Map.null Map (KeyHash 'StakePool) PoolParams
futurepp
      then forall a. Maybe a
Nothing
      else forall a. a -> Maybe a
Just (Text
"future pparams", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap forall (keyrole :: KeyRole). KeyHash keyrole -> PDoc
pcKeyHash PoolParams -> PDoc
pcPoolParams Map (KeyHash 'StakePool) PoolParams
futurepp)
  , if forall k a. Map k a -> Bool
Map.null Map (KeyHash 'StakePool) EpochNo
retiring then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (Text
"retiring", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap forall (keyrole :: KeyRole). KeyHash keyrole -> PDoc
pcKeyHash forall ann. EpochNo -> Doc ann
ppEpochNo Map (KeyHash 'StakePool) EpochNo
retiring)
  , if EpochNo
lastepoch forall a. Eq a => a -> a -> Bool
== Word64 -> EpochNo
EpochNo Word64
0 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (Text
"last epoch", forall ann. EpochNo -> Doc ann
ppEpochNo EpochNo
lastepoch)
  , if forall k a. Map k a -> Bool
Map.null Map (KeyHash 'StakePool) Natural
prevBlocks then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (Text
"prev blocks", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap forall (keyrole :: KeyRole). KeyHash keyrole -> PDoc
pcKeyHash forall a. Natural -> Doc a
ppNatural Map (KeyHash 'StakePool) Natural
prevBlocks)
  , if forall k a. Map k a -> Bool
Map.null Map (KeyHash 'StakePool) Natural
curBlocks then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (Text
"current blocks", forall k v. (k -> PDoc) -> (v -> PDoc) -> Map k v -> PDoc
ppMap forall (keyrole :: KeyRole). KeyHash keyrole -> PDoc
pcKeyHash forall a. Natural -> Doc a
ppNatural Map (KeyHash 'StakePool) Natural
curBlocks)
  ]
  where
    futurepp :: Map (KeyHash 'StakePool) PoolParams
futurepp = forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) PoolParams
mFPoolParams ModelNewEpochState era
x
    retiring :: Map (KeyHash 'StakePool) EpochNo
retiring = forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) EpochNo
mRetiring ModelNewEpochState era
x
    lastepoch :: EpochNo
lastepoch = forall era. ModelNewEpochState era -> EpochNo
mEL ModelNewEpochState era
x
    prevBlocks :: Map (KeyHash 'StakePool) Natural
prevBlocks = (forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) Natural
mBprev ModelNewEpochState era
x)
    curBlocks :: Map (KeyHash 'StakePool) Natural
curBlocks = (forall era.
ModelNewEpochState era -> Map (KeyHash 'StakePool) Natural
mBcur ModelNewEpochState era
x)

-- SnapShots and PulsingRewUdate delberately ommitted from pretty printer

instance Reflect era => PrettyA (ModelNewEpochState era) where prettyA :: ModelNewEpochState era -> PDoc
prettyA = forall era.
Reflect era =>
Proof era -> ModelNewEpochState era -> PDoc
pcModelNewEpochState forall era. Reflect era => Proof era
reify

instance Reflect era => Show (ModelNewEpochState era) where
  show :: ModelNewEpochState era -> [Char]
show ModelNewEpochState era
x = forall a. Show a => a -> [Char]
show (forall t. PrettyA t => t -> PDoc
prettyA ModelNewEpochState era
x)