{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

-- | Besides capturing all configuration that is necessary to progress to a specific era,
-- this interface also provides fast forward functionality that is used in testing and
-- benchmarking in order to initilize a chain in a particular era without going through
-- the trouble of generating all the history for preceeding eras.
module Cardano.Ledger.Shelley.Transition (
  EraTransition (
    TransitionConfig,
    mkTransitionConfig,
    injectIntoTestState,
    tcPreviousEraConfigL,
    tcTranslationContextL,
    tcShelleyGenesisL,
    tcInitialPParamsG
  ),
  pattern ShelleyTransitionConfig,
  tcInitialFundsL,
  tcInitialStakingL,
  mkShelleyTransitionConfig,
  createInitialState,
  shelleyRegisterInitialFundsThenStaking,
  shelleyRegisterInitialAccounts,
  registerInitialStakePools,
  registerInitialFunds,
  resetStakeDistribution,
  protectMainnet,
  protectMainnetLens,
) where

import Cardano.Ledger.Address
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Coin
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Cardano.Ledger.Genesis
import Cardano.Ledger.Keys
import Cardano.Ledger.Shelley.Era
import Cardano.Ledger.Shelley.Genesis
import Cardano.Ledger.Shelley.Governance
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Shelley.Translation (
  FromByronTranslationContext (..),
  toFromByronTranslationContext,
 )
import Cardano.Ledger.Val
import Data.Aeson (FromJSON (..), KeyValue (..), ToJSON (..), object, withObject, (.:))
import qualified Data.Aeson as Aeson (Value (..))
import Data.Aeson.Key (Key, fromString)
import Data.Aeson.Types (Parser)
import Data.Char (toLower)
import Data.Default
import Data.Kind
import qualified Data.ListMap as ListMap
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Typeable
import Data.Void (Void)
import GHC.Generics (Generic)
import GHC.Stack
import Lens.Micro
import NoThunks.Class (NoThunks (..))

-- | Register the initial information in the 'NewEpochState'.
--
-- HERE BE DRAGONS! This interface is intended to help in testing and benchmarking.
--
-- In production, the genesis should /not/ contain any initial information about accounts, stake
-- pools or dreps.
--
-- /Warning/ - Should only be used in testing and benchmarking. Will result in an error
-- when NetworkId is set to Mainnet
class
  ( EraTxOut era
  , EraGov era
  , EraStake era
  , EraGenesis era
  , EraCertState era
  , Eq (TransitionConfig era)
  , Show (TransitionConfig era)
  , FromJSON (TransitionConfig era)
  , Default (StashedAVVMAddresses era)
  ) =>
  EraTransition era
  where
  -- | Cumulative configuration that is needed to be able to start in a current era
  data TransitionConfig era :: Type

  mkTransitionConfig ::
    -- | Translation context necessary for advancing from previous era into the current
    -- one. This will usually be the contents of genesis file, if one exists for the
    -- current era
    TranslationContext era ->
    -- | Transition configuration for the previous era.
    TransitionConfig (PreviousEra era) ->
    TransitionConfig era

  injectIntoTestState ::
    -- | Extract data from the given transition configuration and store it in the given state.
    --
    -- /Warning/ - Should only be used in testing and benchmarking. Will result in an error
    -- when 'NetworkId' is set to 'Mainnet'.
    TransitionConfig era ->
    NewEpochState era ->
    NewEpochState era

  -- | In case when a previous era is available, we should always be able to access
  -- `TransitionConfig` for the previous era, from within the current era's
  -- `TransitionConfig`
  tcPreviousEraConfigL ::
    EraTransition (PreviousEra era) =>
    Lens' (TransitionConfig era) (TransitionConfig (PreviousEra era))

  -- | Lens for the `TranslationContext` for the current era from the `TransitionConfig`
  -- Translation context is a different name for the Genesis type for each era, they are
  -- one and the same concept.
  tcTranslationContextL ::
    Lens' (TransitionConfig era) (TranslationContext era)

  -- | Lens for the `ShelleyGenesis` from the `TransitionConfig`. Default implementation
  -- looks in the previous era's config
  tcShelleyGenesisL :: Lens' (TransitionConfig era) ShelleyGenesis
  default tcShelleyGenesisL ::
    EraTransition (PreviousEra era) =>
    Lens' (TransitionConfig era) ShelleyGenesis
  tcShelleyGenesisL = (TransitionConfig (PreviousEra era)
 -> f (TransitionConfig (PreviousEra era)))
-> TransitionConfig era -> f (TransitionConfig era)
forall era.
(EraTransition era, EraTransition (PreviousEra era)) =>
Lens' (TransitionConfig era) (TransitionConfig (PreviousEra era))
Lens' (TransitionConfig era) (TransitionConfig (PreviousEra era))
tcPreviousEraConfigL ((TransitionConfig (PreviousEra era)
  -> f (TransitionConfig (PreviousEra era)))
 -> TransitionConfig era -> f (TransitionConfig era))
-> ((ShelleyGenesis -> f ShelleyGenesis)
    -> TransitionConfig (PreviousEra era)
    -> f (TransitionConfig (PreviousEra era)))
-> (ShelleyGenesis -> f ShelleyGenesis)
-> TransitionConfig era
-> f (TransitionConfig era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShelleyGenesis -> f ShelleyGenesis)
-> TransitionConfig (PreviousEra era)
-> f (TransitionConfig (PreviousEra era))
forall era.
EraTransition era =>
Lens' (TransitionConfig era) ShelleyGenesis
Lens' (TransitionConfig (PreviousEra era)) ShelleyGenesis
tcShelleyGenesisL

  -- | Get the initial PParams for the current era from the `TransitionConfig`. Note that
  -- this is only useful for testing and fast forward functionality, because this function
  -- assumes no on-chain changes to PParams through PParamsUpdate functionality.
  --
  -- Default implementation will use the PParams from the Previous era and the current
  -- `TranslationContext` to construct PParams for the current era.
  --
  -- /Warning/ - Should only be used in testing and benchmarking
  tcInitialPParamsG :: SimpleGetter (TransitionConfig era) (PParams era)
  default tcInitialPParamsG ::
    ( EraTransition (PreviousEra era)
    , TranslateEra era PParams
    , TranslationError era PParams ~ Void
    ) =>
    SimpleGetter (TransitionConfig era) (PParams era)
  tcInitialPParamsG =
    (TransitionConfig era -> PParams era)
-> SimpleGetter (TransitionConfig era) (PParams era)
forall s a. (s -> a) -> SimpleGetter s a
to ((TransitionConfig era -> PParams era)
 -> SimpleGetter (TransitionConfig era) (PParams era))
-> (TransitionConfig era -> PParams era)
-> SimpleGetter (TransitionConfig era) (PParams era)
forall a b. (a -> b) -> a -> b
$ \TransitionConfig era
tc ->
      TranslationContext era -> PParams (PreviousEra era) -> PParams era
forall era (f :: * -> *).
(TranslateEra era f, TranslationError era f ~ Void) =>
TranslationContext era -> f (PreviousEra era) -> f era
translateEra'
        (TransitionConfig era
tc TransitionConfig era
-> Getting
     (TranslationContext era)
     (TransitionConfig era)
     (TranslationContext era)
-> TranslationContext era
forall s a. s -> Getting a s a -> a
^. Getting
  (TranslationContext era)
  (TransitionConfig era)
  (TranslationContext era)
forall era.
EraTransition era =>
Lens' (TransitionConfig era) (TranslationContext era)
Lens' (TransitionConfig era) (TranslationContext era)
tcTranslationContextL)
        (TransitionConfig era
tc TransitionConfig era
-> Getting
     (PParams (PreviousEra era))
     (TransitionConfig era)
     (PParams (PreviousEra era))
-> PParams (PreviousEra era)
forall s a. s -> Getting a s a -> a
^. (TransitionConfig (PreviousEra era)
 -> Const
      (PParams (PreviousEra era)) (TransitionConfig (PreviousEra era)))
-> TransitionConfig era
-> Const (PParams (PreviousEra era)) (TransitionConfig era)
forall era.
(EraTransition era, EraTransition (PreviousEra era)) =>
Lens' (TransitionConfig era) (TransitionConfig (PreviousEra era))
Lens' (TransitionConfig era) (TransitionConfig (PreviousEra era))
tcPreviousEraConfigL ((TransitionConfig (PreviousEra era)
  -> Const
       (PParams (PreviousEra era)) (TransitionConfig (PreviousEra era)))
 -> TransitionConfig era
 -> Const (PParams (PreviousEra era)) (TransitionConfig era))
-> ((PParams (PreviousEra era)
     -> Const (PParams (PreviousEra era)) (PParams (PreviousEra era)))
    -> TransitionConfig (PreviousEra era)
    -> Const
         (PParams (PreviousEra era)) (TransitionConfig (PreviousEra era)))
-> Getting
     (PParams (PreviousEra era))
     (TransitionConfig era)
     (PParams (PreviousEra era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams (PreviousEra era)
 -> Const (PParams (PreviousEra era)) (PParams (PreviousEra era)))
-> TransitionConfig (PreviousEra era)
-> Const
     (PParams (PreviousEra era)) (TransitionConfig (PreviousEra era))
forall era.
EraTransition era =>
SimpleGetter (TransitionConfig era) (PParams era)
SimpleGetter
  (TransitionConfig (PreviousEra era)) (PParams (PreviousEra era))
tcInitialPParamsG)

  toTransitionConfigKeyValuePairs ::
    KeyValue e a =>
    TransitionConfig era ->
    [a]
  default toTransitionConfigKeyValuePairs ::
    ( EraTransition (PreviousEra era)
    , ToKeyValuePairs (TranslationContext era)
    , ToKeyValuePairs (TransitionConfig (PreviousEra era))
    , Typeable (TranslationContext era)
    , KeyValue e a
    ) =>
    TransitionConfig era ->
    [a]
  toTransitionConfigKeyValuePairs TransitionConfig era
config =
    TransitionConfig (PreviousEra era) -> [a]
forall a e kv. (ToKeyValuePairs a, KeyValue e kv) => a -> [kv]
forall e kv.
KeyValue e kv =>
TransitionConfig (PreviousEra era) -> [kv]
toKeyValuePairs (TransitionConfig era
config TransitionConfig era
-> Getting
     (TransitionConfig (PreviousEra era))
     (TransitionConfig era)
     (TransitionConfig (PreviousEra era))
-> TransitionConfig (PreviousEra era)
forall s a. s -> Getting a s a -> a
^. Getting
  (TransitionConfig (PreviousEra era))
  (TransitionConfig era)
  (TransitionConfig (PreviousEra era))
forall era.
(EraTransition era, EraTransition (PreviousEra era)) =>
Lens' (TransitionConfig era) (TransitionConfig (PreviousEra era))
Lens' (TransitionConfig era) (TransitionConfig (PreviousEra era))
tcPreviousEraConfigL) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
translationContextPairs
    where
      translationContextPairs :: [a]
translationContextPairs =
        case Maybe (TranslationContext era :~: NoGenesis era)
forall {k} (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT :: Maybe (TranslationContext era :~: NoGenesis era) of
          Maybe (TranslationContext era :~: NoGenesis era)
Nothing ->
            [ forall era. Era era => Key
eraNameKey @era Key -> Value -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object (TranslationContext era -> [Pair]
forall a e kv. (ToKeyValuePairs a, KeyValue e kv) => a -> [kv]
forall e kv. KeyValue e kv => TranslationContext era -> [kv]
toKeyValuePairs (TransitionConfig era
config TransitionConfig era
-> Getting
     (TranslationContext era)
     (TransitionConfig era)
     (TranslationContext era)
-> TranslationContext era
forall s a. s -> Getting a s a -> a
^. Getting
  (TranslationContext era)
  (TransitionConfig era)
  (TranslationContext era)
forall era.
EraTransition era =>
Lens' (TransitionConfig era) (TranslationContext era)
Lens' (TransitionConfig era) (TranslationContext era)
tcTranslationContextL))
            ]
          Just TranslationContext era :~: NoGenesis era
Refl -> []

  parseTransitionConfigJSON :: Aeson.Value -> Parser (TransitionConfig era)
  default parseTransitionConfigJSON ::
    ( Typeable (TranslationContext era)
    , FromJSON (TranslationContext era)
    , FromJSON (TransitionConfig (PreviousEra era))
    ) =>
    Aeson.Value ->
    Parser (TransitionConfig era)
  parseTransitionConfigJSON = String
-> (Object -> Parser (TransitionConfig era))
-> Value
-> Parser (TransitionConfig era)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject (forall era. Era era => String
eraName @era String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"TransitionConfig") ((Object -> Parser (TransitionConfig era))
 -> Value -> Parser (TransitionConfig era))
-> (Object -> Parser (TransitionConfig era))
-> Value
-> Parser (TransitionConfig era)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    prevTransitionConfig :: TransitionConfig (PreviousEra era) <- Value -> Parser (TransitionConfig (PreviousEra era))
forall a. FromJSON a => Value -> Parser a
parseJSON (Object -> Value
Aeson.Object Object
o)
    genesis <- mkGenesisWith @era (o .: eraNameKey @era)
    pure $ mkTransitionConfig genesis prevTransitionConfig

eraNameKey :: forall era. Era era => Key
eraNameKey :: forall era. Era era => Key
eraNameKey = String -> Key
fromString ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (forall era. Era era => String
eraName @era))

instance EraTransition era => ToKeyValuePairs (TransitionConfig era) where
  toKeyValuePairs :: forall e kv. KeyValue e kv => TransitionConfig era -> [kv]
toKeyValuePairs = TransitionConfig era -> [kv]
forall era e kv.
(EraTransition era, KeyValue e kv) =>
TransitionConfig era -> [kv]
forall e kv. KeyValue e kv => TransitionConfig era -> [kv]
toTransitionConfigKeyValuePairs

deriving via
  KeyValuePairs (TransitionConfig era)
  instance
    ToKeyValuePairs (TransitionConfig era) => ToJSON (TransitionConfig era)

instance EraTransition era => FromJSON (TransitionConfig era) where
  parseJSON :: Value -> Parser (TransitionConfig era)
parseJSON = Value -> Parser (TransitionConfig era)
forall era.
EraTransition era =>
Value -> Parser (TransitionConfig era)
parseTransitionConfigJSON

tcNetworkIDG :: EraTransition era => SimpleGetter (TransitionConfig era) Network
tcNetworkIDG :: forall era.
EraTransition era =>
SimpleGetter (TransitionConfig era) Network
tcNetworkIDG = (ShelleyGenesis -> Const r ShelleyGenesis)
-> TransitionConfig era -> Const r (TransitionConfig era)
forall era.
EraTransition era =>
Lens' (TransitionConfig era) ShelleyGenesis
Lens' (TransitionConfig era) ShelleyGenesis
tcShelleyGenesisL ((ShelleyGenesis -> Const r ShelleyGenesis)
 -> TransitionConfig era -> Const r (TransitionConfig era))
-> ((Network -> Const r Network)
    -> ShelleyGenesis -> Const r ShelleyGenesis)
-> (Network -> Const r Network)
-> TransitionConfig era
-> Const r (TransitionConfig era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShelleyGenesis -> Network) -> SimpleGetter ShelleyGenesis Network
forall s a. (s -> a) -> SimpleGetter s a
to ShelleyGenesis -> Network
sgNetworkId

shelleyRegisterInitialFundsThenStaking ::
  (EraTransition era, ShelleyEraAccounts era) =>
  TransitionConfig era ->
  NewEpochState era ->
  NewEpochState era
shelleyRegisterInitialFundsThenStaking :: forall era.
(EraTransition era, ShelleyEraAccounts era) =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
shelleyRegisterInitialFundsThenStaking TransitionConfig era
cfg =
  -- We must first register the initial funds, because the stake
  -- information depends on it.
  NewEpochState era -> NewEpochState era
forall era.
(EraCertState era, EraStake era) =>
NewEpochState era -> NewEpochState era
resetStakeDistribution
    (NewEpochState era -> NewEpochState era)
-> (NewEpochState era -> NewEpochState era)
-> NewEpochState era
-> NewEpochState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesisStaking -> NewEpochState era -> NewEpochState era
forall era.
(HasCallStack, ShelleyEraAccounts era, EraCertState era,
 EraGov era) =>
ShelleyGenesisStaking -> NewEpochState era -> NewEpochState era
shelleyRegisterInitialAccounts (TransitionConfig era
cfg TransitionConfig era
-> Getting
     ShelleyGenesisStaking (TransitionConfig era) ShelleyGenesisStaking
-> ShelleyGenesisStaking
forall s a. s -> Getting a s a -> a
^. Getting
  ShelleyGenesisStaking (TransitionConfig era) ShelleyGenesisStaking
forall era.
(HasCallStack, EraTransition era) =>
Lens' (TransitionConfig era) ShelleyGenesisStaking
Lens' (TransitionConfig era) ShelleyGenesisStaking
tcInitialStakingL)
    (NewEpochState era -> NewEpochState era)
-> (NewEpochState era -> NewEpochState era)
-> NewEpochState era
-> NewEpochState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGenesisStaking -> NewEpochState era -> NewEpochState era
forall era.
(EraCertState era, EraGov era) =>
ShelleyGenesisStaking -> NewEpochState era -> NewEpochState era
registerInitialStakePools (TransitionConfig era
cfg TransitionConfig era
-> Getting
     ShelleyGenesisStaking (TransitionConfig era) ShelleyGenesisStaking
-> ShelleyGenesisStaking
forall s a. s -> Getting a s a -> a
^. Getting
  ShelleyGenesisStaking (TransitionConfig era) ShelleyGenesisStaking
forall era.
(HasCallStack, EraTransition era) =>
Lens' (TransitionConfig era) ShelleyGenesisStaking
Lens' (TransitionConfig era) ShelleyGenesisStaking
tcInitialStakingL)
    (NewEpochState era -> NewEpochState era)
-> (NewEpochState era -> NewEpochState era)
-> NewEpochState era
-> NewEpochState era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransitionConfig era -> NewEpochState era -> NewEpochState era
forall era.
(EraTransition era, HasCallStack) =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialFunds TransitionConfig era
cfg

instance EraTransition ShelleyEra where
  newtype TransitionConfig ShelleyEra = ShelleyTransitionConfig
    { TransitionConfig ShelleyEra -> ShelleyGenesis
stcShelleyGenesis :: ShelleyGenesis
    }
    deriving (TransitionConfig ShelleyEra -> TransitionConfig ShelleyEra -> Bool
(TransitionConfig ShelleyEra
 -> TransitionConfig ShelleyEra -> Bool)
-> (TransitionConfig ShelleyEra
    -> TransitionConfig ShelleyEra -> Bool)
-> Eq (TransitionConfig ShelleyEra)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TransitionConfig ShelleyEra -> TransitionConfig ShelleyEra -> Bool
== :: TransitionConfig ShelleyEra -> TransitionConfig ShelleyEra -> Bool
$c/= :: TransitionConfig ShelleyEra -> TransitionConfig ShelleyEra -> Bool
/= :: TransitionConfig ShelleyEra -> TransitionConfig ShelleyEra -> Bool
Eq, Int -> TransitionConfig ShelleyEra -> String -> String
[TransitionConfig ShelleyEra] -> String -> String
TransitionConfig ShelleyEra -> String
(Int -> TransitionConfig ShelleyEra -> String -> String)
-> (TransitionConfig ShelleyEra -> String)
-> ([TransitionConfig ShelleyEra] -> String -> String)
-> Show (TransitionConfig ShelleyEra)
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TransitionConfig ShelleyEra -> String -> String
showsPrec :: Int -> TransitionConfig ShelleyEra -> String -> String
$cshow :: TransitionConfig ShelleyEra -> String
show :: TransitionConfig ShelleyEra -> String
$cshowList :: [TransitionConfig ShelleyEra] -> String -> String
showList :: [TransitionConfig ShelleyEra] -> String -> String
Show, (forall x.
 TransitionConfig ShelleyEra -> Rep (TransitionConfig ShelleyEra) x)
-> (forall x.
    Rep (TransitionConfig ShelleyEra) x -> TransitionConfig ShelleyEra)
-> Generic (TransitionConfig ShelleyEra)
forall x.
Rep (TransitionConfig ShelleyEra) x -> TransitionConfig ShelleyEra
forall x.
TransitionConfig ShelleyEra -> Rep (TransitionConfig ShelleyEra) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
TransitionConfig ShelleyEra -> Rep (TransitionConfig ShelleyEra) x
from :: forall x.
TransitionConfig ShelleyEra -> Rep (TransitionConfig ShelleyEra) x
$cto :: forall x.
Rep (TransitionConfig ShelleyEra) x -> TransitionConfig ShelleyEra
to :: forall x.
Rep (TransitionConfig ShelleyEra) x -> TransitionConfig ShelleyEra
Generic)

  mkTransitionConfig :: TranslationContext ShelleyEra
-> TransitionConfig (PreviousEra ShelleyEra)
-> TransitionConfig ShelleyEra
mkTransitionConfig =
    String
-> FromByronTranslationContext
-> TransitionConfig ByronEra
-> TransitionConfig ShelleyEra
forall a. HasCallStack => String -> a
error String
"Impossible: There is no EraTransition instance for ByronEra"

  injectIntoTestState :: TransitionConfig ShelleyEra
-> NewEpochState ShelleyEra -> NewEpochState ShelleyEra
injectIntoTestState = TransitionConfig ShelleyEra
-> NewEpochState ShelleyEra -> NewEpochState ShelleyEra
forall era.
(EraTransition era, ShelleyEraAccounts era) =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
shelleyRegisterInitialFundsThenStaking

  tcPreviousEraConfigL :: EraTransition (PreviousEra ShelleyEra) =>
Lens'
  (TransitionConfig ShelleyEra)
  (TransitionConfig (PreviousEra ShelleyEra))
tcPreviousEraConfigL = (TransitionConfig ByronEra -> f (TransitionConfig ByronEra))
-> TransitionConfig ShelleyEra -> f (TransitionConfig ShelleyEra)
(TransitionConfig (PreviousEra ShelleyEra)
 -> f (TransitionConfig (PreviousEra ShelleyEra)))
-> TransitionConfig ShelleyEra -> f (TransitionConfig ShelleyEra)
forall a b. HasCallStack => Lens' a b
Lens' (TransitionConfig ShelleyEra) (TransitionConfig ByronEra)
notSupportedInThisEraL

  tcTranslationContextL :: Lens' (TransitionConfig ShelleyEra) (TranslationContext ShelleyEra)
tcTranslationContextL =
    (ShelleyGenesis -> f ShelleyGenesis)
-> TransitionConfig ShelleyEra -> f (TransitionConfig ShelleyEra)
forall era.
EraTransition era =>
Lens' (TransitionConfig era) ShelleyGenesis
Lens' (TransitionConfig ShelleyEra) ShelleyGenesis
tcShelleyGenesisL ((ShelleyGenesis -> f ShelleyGenesis)
 -> TransitionConfig ShelleyEra -> f (TransitionConfig ShelleyEra))
-> ((FromByronTranslationContext -> f FromByronTranslationContext)
    -> ShelleyGenesis -> f ShelleyGenesis)
-> (FromByronTranslationContext -> f FromByronTranslationContext)
-> TransitionConfig ShelleyEra
-> f (TransitionConfig ShelleyEra)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShelleyGenesis -> FromByronTranslationContext)
-> (ShelleyGenesis
    -> FromByronTranslationContext -> ShelleyGenesis)
-> Lens
     ShelleyGenesis
     ShelleyGenesis
     FromByronTranslationContext
     FromByronTranslationContext
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ShelleyGenesis -> FromByronTranslationContext
toFromByronTranslationContext ShelleyGenesis -> FromByronTranslationContext -> ShelleyGenesis
setFBTC
    where
      setFBTC :: ShelleyGenesis -> FromByronTranslationContext -> ShelleyGenesis
setFBTC ShelleyGenesis
shelleyGenesis FromByronTranslationContext {Word64
Map (KeyHash GenesisRole) GenDelegPair
PParams ShelleyEra
fbtcGenDelegs :: Map (KeyHash GenesisRole) GenDelegPair
fbtcProtocolParams :: PParams ShelleyEra
fbtcMaxLovelaceSupply :: Word64
fbtcMaxLovelaceSupply :: FromByronTranslationContext -> Word64
fbtcProtocolParams :: FromByronTranslationContext -> PParams ShelleyEra
fbtcGenDelegs :: FromByronTranslationContext
-> Map (KeyHash GenesisRole) GenDelegPair
..} =
        ShelleyGenesis
shelleyGenesis
          { sgGenDelegs = fbtcGenDelegs
          , sgProtocolParams = fbtcProtocolParams
          , sgMaxLovelaceSupply = fbtcMaxLovelaceSupply
          }

  tcShelleyGenesisL :: Lens' (TransitionConfig ShelleyEra) ShelleyGenesis
tcShelleyGenesisL = (TransitionConfig ShelleyEra -> ShelleyGenesis)
-> (TransitionConfig ShelleyEra
    -> ShelleyGenesis -> TransitionConfig ShelleyEra)
-> Lens' (TransitionConfig ShelleyEra) ShelleyGenesis
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens TransitionConfig ShelleyEra -> ShelleyGenesis
stcShelleyGenesis (\TransitionConfig ShelleyEra
tc ShelleyGenesis
sg -> TransitionConfig ShelleyEra
tc {stcShelleyGenesis = sg})

  tcInitialPParamsG :: SimpleGetter (TransitionConfig ShelleyEra) (PParams ShelleyEra)
tcInitialPParamsG = (TransitionConfig ShelleyEra -> PParams ShelleyEra)
-> SimpleGetter (TransitionConfig ShelleyEra) (PParams ShelleyEra)
forall s a. (s -> a) -> SimpleGetter s a
to (ShelleyGenesis -> PParams ShelleyEra
sgProtocolParams (ShelleyGenesis -> PParams ShelleyEra)
-> (TransitionConfig ShelleyEra -> ShelleyGenesis)
-> TransitionConfig ShelleyEra
-> PParams ShelleyEra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransitionConfig ShelleyEra -> ShelleyGenesis
stcShelleyGenesis)

  toTransitionConfigKeyValuePairs :: forall e a. KeyValue e a => TransitionConfig ShelleyEra -> [a]
toTransitionConfigKeyValuePairs stc :: TransitionConfig ShelleyEra
stc@(ShelleyTransitionConfig ShelleyGenesis
_) =
    [Key
"shelley" Key -> Value -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object (ShelleyGenesis -> [Pair]
forall a e kv. (ToKeyValuePairs a, KeyValue e kv) => a -> [kv]
forall e kv. KeyValue e kv => ShelleyGenesis -> [kv]
toKeyValuePairs (TransitionConfig ShelleyEra -> ShelleyGenesis
stcShelleyGenesis TransitionConfig ShelleyEra
stc))]

  parseTransitionConfigJSON :: Value -> Parser (TransitionConfig ShelleyEra)
parseTransitionConfigJSON = String
-> (Object -> Parser (TransitionConfig ShelleyEra))
-> Value
-> Parser (TransitionConfig ShelleyEra)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ShelleyTransitionConfig" ((Object -> Parser (TransitionConfig ShelleyEra))
 -> Value -> Parser (TransitionConfig ShelleyEra))
-> (Object -> Parser (TransitionConfig ShelleyEra))
-> Value
-> Parser (TransitionConfig ShelleyEra)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    sg <- Object
o Object -> Key -> Parser ShelleyGenesis
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"shelley"
    pure $ ShelleyTransitionConfig {stcShelleyGenesis = sg}

-- | Get the initial funds from the `TransitionConfig`. This value must be non-empty
-- only during testing and benchmarking, it must never contain anything on a real system.
--
-- /Warning/ - Should only be used in testing and benchmarking. Will result in an error
-- when NetworkId is set to Mainnet
tcInitialFundsL ::
  (HasCallStack, EraTransition era) =>
  Lens' (TransitionConfig era) (ListMap.ListMap Addr Coin)
tcInitialFundsL :: forall era.
(HasCallStack, EraTransition era) =>
Lens' (TransitionConfig era) (ListMap Addr Coin)
tcInitialFundsL =
  String
-> (ListMap Addr Coin -> Bool)
-> Lens' (TransitionConfig era) (ListMap Addr Coin)
-> Lens' (TransitionConfig era) (ListMap Addr Coin)
forall era a.
(HasCallStack, EraTransition era) =>
String
-> (a -> Bool)
-> Lens' (TransitionConfig era) a
-> Lens' (TransitionConfig era) a
protectMainnetLens String
"InitialFunds" ListMap Addr Coin -> Bool
forall a. ListMap Addr a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Lens' (TransitionConfig era) (ListMap Addr Coin)
 -> Lens' (TransitionConfig era) (ListMap Addr Coin))
-> Lens' (TransitionConfig era) (ListMap Addr Coin)
-> Lens' (TransitionConfig era) (ListMap Addr Coin)
forall a b. (a -> b) -> a -> b
$
    (ShelleyGenesis -> f ShelleyGenesis)
-> TransitionConfig era -> f (TransitionConfig era)
forall era.
EraTransition era =>
Lens' (TransitionConfig era) ShelleyGenesis
Lens' (TransitionConfig era) ShelleyGenesis
tcShelleyGenesisL ((ShelleyGenesis -> f ShelleyGenesis)
 -> TransitionConfig era -> f (TransitionConfig era))
-> ((ListMap Addr Coin -> f (ListMap Addr Coin))
    -> ShelleyGenesis -> f ShelleyGenesis)
-> (ListMap Addr Coin -> f (ListMap Addr Coin))
-> TransitionConfig era
-> f (TransitionConfig era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ListMap Addr Coin -> f (ListMap Addr Coin))
-> ShelleyGenesis -> f ShelleyGenesis
Lens' ShelleyGenesis (ListMap Addr Coin)
sgInitialFundsL

-- | Get the initial staking from the `TransitionConfig`. This value must be non-empty
-- only during testing and benchmarking, it must never contain anything on a real system.
--
-- /Warning/ - Should only be used in testing and benchmarking. Will result in an error
-- when NetworkId is set to Mainnet
tcInitialStakingL ::
  (HasCallStack, EraTransition era) =>
  Lens' (TransitionConfig era) ShelleyGenesisStaking
tcInitialStakingL :: forall era.
(HasCallStack, EraTransition era) =>
Lens' (TransitionConfig era) ShelleyGenesisStaking
tcInitialStakingL =
  String
-> (ShelleyGenesisStaking -> Bool)
-> Lens' (TransitionConfig era) ShelleyGenesisStaking
-> Lens' (TransitionConfig era) ShelleyGenesisStaking
forall era a.
(HasCallStack, EraTransition era) =>
String
-> (a -> Bool)
-> Lens' (TransitionConfig era) a
-> Lens' (TransitionConfig era) a
protectMainnetLens String
"InitialStaking" (ShelleyGenesisStaking -> ShelleyGenesisStaking -> Bool
forall a. Eq a => a -> a -> Bool
== ShelleyGenesisStaking
forall a. Monoid a => a
mempty) (Lens' (TransitionConfig era) ShelleyGenesisStaking
 -> Lens' (TransitionConfig era) ShelleyGenesisStaking)
-> Lens' (TransitionConfig era) ShelleyGenesisStaking
-> Lens' (TransitionConfig era) ShelleyGenesisStaking
forall a b. (a -> b) -> a -> b
$
    (ShelleyGenesis -> f ShelleyGenesis)
-> TransitionConfig era -> f (TransitionConfig era)
forall era.
EraTransition era =>
Lens' (TransitionConfig era) ShelleyGenesis
Lens' (TransitionConfig era) ShelleyGenesis
tcShelleyGenesisL ((ShelleyGenesis -> f ShelleyGenesis)
 -> TransitionConfig era -> f (TransitionConfig era))
-> ((ShelleyGenesisStaking -> f ShelleyGenesisStaking)
    -> ShelleyGenesis -> f ShelleyGenesis)
-> (ShelleyGenesisStaking -> f ShelleyGenesisStaking)
-> TransitionConfig era
-> f (TransitionConfig era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ShelleyGenesisStaking -> f ShelleyGenesisStaking)
-> ShelleyGenesis -> f ShelleyGenesis
Lens' ShelleyGenesis ShelleyGenesisStaking
sgStakingL

-- | Constructor for the base Shelley `TransitionConfig`
mkShelleyTransitionConfig :: ShelleyGenesis -> TransitionConfig ShelleyEra
mkShelleyTransitionConfig :: ShelleyGenesis -> TransitionConfig ShelleyEra
mkShelleyTransitionConfig = ShelleyGenesis -> TransitionConfig ShelleyEra
ShelleyTransitionConfig

protectMainnetLens ::
  (HasCallStack, EraTransition era) =>
  String ->
  (a -> Bool) ->
  Lens' (TransitionConfig era) a ->
  Lens' (TransitionConfig era) a
protectMainnetLens :: forall era a.
(HasCallStack, EraTransition era) =>
String
-> (a -> Bool)
-> Lens' (TransitionConfig era) a
-> Lens' (TransitionConfig era) a
protectMainnetLens String
name a -> Bool
isMainnetSafe Lens' (TransitionConfig era) a
l =
  (TransitionConfig era -> a)
-> (TransitionConfig era -> a -> TransitionConfig era)
-> Lens' (TransitionConfig era) a
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    (\TransitionConfig era
g -> String -> TransitionConfig era -> (a -> Bool) -> a -> a
forall era a.
(HasCallStack, EraTransition era) =>
String -> TransitionConfig era -> (a -> Bool) -> a -> a
protectMainnet String
name TransitionConfig era
g a -> Bool
isMainnetSafe (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ TransitionConfig era
g TransitionConfig era -> Getting a (TransitionConfig era) a -> a
forall s a. s -> Getting a s a -> a
^. Getting a (TransitionConfig era) a
Lens' (TransitionConfig era) a
l)
    (\TransitionConfig era
g a
x -> TransitionConfig era
g TransitionConfig era
-> (TransitionConfig era -> TransitionConfig era)
-> TransitionConfig era
forall a b. a -> (a -> b) -> b
& (a -> Identity a)
-> TransitionConfig era -> Identity (TransitionConfig era)
Lens' (TransitionConfig era) a
l ((a -> Identity a)
 -> TransitionConfig era -> Identity (TransitionConfig era))
-> a -> TransitionConfig era -> TransitionConfig era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ a
x)

protectMainnet ::
  (HasCallStack, EraTransition era) =>
  String ->
  TransitionConfig era ->
  (a -> Bool) ->
  a ->
  a
protectMainnet :: forall era a.
(HasCallStack, EraTransition era) =>
String -> TransitionConfig era -> (a -> Bool) -> a -> a
protectMainnet String
name TransitionConfig era
g a -> Bool
isMainnetSafe a
m =
  if TransitionConfig era
g TransitionConfig era
-> Getting Network (TransitionConfig era) Network -> Network
forall s a. s -> Getting a s a -> a
^. Getting Network (TransitionConfig era) Network
forall era.
EraTransition era =>
SimpleGetter (TransitionConfig era) Network
SimpleGetter (TransitionConfig era) Network
tcNetworkIDG Network -> Network -> Bool
forall a. Eq a => a -> a -> Bool
== Network
Mainnet Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
isMainnetSafe a
m)
    then String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"Injection of " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not possible on Mainnet"
    else a
m

deriving instance NoThunks (TransitionConfig ShelleyEra)

-- | Helper function for constructing the initial state for any era
--
-- /Warning/ - Should only be used in testing and benchmarking. Will result in an error
-- when NetworkId is set to Mainnet
--
-- This function does not register any initial funds or delegates.
createInitialState ::
  forall era.
  (EraTransition era, HasCallStack) =>
  TransitionConfig era ->
  NewEpochState era
createInitialState :: forall era.
(EraTransition era, HasCallStack) =>
TransitionConfig era -> NewEpochState era
createInitialState TransitionConfig era
tc =
  String
-> TransitionConfig era
-> (NewEpochState era -> Bool)
-> NewEpochState era
-> NewEpochState era
forall era a.
(HasCallStack, EraTransition era) =>
String -> TransitionConfig era -> (a -> Bool) -> a -> a
protectMainnet
    String
"InitialState"
    TransitionConfig era
tc
    (Bool -> NewEpochState era -> Bool
forall a b. a -> b -> a
const Bool
False)
    NewEpochState
      { nesEL :: EpochNo
nesEL = EpochNo
initialEpochNo
      , nesBprev :: BlocksMade
nesBprev = Map (KeyHash StakePool) Natural -> BlocksMade
BlocksMade Map (KeyHash StakePool) Natural
forall k a. Map k a
Map.empty
      , nesBcur :: BlocksMade
nesBcur = Map (KeyHash StakePool) Natural -> BlocksMade
BlocksMade Map (KeyHash StakePool) Natural
forall k a. Map k a
Map.empty
      , nesEs :: EpochState era
nesEs =
          EpochState
            { esChainAccountState :: ChainAccountState
esChainAccountState =
                ChainAccountState
                  { casTreasury :: Coin
casTreasury = Coin
forall t. Val t => t
zero
                  , casReserves :: Coin
casReserves = Coin
reserves
                  }
            , esSnapshots :: SnapShots
esSnapshots = SnapShots
emptySnapShots
            , esLState :: LedgerState era
esLState =
                LedgerState
                  { lsUTxOState :: UTxOState era
lsUTxOState =
                      PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
forall era.
EraStake era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState PParams era
pp UTxO era
initialUtxo Coin
forall t. Val t => t
zero Coin
forall t. Val t => t
zero GovState era
govState Coin
forall t. Val t => t
zero
                  , lsCertState :: CertState era
lsCertState =
                      CertState era
forall a. Default a => a
def CertState era -> (CertState era -> CertState era) -> CertState era
forall a b. a -> (a -> b) -> b
& (DState era -> Identity (DState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Identity (DState era))
 -> CertState era -> Identity (CertState era))
-> ((GenDelegs -> Identity GenDelegs)
    -> DState era -> Identity (DState era))
-> (GenDelegs -> Identity GenDelegs)
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenDelegs -> Identity GenDelegs)
-> DState era -> Identity (DState era)
forall era (f :: * -> *).
Functor f =>
(GenDelegs -> f GenDelegs) -> DState era -> f (DState era)
dsGenDelegsL ((GenDelegs -> Identity GenDelegs)
 -> CertState era -> Identity (CertState era))
-> GenDelegs -> CertState era -> CertState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (KeyHash GenesisRole) GenDelegPair -> GenDelegs
GenDelegs (ShelleyGenesis -> Map (KeyHash GenesisRole) GenDelegPair
sgGenDelegs ShelleyGenesis
sg)
                  }
            , esNonMyopic :: NonMyopic
esNonMyopic = NonMyopic
forall a. Default a => a
def
            }
      , nesRu :: StrictMaybe PulsingRewUpdate
nesRu = StrictMaybe PulsingRewUpdate
forall a. StrictMaybe a
SNothing
      , nesPd :: PoolDistr
nesPd = Map (KeyHash StakePool) IndividualPoolStake
-> CompactForm Coin -> PoolDistr
PoolDistr Map (KeyHash StakePool) IndividualPoolStake
forall k a. Map k a
Map.empty CompactForm Coin
forall a. Monoid a => a
mempty
      , stashedAVVMAddresses :: StashedAVVMAddresses era
stashedAVVMAddresses = StashedAVVMAddresses era
forall a. Default a => a
def
      }
  where
    govState :: GovState era
    govState :: GovState era
govState =
      GovState era
forall era. EraGov era => GovState era
emptyGovState
        GovState era -> (GovState era -> GovState era) -> GovState era
forall a b. a -> (a -> b) -> b
& (PParams era -> Identity (PParams era))
-> GovState era -> Identity (GovState era)
forall era. EraGov era => Lens' (GovState era) (PParams era)
Lens' (GovState era) (PParams era)
curPParamsGovStateL ((PParams era -> Identity (PParams era))
 -> GovState era -> Identity (GovState era))
-> PParams era -> GovState era -> GovState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams era
pp
        GovState era -> (GovState era -> GovState era) -> GovState era
forall a b. a -> (a -> b) -> b
& (PParams era -> Identity (PParams era))
-> GovState era -> Identity (GovState era)
forall era. EraGov era => Lens' (GovState era) (PParams era)
Lens' (GovState era) (PParams era)
prevPParamsGovStateL ((PParams era -> Identity (PParams era))
 -> GovState era -> Identity (GovState era))
-> PParams era -> GovState era -> GovState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams era
pp
    pp :: PParams era
    pp :: PParams era
pp = TransitionConfig era
tc TransitionConfig era
-> Getting (PParams era) (TransitionConfig era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (TransitionConfig era) (PParams era)
forall era.
EraTransition era =>
SimpleGetter (TransitionConfig era) (PParams era)
SimpleGetter (TransitionConfig era) (PParams era)
tcInitialPParamsG
    sg :: ShelleyGenesis
    sg :: ShelleyGenesis
sg = TransitionConfig era
tc TransitionConfig era
-> Getting ShelleyGenesis (TransitionConfig era) ShelleyGenesis
-> ShelleyGenesis
forall s a. s -> Getting a s a -> a
^. Getting ShelleyGenesis (TransitionConfig era) ShelleyGenesis
forall era.
EraTransition era =>
Lens' (TransitionConfig era) ShelleyGenesis
Lens' (TransitionConfig era) ShelleyGenesis
tcShelleyGenesisL
    initialEpochNo :: EpochNo
    initialEpochNo :: EpochNo
initialEpochNo = Word64 -> EpochNo
EpochNo Word64
0
    initialUtxo :: UTxO era
    initialUtxo :: UTxO era
initialUtxo = UTxO era
forall a. Monoid a => a
mempty
    reserves :: Coin
    reserves :: Coin
reserves = Word64 -> Coin
word64ToCoin (ShelleyGenesis -> Word64
sgMaxLovelaceSupply ShelleyGenesis
sg) Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> UTxO era -> Coin
forall era. EraTxOut era => UTxO era -> Coin
sumCoinUTxO UTxO era
initialUtxo

-- | Register initial stake pools from the `ShelleyGenesisStaking`
registerInitialStakePools ::
  forall era.
  (EraCertState era, EraGov era) =>
  ShelleyGenesisStaking ->
  NewEpochState era ->
  NewEpochState era
registerInitialStakePools :: forall era.
(EraCertState era, EraGov era) =>
ShelleyGenesisStaking -> NewEpochState era -> NewEpochState era
registerInitialStakePools ShelleyGenesisStaking {ListMap (KeyHash StakePool) StakePoolParams
sgsPools :: ListMap (KeyHash StakePool) StakePoolParams
sgsPools :: ShelleyGenesisStaking
-> ListMap (KeyHash StakePool) StakePoolParams
sgsPools} NewEpochState era
nes =
  NewEpochState era
nes
    NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Identity (Map (KeyHash StakePool) StakePoolState))
    -> EpochState era -> Identity (EpochState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Identity (Map (KeyHash StakePool) StakePoolState))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Identity (LedgerState era))
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Identity (LedgerState era))
 -> EpochState era -> Identity (EpochState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Identity (Map (KeyHash StakePool) StakePoolState))
    -> LedgerState era -> Identity (LedgerState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Identity (Map (KeyHash StakePool) StakePoolState))
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Identity (CertState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Identity (CertState era))
 -> LedgerState era -> Identity (LedgerState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Identity (Map (KeyHash StakePool) StakePoolState))
    -> CertState era -> Identity (CertState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Identity (Map (KeyHash StakePool) StakePoolState))
-> LedgerState era
-> Identity (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PState era -> Identity (PState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era -> Identity (PState era))
 -> CertState era -> Identity (CertState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Identity (Map (KeyHash StakePool) StakePoolState))
    -> PState era -> Identity (PState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Identity (Map (KeyHash StakePool) StakePoolState))
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Identity (Map (KeyHash StakePool) StakePoolState))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL
      ((Map (KeyHash StakePool) StakePoolState
  -> Identity (Map (KeyHash StakePool) StakePoolState))
 -> NewEpochState era -> Identity (NewEpochState era))
-> Map (KeyHash StakePool) StakePoolState
-> NewEpochState era
-> NewEpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ListMap (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) StakePoolState
forall k v. Ord k => ListMap k v -> Map k v
ListMap.toMap (CompactForm Coin
-> Set (Credential Staking) -> StakePoolParams -> StakePoolState
mkStakePoolState CompactForm Coin
deposit Set (Credential Staking)
forall a. Monoid a => a
mempty (StakePoolParams -> StakePoolState)
-> ListMap (KeyHash StakePool) StakePoolParams
-> ListMap (KeyHash StakePool) StakePoolState
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ListMap (KeyHash StakePool) StakePoolParams
sgsPools)
  where
    deposit :: CompactForm Coin
deposit = NewEpochState era
nes NewEpochState era
-> Getting
     (CompactForm Coin) (NewEpochState era) (CompactForm Coin)
-> CompactForm Coin
forall s a. s -> Getting a s a -> a
^. (EpochState era -> Const (CompactForm Coin) (EpochState era))
-> NewEpochState era
-> Const (CompactForm Coin) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const (CompactForm Coin) (EpochState era))
 -> NewEpochState era
 -> Const (CompactForm Coin) (NewEpochState era))
-> ((CompactForm Coin
     -> Const (CompactForm Coin) (CompactForm Coin))
    -> EpochState era -> Const (CompactForm Coin) (EpochState era))
-> Getting
     (CompactForm Coin) (NewEpochState era) (CompactForm Coin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const (CompactForm Coin) (PParams era))
-> EpochState era -> Const (CompactForm Coin) (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const (CompactForm Coin) (PParams era))
 -> EpochState era -> Const (CompactForm Coin) (EpochState era))
-> ((CompactForm Coin
     -> Const (CompactForm Coin) (CompactForm Coin))
    -> PParams era -> Const (CompactForm Coin) (PParams era))
-> (CompactForm Coin
    -> Const (CompactForm Coin) (CompactForm Coin))
-> EpochState era
-> Const (CompactForm Coin) (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CompactForm Coin -> Const (CompactForm Coin) (CompactForm Coin))
-> PParams era -> Const (CompactForm Coin) (PParams era)
forall era.
EraPParams era =>
Lens' (PParams era) (CompactForm Coin)
Lens' (PParams era) (CompactForm Coin)
ppPoolDepositCompactL

-- | Register all staking credentials and apply delegations. Make sure StakePools that are being
-- delegated to are already registered, which can be done with `registerInitialStakePools`.
shelleyRegisterInitialAccounts ::
  forall era.
  (HasCallStack, ShelleyEraAccounts era, EraCertState era, EraGov era) =>
  ShelleyGenesisStaking ->
  NewEpochState era ->
  NewEpochState era
shelleyRegisterInitialAccounts :: forall era.
(HasCallStack, ShelleyEraAccounts era, EraCertState era,
 EraGov era) =>
ShelleyGenesisStaking -> NewEpochState era -> NewEpochState era
shelleyRegisterInitialAccounts ShelleyGenesisStaking {ListMap (KeyHash Staking) (KeyHash StakePool)
sgsStake :: ListMap (KeyHash Staking) (KeyHash StakePool)
sgsStake :: ShelleyGenesisStaking
-> ListMap (KeyHash Staking) (KeyHash StakePool)
sgsStake} NewEpochState era
nes =
  NewEpochState era
nes
    NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((Accounts era -> Identity (Accounts era))
    -> EpochState era -> Identity (EpochState era))
-> (Accounts era -> Identity (Accounts era))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Identity (LedgerState era))
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Identity (LedgerState era))
 -> EpochState era -> Identity (EpochState era))
-> ((Accounts era -> Identity (Accounts era))
    -> LedgerState era -> Identity (LedgerState era))
-> (Accounts era -> Identity (Accounts era))
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Identity (CertState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Identity (CertState era))
 -> LedgerState era -> Identity (LedgerState era))
-> ((Accounts era -> Identity (Accounts era))
    -> CertState era -> Identity (CertState era))
-> (Accounts era -> Identity (Accounts era))
-> LedgerState era
-> Identity (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Identity (DState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Identity (DState era))
 -> CertState era -> Identity (CertState era))
-> ((Accounts era -> Identity (Accounts era))
    -> DState era -> Identity (DState era))
-> (Accounts era -> Identity (Accounts era))
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Identity (Accounts era))
-> DState era -> Identity (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL ((Accounts era -> Identity (Accounts era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> Accounts era -> NewEpochState era -> NewEpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Accounts era
updatedAccounts
    NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Identity (Map (KeyHash StakePool) StakePoolState))
    -> EpochState era -> Identity (EpochState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Identity (Map (KeyHash StakePool) StakePoolState))
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Identity (LedgerState era))
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Identity (LedgerState era))
 -> EpochState era -> Identity (EpochState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Identity (Map (KeyHash StakePool) StakePoolState))
    -> LedgerState era -> Identity (LedgerState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Identity (Map (KeyHash StakePool) StakePoolState))
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Identity (CertState era))
-> LedgerState era -> Identity (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Identity (CertState era))
 -> LedgerState era -> Identity (LedgerState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Identity (Map (KeyHash StakePool) StakePoolState))
    -> CertState era -> Identity (CertState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Identity (Map (KeyHash StakePool) StakePoolState))
-> LedgerState era
-> Identity (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PState era -> Identity (PState era))
-> CertState era -> Identity (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era -> Identity (PState era))
 -> CertState era -> Identity (CertState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Identity (Map (KeyHash StakePool) StakePoolState))
    -> PState era -> Identity (PState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Identity (Map (KeyHash StakePool) StakePoolState))
-> CertState era
-> Identity (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Identity (Map (KeyHash StakePool) StakePoolState))
-> PState era -> Identity (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL ((Map (KeyHash StakePool) StakePoolState
  -> Identity (Map (KeyHash StakePool) StakePoolState))
 -> NewEpochState era -> Identity (NewEpochState era))
-> Map (KeyHash StakePool) StakePoolState
-> NewEpochState era
-> NewEpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Map (KeyHash StakePool) StakePoolState
updatedStakePoolStates
  where
    stakePools :: Map (KeyHash StakePool) StakePoolState
stakePools = NewEpochState era
nes NewEpochState era
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (NewEpochState era)
     (Map (KeyHash StakePool) StakePoolState)
-> Map (KeyHash StakePool) StakePoolState
forall s a. s -> Getting a s a -> a
^. (EpochState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era))
-> NewEpochState era
-> Const
     (Map (KeyHash StakePool) StakePoolState) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era))
 -> NewEpochState era
 -> Const
      (Map (KeyHash StakePool) StakePoolState) (NewEpochState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> EpochState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era))
-> Getting
     (Map (KeyHash StakePool) StakePoolState)
     (NewEpochState era)
     (Map (KeyHash StakePool) StakePoolState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era
 -> Const
      (Map (KeyHash StakePool) StakePoolState) (LedgerState era))
-> EpochState era
-> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era
  -> Const
       (Map (KeyHash StakePool) StakePoolState) (LedgerState era))
 -> EpochState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> LedgerState era
    -> Const
         (Map (KeyHash StakePool) StakePoolState) (LedgerState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Const
         (Map (KeyHash StakePool) StakePoolState)
         (Map (KeyHash StakePool) StakePoolState))
-> EpochState era
-> Const (Map (KeyHash StakePool) StakePoolState) (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> LedgerState era
-> Const (Map (KeyHash StakePool) StakePoolState) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
 -> LedgerState era
 -> Const
      (Map (KeyHash StakePool) StakePoolState) (LedgerState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> CertState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Const
         (Map (KeyHash StakePool) StakePoolState)
         (Map (KeyHash StakePool) StakePoolState))
-> LedgerState era
-> Const (Map (KeyHash StakePool) StakePoolState) (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> CertState era
-> Const (Map (KeyHash StakePool) StakePoolState) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL ((PState era
  -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
 -> CertState era
 -> Const (Map (KeyHash StakePool) StakePoolState) (CertState era))
-> ((Map (KeyHash StakePool) StakePoolState
     -> Const
          (Map (KeyHash StakePool) StakePoolState)
          (Map (KeyHash StakePool) StakePoolState))
    -> PState era
    -> Const (Map (KeyHash StakePool) StakePoolState) (PState era))
-> (Map (KeyHash StakePool) StakePoolState
    -> Const
         (Map (KeyHash StakePool) StakePoolState)
         (Map (KeyHash StakePool) StakePoolState))
-> CertState era
-> Const (Map (KeyHash StakePool) StakePoolState) (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map (KeyHash StakePool) StakePoolState
 -> Const
      (Map (KeyHash StakePool) StakePoolState)
      (Map (KeyHash StakePool) StakePoolState))
-> PState era
-> Const (Map (KeyHash StakePool) StakePoolState) (PState era)
forall era (f :: * -> *).
Functor f =>
(Map (KeyHash StakePool) StakePoolState
 -> f (Map (KeyHash StakePool) StakePoolState))
-> PState era -> f (PState era)
psStakePoolsL
    initialAccounts :: Accounts era
initialAccounts = NewEpochState era
nes NewEpochState era
-> Getting (Accounts era) (NewEpochState era) (Accounts era)
-> Accounts era
forall s a. s -> Getting a s a -> a
^. (EpochState era -> Const (Accounts era) (EpochState era))
-> NewEpochState era -> Const (Accounts era) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const (Accounts era) (EpochState era))
 -> NewEpochState era -> Const (Accounts era) (NewEpochState era))
-> ((Accounts era -> Const (Accounts era) (Accounts era))
    -> EpochState era -> Const (Accounts era) (EpochState era))
-> Getting (Accounts era) (NewEpochState era) (Accounts era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const (Accounts era) (LedgerState era))
-> EpochState era -> Const (Accounts era) (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const (Accounts era) (LedgerState era))
 -> EpochState era -> Const (Accounts era) (EpochState era))
-> ((Accounts era -> Const (Accounts era) (Accounts era))
    -> LedgerState era -> Const (Accounts era) (LedgerState era))
-> (Accounts era -> Const (Accounts era) (Accounts era))
-> EpochState era
-> Const (Accounts era) (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const (Accounts era) (CertState era))
-> LedgerState era -> Const (Accounts era) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const (Accounts era) (CertState era))
 -> LedgerState era -> Const (Accounts era) (LedgerState era))
-> ((Accounts era -> Const (Accounts era) (Accounts era))
    -> CertState era -> Const (Accounts era) (CertState era))
-> (Accounts era -> Const (Accounts era) (Accounts era))
-> LedgerState era
-> Const (Accounts era) (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Const (Accounts era) (DState era))
-> CertState era -> Const (Accounts era) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL ((DState era -> Const (Accounts era) (DState era))
 -> CertState era -> Const (Accounts era) (CertState era))
-> ((Accounts era -> Const (Accounts era) (Accounts era))
    -> DState era -> Const (Accounts era) (DState era))
-> (Accounts era -> Const (Accounts era) (Accounts era))
-> CertState era
-> Const (Accounts era) (CertState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Accounts era -> Const (Accounts era) (Accounts era))
-> DState era -> Const (Accounts era) (DState era)
forall era. Lens' (DState era) (Accounts era)
forall (t :: * -> *) era.
CanSetAccounts t =>
Lens' (t era) (Accounts era)
accountsL
    deposit :: CompactForm Coin
deposit = HasCallStack => Coin -> CompactForm Coin
Coin -> CompactForm Coin
compactCoinOrError (Coin -> CompactForm Coin) -> Coin -> CompactForm Coin
forall a b. (a -> b) -> a -> b
$ NewEpochState era
nes NewEpochState era -> Getting Coin (NewEpochState era) Coin -> Coin
forall s a. s -> Getting a s a -> a
^. (EpochState era -> Const Coin (EpochState era))
-> NewEpochState era -> Const Coin (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const Coin (EpochState era))
 -> NewEpochState era -> Const Coin (NewEpochState era))
-> ((Coin -> Const Coin Coin)
    -> EpochState era -> Const Coin (EpochState era))
-> Getting Coin (NewEpochState era) Coin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const Coin (PParams era))
-> EpochState era -> Const Coin (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams era)
Lens' (EpochState era) (PParams era)
curPParamsEpochStateL ((PParams era -> Const Coin (PParams era))
 -> EpochState era -> Const Coin (EpochState era))
-> ((Coin -> Const Coin Coin)
    -> PParams era -> Const Coin (PParams era))
-> (Coin -> Const Coin Coin)
-> EpochState era
-> Const Coin (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Const Coin Coin)
-> PParams era -> Const Coin (PParams era)
forall era.
(EraPParams era, HasCallStack) =>
Lens' (PParams era) Coin
Lens' (PParams era) Coin
ppKeyDepositL

    !(!Accounts era
updatedAccounts, !Map (KeyHash StakePool) StakePoolState
updatedStakePoolStates) =
      (((KeyHash Staking, KeyHash StakePool), Ptr)
 -> (Accounts era, Map (KeyHash StakePool) StakePoolState)
 -> (Accounts era, Map (KeyHash StakePool) StakePoolState))
-> (Accounts era, Map (KeyHash StakePool) StakePoolState)
-> [((KeyHash Staking, KeyHash StakePool), Ptr)]
-> (Accounts era, Map (KeyHash StakePool) StakePoolState)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((KeyHash Staking, KeyHash StakePool), Ptr)
-> (Accounts era, Map (KeyHash StakePool) StakePoolState)
-> (Accounts era, Map (KeyHash StakePool) StakePoolState)
registerAndDelegate (Accounts era
initialAccounts, Map (KeyHash StakePool) StakePoolState
stakePools) ([(KeyHash Staking, KeyHash StakePool)]
-> [Ptr] -> [((KeyHash Staking, KeyHash StakePool), Ptr)]
forall a b. [a] -> [b] -> [(a, b)]
zip (ListMap (KeyHash Staking) (KeyHash StakePool)
-> [(KeyHash Staking, KeyHash StakePool)]
forall k v. ListMap k v -> [(k, v)]
ListMap.toList ListMap (KeyHash Staking) (KeyHash StakePool)
sgsStake) [Ptr]
ptrs)
    registerAndDelegate :: ((KeyHash Staking, KeyHash StakePool), Ptr)
-> (Accounts era, Map (KeyHash StakePool) StakePoolState)
-> (Accounts era, Map (KeyHash StakePool) StakePoolState)
registerAndDelegate ((KeyHash Staking
stakeKeyHash, KeyHash StakePool
stakePool), Ptr
ptr) (!Accounts era
accounts, !Map (KeyHash StakePool) StakePoolState
stakePoolMap)
      | KeyHash StakePool
stakePool KeyHash StakePool -> Map (KeyHash StakePool) StakePoolState -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map (KeyHash StakePool) StakePoolState
stakePools =
          ( Credential Staking
-> Ptr
-> CompactForm Coin
-> Maybe (KeyHash StakePool)
-> Accounts era
-> Accounts era
forall era.
ShelleyEraAccounts era =>
Credential Staking
-> Ptr
-> CompactForm Coin
-> Maybe (KeyHash StakePool)
-> Accounts era
-> Accounts era
registerShelleyAccount (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
stakeKeyHash) Ptr
ptr CompactForm Coin
deposit (KeyHash StakePool -> Maybe (KeyHash StakePool)
forall a. a -> Maybe a
Just KeyHash StakePool
stakePool) Accounts era
accounts
          , (StakePoolState -> StakePoolState)
-> KeyHash StakePool
-> Map (KeyHash StakePool) StakePoolState
-> Map (KeyHash StakePool) StakePoolState
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust ((Set (Credential Staking) -> Identity (Set (Credential Staking)))
-> StakePoolState -> Identity StakePoolState
Lens' StakePoolState (Set (Credential Staking))
spsDelegatorsL ((Set (Credential Staking) -> Identity (Set (Credential Staking)))
 -> StakePoolState -> Identity StakePoolState)
-> (Set (Credential Staking) -> Set (Credential Staking))
-> StakePoolState
-> StakePoolState
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Credential Staking
-> Set (Credential Staking) -> Set (Credential Staking)
forall a. Ord a => a -> Set a -> Set a
Set.insert (KeyHash Staking -> Credential Staking
forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj KeyHash Staking
stakeKeyHash)) KeyHash StakePool
stakePool Map (KeyHash StakePool) StakePoolState
stakePoolMap
          )
      | Bool
otherwise =
          String -> (Accounts era, Map (KeyHash StakePool) StakePoolState)
forall a. HasCallStack => String -> a
error (String -> (Accounts era, Map (KeyHash StakePool) StakePoolState))
-> String -> (Accounts era, Map (KeyHash StakePool) StakePoolState)
forall a b. (a -> b) -> a -> b
$
            String
"Invariant of a delegation of "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ KeyHash Staking -> String
forall a. Show a => a -> String
show KeyHash Staking
stakeKeyHash
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to an unregistered stake pool "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ KeyHash StakePool -> String
forall a. Show a => a -> String
show KeyHash StakePool
stakePool
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is being violated."
    ptrs :: [Ptr]
ptrs =
      [ SlotNo32 -> TxIx -> CertIx -> Ptr
Ptr SlotNo32
forall a. Bounded a => a
minBound TxIx
txIx CertIx
certIx | TxIx
txIx <- [TxIx
forall a. Bounded a => a
minBound .. TxIx
forall a. Bounded a => a
maxBound], CertIx
certIx <- [CertIx
forall a. Bounded a => a
minBound .. CertIx
forall a. Bounded a => a
maxBound]
      ]

-- NOTE: it seems like this is only used for testing, so hardcoding `Testnet` as a Network for now

-- | Having initial funds, stake pools and accounts with delegations, we need to reset the stake
-- distribution, otherwise those initial stake pools will not be able to produce blocks
resetStakeDistribution ::
  (EraCertState era, EraStake era) =>
  NewEpochState era ->
  NewEpochState era
resetStakeDistribution :: forall era.
(EraCertState era, EraStake era) =>
NewEpochState era -> NewEpochState era
resetStakeDistribution NewEpochState era
nes =
  NewEpochState era
nes
    NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((SnapShot -> Identity SnapShot)
    -> EpochState era -> Identity (EpochState era))
-> (SnapShot -> Identity SnapShot)
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SnapShots -> Identity SnapShots)
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(SnapShots -> f SnapShots) -> EpochState era -> f (EpochState era)
esSnapshotsL ((SnapShots -> Identity SnapShots)
 -> EpochState era -> Identity (EpochState era))
-> ((SnapShot -> Identity SnapShot)
    -> SnapShots -> Identity SnapShots)
-> (SnapShot -> Identity SnapShot)
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SnapShot -> Identity SnapShot) -> SnapShots -> Identity SnapShots
Lens' SnapShots SnapShot
ssStakeMarkL ((SnapShot -> Identity SnapShot)
 -> NewEpochState era -> Identity (NewEpochState era))
-> SnapShot -> NewEpochState era -> NewEpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ SnapShot
initSnapShot
    NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (EpochState era -> Identity (EpochState era))
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Identity (EpochState era))
 -> NewEpochState era -> Identity (NewEpochState era))
-> ((PoolDistr -> Identity PoolDistr)
    -> EpochState era -> Identity (EpochState era))
-> (PoolDistr -> Identity PoolDistr)
-> NewEpochState era
-> Identity (NewEpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SnapShots -> Identity SnapShots)
-> EpochState era -> Identity (EpochState era)
forall era (f :: * -> *).
Functor f =>
(SnapShots -> f SnapShots) -> EpochState era -> f (EpochState era)
esSnapshotsL ((SnapShots -> Identity SnapShots)
 -> EpochState era -> Identity (EpochState era))
-> ((PoolDistr -> Identity PoolDistr)
    -> SnapShots -> Identity SnapShots)
-> (PoolDistr -> Identity PoolDistr)
-> EpochState era
-> Identity (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PoolDistr -> Identity PoolDistr)
-> SnapShots -> Identity SnapShots
Lens' SnapShots PoolDistr
ssStakeMarkPoolDistrL ((PoolDistr -> Identity PoolDistr)
 -> NewEpochState era -> Identity (NewEpochState era))
-> PoolDistr -> NewEpochState era -> NewEpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PoolDistr
poolDistr
    NewEpochState era
-> (NewEpochState era -> NewEpochState era) -> NewEpochState era
forall a b. a -> (a -> b) -> b
& (PoolDistr -> Identity PoolDistr)
-> NewEpochState era -> Identity (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(PoolDistr -> f PoolDistr)
-> NewEpochState era -> f (NewEpochState era)
nesPdL ((PoolDistr -> Identity PoolDistr)
 -> NewEpochState era -> Identity (NewEpochState era))
-> PoolDistr -> NewEpochState era -> NewEpochState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ PoolDistr
poolDistr
  where
    dState :: DState era
dState = NewEpochState era
nes NewEpochState era
-> Getting (DState era) (NewEpochState era) (DState era)
-> DState era
forall s a. s -> Getting a s a -> a
^. (EpochState era -> Const (DState era) (EpochState era))
-> NewEpochState era -> Const (DState era) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const (DState era) (EpochState era))
 -> NewEpochState era -> Const (DState era) (NewEpochState era))
-> ((DState era -> Const (DState era) (DState era))
    -> EpochState era -> Const (DState era) (EpochState era))
-> Getting (DState era) (NewEpochState era) (DState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const (DState era) (LedgerState era))
-> EpochState era -> Const (DState era) (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const (DState era) (LedgerState era))
 -> EpochState era -> Const (DState era) (EpochState era))
-> ((DState era -> Const (DState era) (DState era))
    -> LedgerState era -> Const (DState era) (LedgerState era))
-> (DState era -> Const (DState era) (DState era))
-> EpochState era
-> Const (DState era) (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const (DState era) (CertState era))
-> LedgerState era -> Const (DState era) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const (DState era) (CertState era))
 -> LedgerState era -> Const (DState era) (LedgerState era))
-> ((DState era -> Const (DState era) (DState era))
    -> CertState era -> Const (DState era) (CertState era))
-> (DState era -> Const (DState era) (DState era))
-> LedgerState era
-> Const (DState era) (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DState era -> Const (DState era) (DState era))
-> CertState era -> Const (DState era) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL
    pState :: PState era
pState = NewEpochState era
nes NewEpochState era
-> Getting (PState era) (NewEpochState era) (PState era)
-> PState era
forall s a. s -> Getting a s a -> a
^. (EpochState era -> Const (PState era) (EpochState era))
-> NewEpochState era -> Const (PState era) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const (PState era) (EpochState era))
 -> NewEpochState era -> Const (PState era) (NewEpochState era))
-> ((PState era -> Const (PState era) (PState era))
    -> EpochState era -> Const (PState era) (EpochState era))
-> Getting (PState era) (NewEpochState era) (PState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState era -> Const (PState era) (LedgerState era))
-> EpochState era -> Const (PState era) (EpochState era)
forall era (f :: * -> *).
Functor f =>
(LedgerState era -> f (LedgerState era))
-> EpochState era -> f (EpochState era)
esLStateL ((LedgerState era -> Const (PState era) (LedgerState era))
 -> EpochState era -> Const (PState era) (EpochState era))
-> ((PState era -> Const (PState era) (PState era))
    -> LedgerState era -> Const (PState era) (LedgerState era))
-> (PState era -> Const (PState era) (PState era))
-> EpochState era
-> Const (PState era) (EpochState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CertState era -> Const (PState era) (CertState era))
-> LedgerState era -> Const (PState era) (LedgerState era)
forall era (f :: * -> *).
Functor f =>
(CertState era -> f (CertState era))
-> LedgerState era -> f (LedgerState era)
lsCertStateL ((CertState era -> Const (PState era) (CertState era))
 -> LedgerState era -> Const (PState era) (LedgerState era))
-> ((PState era -> Const (PState era) (PState era))
    -> CertState era -> Const (PState era) (CertState era))
-> (PState era -> Const (PState era) (PState era))
-> LedgerState era
-> Const (PState era) (LedgerState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PState era -> Const (PState era) (PState era))
-> CertState era -> Const (PState era) (CertState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL
    poolDistr :: PoolDistr
poolDistr = SnapShot -> PoolDistr
calculatePoolDistr SnapShot
initSnapShot
    -- The new stake distribution is made on the basis of a snapshot taken
    -- during the previous epoch. We create a "fake" snapshot in order to
    -- establish an initial stake distribution.
    initSnapShot :: SnapShot
    initSnapShot :: SnapShot
initSnapShot =
      InstantStake era -> DState era -> PState era -> Network -> SnapShot
forall era.
EraStake era =>
InstantStake era -> DState era -> PState era -> Network -> SnapShot
snapShotFromInstantStake (UTxO era -> InstantStake era -> InstantStake era
forall era.
EraStake era =>
UTxO era -> InstantStake era -> InstantStake era
addInstantStake (NewEpochState era
nes NewEpochState era
-> Getting (UTxO era) (NewEpochState era) (UTxO era) -> UTxO era
forall s a. s -> Getting a s a -> a
^. Getting (UTxO era) (NewEpochState era) (UTxO era)
forall era. Lens' (NewEpochState era) (UTxO era)
forall (t :: * -> *) era. CanSetUTxO t => Lens' (t era) (UTxO era)
utxoL) InstantStake era
forall a. Monoid a => a
mempty) DState era
dState PState era
pState Network
Testnet

-- | Register the initial funds in the 'NewEpochState'.
--
-- HERE BE DRAGONS! This function is intended to help in testing.
--
-- In production, the genesis should /not/ contain any initial funds.
--
-- The given funds are /added/ to the existing UTxO.
--
-- PRECONDITION: the given funds must not be part of the existing UTxO.
-- > forall (addr, _) in initialFunds.
-- >    Map.notElem (initialFundsPseudoTxIn addr) existingUTxO
--
-- PROPERTY:
-- >    genesisUTxO genesis
-- > == <genesisUTxO'> (sgInitialFunds genesis)
-- > == <extractUTxO> (registerInitialFunds (sgInitialFunds genesis)
-- >                                        <empty NewEpochState>)
--
-- /Warning/ - Should only be used in testing and benchmarking. Will result in an error
-- when NetworkId is set to Mainnet
registerInitialFunds ::
  forall era.
  ( EraTransition era
  , HasCallStack
  ) =>
  TransitionConfig era ->
  NewEpochState era ->
  NewEpochState era
registerInitialFunds :: forall era.
(EraTransition era, HasCallStack) =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialFunds TransitionConfig era
tc NewEpochState era
nes =
  NewEpochState era
nes
    { nesEs =
        epochState
          { esChainAccountState = accountState'
          , esLState = ledgerState'
          }
    }
  where
    epochState :: EpochState era
epochState = NewEpochState era -> EpochState era
forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    accountState :: ChainAccountState
accountState = EpochState era -> ChainAccountState
forall era. EpochState era -> ChainAccountState
esChainAccountState EpochState era
epochState
    ledgerState :: LedgerState era
ledgerState = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
epochState
    utxoState :: UTxOState era
utxoState = LedgerState era -> UTxOState era
forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ledgerState
    utxo :: UTxO era
utxo = UTxOState era -> UTxO era
forall era. UTxOState era -> UTxO era
utxosUtxo UTxOState era
utxoState

    initialFundsUtxo :: UTxO era
    initialFundsUtxo :: UTxO era
initialFundsUtxo =
      Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (Map TxIn (TxOut era) -> UTxO era)
-> Map TxIn (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$
        [(TxIn, TxOut era)] -> Map TxIn (TxOut era)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (TxIn
txIn, TxOut era
txOut)
          | (Addr
addr, Coin
amount) <- ListMap Addr Coin -> [(Addr, Coin)]
forall k v. ListMap k v -> [(k, v)]
ListMap.toList (TransitionConfig era
tc TransitionConfig era
-> Getting
     (ListMap Addr Coin) (TransitionConfig era) (ListMap Addr Coin)
-> ListMap Addr Coin
forall s a. s -> Getting a s a -> a
^. Getting
  (ListMap Addr Coin) (TransitionConfig era) (ListMap Addr Coin)
forall era.
(HasCallStack, EraTransition era) =>
Lens' (TransitionConfig era) (ListMap Addr Coin)
Lens' (TransitionConfig era) (ListMap Addr Coin)
tcInitialFundsL)
          , let txIn :: TxIn
txIn = Addr -> TxIn
initialFundsPseudoTxIn Addr
addr
                txOut :: TxOut era
txOut = Addr -> Value era -> TxOut era
forall era.
(EraTxOut era, HasCallStack) =>
Addr -> Value era -> TxOut era
mkBasicTxOut Addr
addr (Coin -> Value era
forall t s. Inject t s => t -> s
inject Coin
amount)
          ]

    utxo' :: UTxO era
utxo' = HasCallStack => UTxO era -> UTxO era -> UTxO era
UTxO era -> UTxO era -> UTxO era
mergeUtxoNoOverlap UTxO era
utxo UTxO era
initialFundsUtxo

    -- Update the reserves
    accountState' :: ChainAccountState
accountState' =
      ChainAccountState
accountState
        { casReserves = casReserves accountState <-> sumCoinUTxO initialFundsUtxo
        }

    ledgerState' :: LedgerState era
ledgerState' =
      LedgerState era
ledgerState
        { lsUTxOState =
            utxoState
              { utxosUtxo = utxo'
              , -- Normally we would incrementally update here. But since we pass
                -- the full UTxO as "toAdd" rather than a delta, we simply
                -- reinitialise the full instant stake.
                utxosInstantStake = addInstantStake utxo' mempty
              }
        }

    -- Merge two UTxOs, throw an 'error' in case of overlap
    mergeUtxoNoOverlap ::
      HasCallStack =>
      UTxO era ->
      UTxO era ->
      UTxO era
    mergeUtxoNoOverlap :: HasCallStack => UTxO era -> UTxO era -> UTxO era
mergeUtxoNoOverlap (UTxO Map TxIn (TxOut era)
m1) (UTxO Map TxIn (TxOut era)
m2) =
      Map TxIn (TxOut era) -> UTxO era
forall era. Map TxIn (TxOut era) -> UTxO era
UTxO (Map TxIn (TxOut era) -> UTxO era)
-> Map TxIn (TxOut era) -> UTxO era
forall a b. (a -> b) -> a -> b
$
        (TxIn -> TxOut era -> TxOut era -> TxOut era)
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
-> Map TxIn (TxOut era)
forall k a.
Ord k =>
(k -> a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWithKey
          (\TxIn
k TxOut era
_ TxOut era
_ -> String -> TxOut era
forall a. HasCallStack => String -> a
error (String -> TxOut era) -> String -> TxOut era
forall a b. (a -> b) -> a -> b
$ String
"initial fund part of UTxO: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TxIn -> String
forall a. Show a => a -> String
show TxIn
k)
          Map TxIn (TxOut era)
m1
          Map TxIn (TxOut era)
m2