{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# 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 (..),
  tcInitialFundsL,
  tcInitialStakingL,
  mkShelleyTransitionConfig,
  createInitialState,
  registerInitialFundsThenStaking,
  toShelleyTransitionConfigPairs,
  protectMainnet,
  protectMainnetLens,
) where

import Cardano.Ledger.Address
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.CertState
import Cardano.Ledger.Coin
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Cardano.Ledger.EpochBoundary
import Cardano.Ledger.Genesis (EraGenesis)
import Cardano.Ledger.Keys
import Cardano.Ledger.PoolDistr
import Cardano.Ledger.Shelley.Era
import Cardano.Ledger.Shelley.Genesis
import Cardano.Ledger.Shelley.Governance
import Cardano.Ledger.Shelley.LedgerState
import Cardano.Ledger.Shelley.Translation (
  FromByronTranslationContext (..),
  toFromByronTranslationContext,
 )
import qualified Cardano.Ledger.UMap as UM
import Cardano.Ledger.UTxO
import Cardano.Ledger.Val
import Data.Aeson (FromJSON (..), KeyValue (..), ToJSON (..), object, pairs, withObject, (.:))
import Data.Default
import Data.Kind
import qualified Data.ListMap as LM
import qualified Data.ListMap as ListMap
import qualified Data.Map.Strict as Map
import Data.Void (Void)
import GHC.Generics (Generic)
import GHC.Stack
import Lens.Micro
import NoThunks.Class (NoThunks (..))

class
  ( EraTxOut era
  , EraGov era
  , EraGenesis era
  , ToJSON (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 = forall era.
(EraTransition era, EraTransition (PreviousEra era)) =>
Lens' (TransitionConfig era) (TransitionConfig (PreviousEra era))
tcPreviousEraConfigL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTransition era =>
Lens' (TransitionConfig 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 =
    forall s a. (s -> a) -> SimpleGetter s a
to forall a b. (a -> b) -> a -> b
$ \TransitionConfig era
tc ->
      forall era (f :: * -> *).
(TranslateEra era f, TranslationError era f ~ Void) =>
TranslationContext era -> f (PreviousEra era) -> f era
translateEra'
        (TransitionConfig era
tc forall s a. s -> Getting a s a -> a
^. forall era.
EraTransition era =>
Lens' (TransitionConfig era) (TranslationContext era)
tcTranslationContextL)
        (TransitionConfig era
tc forall s a. s -> Getting a s a -> a
^. forall era.
(EraTransition era, EraTransition (PreviousEra era)) =>
Lens' (TransitionConfig era) (TransitionConfig (PreviousEra era))
tcPreviousEraConfigL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era.
EraTransition era =>
SimpleGetter (TransitionConfig era) (PParams era)
tcInitialPParamsG)

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

registerInitialFundsThenStaking ::
  EraTransition era =>
  TransitionConfig era ->
  NewEpochState era ->
  NewEpochState era
registerInitialFundsThenStaking :: forall era.
EraTransition era =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialFundsThenStaking TransitionConfig era
cfg =
  -- We must first register the initial funds, because the stake
  -- information depends on it.
  forall era.
(HasCallStack, EraTransition era) =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialStaking TransitionConfig era
cfg forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransitionConfig ShelleyEra -> TransitionConfig ShelleyEra -> Bool
$c/= :: TransitionConfig ShelleyEra -> TransitionConfig ShelleyEra -> Bool
== :: TransitionConfig ShelleyEra -> TransitionConfig ShelleyEra -> Bool
$c== :: TransitionConfig ShelleyEra -> TransitionConfig ShelleyEra -> Bool
Eq, Int -> TransitionConfig ShelleyEra -> ShowS
[TransitionConfig ShelleyEra] -> ShowS
TransitionConfig ShelleyEra -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransitionConfig ShelleyEra] -> ShowS
$cshowList :: [TransitionConfig ShelleyEra] -> ShowS
show :: TransitionConfig ShelleyEra -> String
$cshow :: TransitionConfig ShelleyEra -> String
showsPrec :: Int -> TransitionConfig ShelleyEra -> ShowS
$cshowsPrec :: Int -> TransitionConfig ShelleyEra -> ShowS
Show, 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
$cto :: forall x.
Rep (TransitionConfig ShelleyEra) x -> TransitionConfig ShelleyEra
$cfrom :: forall x.
TransitionConfig ShelleyEra -> Rep (TransitionConfig ShelleyEra) x
Generic)

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

  injectIntoTestState :: TransitionConfig ShelleyEra
-> NewEpochState ShelleyEra -> NewEpochState ShelleyEra
injectIntoTestState = forall era.
EraTransition era =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialFundsThenStaking

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

  tcTranslationContextL :: Lens' (TransitionConfig ShelleyEra) (TranslationContext ShelleyEra)
tcTranslationContextL =
    forall era.
EraTransition era =>
Lens' (TransitionConfig era) ShelleyGenesis
tcShelleyGenesisL forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 'Genesis) GenDelegPair
PParams ShelleyEra
fbtcMaxLovelaceSupply :: FromByronTranslationContext -> Word64
fbtcProtocolParams :: FromByronTranslationContext -> PParams ShelleyEra
fbtcGenDelegs :: FromByronTranslationContext -> Map (KeyHash 'Genesis) GenDelegPair
fbtcMaxLovelaceSupply :: Word64
fbtcProtocolParams :: PParams ShelleyEra
fbtcGenDelegs :: Map (KeyHash 'Genesis) GenDelegPair
..} =
        ShelleyGenesis
shelleyGenesis
          { sgGenDelegs :: Map (KeyHash 'Genesis) GenDelegPair
sgGenDelegs = Map (KeyHash 'Genesis) GenDelegPair
fbtcGenDelegs
          , sgProtocolParams :: PParams ShelleyEra
sgProtocolParams = PParams ShelleyEra
fbtcProtocolParams
          , sgMaxLovelaceSupply :: Word64
sgMaxLovelaceSupply = Word64
fbtcMaxLovelaceSupply
          }

  tcShelleyGenesisL :: Lens' (TransitionConfig ShelleyEra) ShelleyGenesis
tcShelleyGenesisL = 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 :: ShelleyGenesis
stcShelleyGenesis = ShelleyGenesis
sg})

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

-- | 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) (LM.ListMap Addr Coin)
tcInitialFundsL :: forall era.
(HasCallStack, EraTransition era) =>
Lens' (TransitionConfig era) (ListMap Addr Coin)
tcInitialFundsL =
  forall era a.
(HasCallStack, EraTransition era) =>
String
-> (a -> Bool)
-> Lens' (TransitionConfig era) a
-> Lens' (TransitionConfig era) a
protectMainnetLens String
"InitialFunds" forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$
    forall era.
EraTransition era =>
Lens' (TransitionConfig era) ShelleyGenesis
tcShelleyGenesisL forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
  forall era a.
(HasCallStack, EraTransition era) =>
String
-> (a -> Bool)
-> Lens' (TransitionConfig era) a
-> Lens' (TransitionConfig era) a
protectMainnetLens String
"InitialStaking" (forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty) forall a b. (a -> b) -> a -> b
$
    forall era.
EraTransition era =>
Lens' (TransitionConfig era) ShelleyGenesis
tcShelleyGenesisL forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
  forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    (\TransitionConfig era
g -> forall era a.
(HasCallStack, EraTransition era) =>
String -> TransitionConfig era -> (a -> Bool) -> a -> a
protectMainnet String
name TransitionConfig era
g a -> Bool
isMainnetSafe forall a b. (a -> b) -> a -> b
$ TransitionConfig era
g forall s a. s -> Getting a s a -> a
^. Lens' (TransitionConfig era) a
l)
    (\TransitionConfig era
g a
x -> TransitionConfig era
g forall a b. a -> (a -> b) -> b
& Lens' (TransitionConfig era) a
l 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 forall s a. s -> Getting a s a -> a
^. forall era.
EraTransition era =>
SimpleGetter (TransitionConfig era) Network
tcNetworkIDG forall a. Eq a => a -> a -> Bool
== Network
Mainnet Bool -> Bool -> Bool
&& Bool -> Bool
not (a -> Bool
isMainnetSafe a
m)
    then forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Injection of " forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
" is not possible on Mainnet"
    else a
m

deriving instance NoThunks (TransitionConfig ShelleyEra)

instance ToJSON (TransitionConfig ShelleyEra) where
  toJSON :: TransitionConfig ShelleyEra -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. KeyValue e a => TransitionConfig ShelleyEra -> [a]
toShelleyTransitionConfigPairs
  toEncoding :: TransitionConfig ShelleyEra -> Encoding
toEncoding = Series -> Encoding
pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. KeyValue e a => TransitionConfig ShelleyEra -> [a]
toShelleyTransitionConfigPairs

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

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

-- | 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 =
  forall era a.
(HasCallStack, EraTransition era) =>
String -> TransitionConfig era -> (a -> Bool) -> a -> a
protectMainnet
    String
"InitialState"
    TransitionConfig era
tc
    (forall a b. a -> b -> a
const Bool
False)
    NewEpochState
      { nesEL :: EpochNo
nesEL = EpochNo
initialEpochNo
      , nesBprev :: BlocksMade
nesBprev = Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade forall k a. Map k a
Map.empty
      , nesBcur :: BlocksMade
nesBcur = Map (KeyHash 'StakePool) Natural -> BlocksMade
BlocksMade forall k a. Map k a
Map.empty
      , nesEs :: EpochState era
nesEs =
          EpochState
            { esAccountState :: AccountState
esAccountState = Coin -> Coin -> AccountState
AccountState forall t. Val t => t
zero Coin
reserves
            , esSnapshots :: SnapShots
esSnapshots = SnapShots
emptySnapShots
            , esLState :: LedgerState era
esLState =
                LedgerState
                  { lsUTxOState :: UTxOState era
lsUTxOState =
                      forall era.
EraTxOut era =>
PParams era
-> UTxO era
-> Coin
-> Coin
-> GovState era
-> Coin
-> UTxOState era
smartUTxOState PParams era
pp UTxO era
initialUtxo forall t. Val t => t
zero forall t. Val t => t
zero GovState era
govState forall t. Val t => t
zero
                  , lsCertState :: CertState era
lsCertState =
                      CertState
                        { certDState :: DState era
certDState = DState era
dState {dsGenDelegs :: GenDelegs
dsGenDelegs = Map (KeyHash 'Genesis) GenDelegPair -> GenDelegs
GenDelegs (ShelleyGenesis -> Map (KeyHash 'Genesis) GenDelegPair
sgGenDelegs ShelleyGenesis
sg)}
                        , certPState :: PState era
certPState = forall a. Default a => a
def
                        , certVState :: VState era
certVState = forall a. Default a => a
def
                        }
                  }
            , esNonMyopic :: NonMyopic
esNonMyopic = forall a. Default a => a
def
            }
      , nesRu :: StrictMaybe PulsingRewUpdate
nesRu = forall a. StrictMaybe a
SNothing
      , nesPd :: PoolDistr
nesPd = Map (KeyHash 'StakePool) IndividualPoolStake
-> CompactForm Coin -> PoolDistr
PoolDistr forall k a. Map k a
Map.empty forall a. Monoid a => a
mempty
      , stashedAVVMAddresses :: StashedAVVMAddresses era
stashedAVVMAddresses = forall a. Default a => a
def
      }
  where
    dState :: DState era
    dState :: DState era
dState = forall a. Default a => a
def
    govState :: GovState era
    govState :: GovState era
govState =
      forall era. EraGov era => GovState era
emptyGovState
        forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (GovState era) (PParams era)
curPParamsGovStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ PParams era
pp
        forall a b. a -> (a -> b) -> b
& forall era. EraGov era => Lens' (GovState era) (PParams era)
prevPParamsGovStateL 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 forall s a. s -> Getting a s a -> a
^. forall era.
EraTransition era =>
SimpleGetter (TransitionConfig era) (PParams era)
tcInitialPParamsG
    sg :: ShelleyGenesis
    sg :: ShelleyGenesis
sg = TransitionConfig era
tc forall s a. s -> Getting a s a -> a
^. forall era.
EraTransition era =>
Lens' (TransitionConfig era) ShelleyGenesis
tcShelleyGenesisL
    initialEpochNo :: EpochNo
    initialEpochNo :: EpochNo
initialEpochNo = Word64 -> EpochNo
EpochNo Word64
0
    initialUtxo :: UTxO era
    initialUtxo :: UTxO era
initialUtxo = forall a. Monoid a => a
mempty
    reserves :: Coin
    reserves :: Coin
reserves = Word64 -> Coin
word64ToCoin (ShelleyGenesis -> Word64
sgMaxLovelaceSupply ShelleyGenesis
sg) forall t. Val t => t -> t -> t
<-> forall era. EraTxOut era => UTxO era -> Coin
coinBalance UTxO era
initialUtxo

-- | Register the initial staking information in the 'NewEpochState'.
--
-- HERE BE DRAGONS! This function is intended to help in testing.
--
-- In production, the genesis should /not/ contain any initial staking.
--
-- Any existing staking information is overridden, but the UTxO is left
-- untouched.
--
-- /Warning/ - Should only be used in testing and benchmarking. Will result in an error
-- when NetworkId is set to Mainnet
registerInitialStaking ::
  forall era.
  (HasCallStack, EraTransition era) =>
  TransitionConfig era ->
  NewEpochState era ->
  NewEpochState era
registerInitialStaking :: forall era.
(HasCallStack, EraTransition era) =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialStaking TransitionConfig era
tc NewEpochState era
nes =
  NewEpochState era
nes
    { nesEs :: EpochState era
nesEs =
        EpochState era
epochState
          { esLState :: LedgerState era
esLState =
              LedgerState era
ledgerState
                { lsCertState :: CertState era
lsCertState =
                    CertState era
dpState
                      { certDState :: DState era
certDState = DState era
dState'
                      , certPState :: PState era
certPState = PState era
pState'
                      }
                }
          , esSnapshots :: SnapShots
esSnapshots =
              (forall era. EpochState era -> SnapShots
esSnapshots EpochState era
epochState)
                { $sel:ssStakeMark:SnapShots :: SnapShot
ssStakeMark = SnapShot
initSnapShot
                , $sel:ssStakeMarkPoolDistr:SnapShots :: PoolDistr
ssStakeMarkPoolDistr = SnapShot -> PoolDistr
calculatePoolDistr SnapShot
initSnapShot
                }
          }
    , -- Note that this is only applicable in the initial configuration where
      -- there is no existing stake distribution, since it would completely
      -- overwrite any such thing.
      nesPd :: PoolDistr
nesPd = SnapShot -> PoolDistr
calculatePoolDistr SnapShot
initSnapShot
    }
  where
    ShelleyGenesisStaking {ListMap (KeyHash 'StakePool) PoolParams
sgsPools :: ShelleyGenesisStaking -> ListMap (KeyHash 'StakePool) PoolParams
sgsPools :: ListMap (KeyHash 'StakePool) PoolParams
sgsPools, ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStake :: ShelleyGenesisStaking
-> ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStake :: ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStake} = TransitionConfig era
tc forall s a. s -> Getting a s a -> a
^. forall era.
(HasCallStack, EraTransition era) =>
Lens' (TransitionConfig era) ShelleyGenesisStaking
tcInitialStakingL
    NewEpochState {nesEs :: forall era. NewEpochState era -> EpochState era
nesEs = EpochState era
epochState} = NewEpochState era
nes
    ledgerState :: LedgerState era
ledgerState = forall era. EpochState era -> LedgerState era
esLState EpochState era
epochState
    dpState :: CertState era
dpState = forall era. LedgerState era -> CertState era
lsCertState LedgerState era
ledgerState

    -- New delegation state. Since we're using base addresses, we only care
    -- about updating the '_delegations' field.
    --
    -- See STS DELEG for details
    dState' :: DState era
    dState' :: DState era
dState' =
      (forall era. CertState era -> DState era
certDState CertState era
dpState)
        { dsUnified :: UMap
dsUnified =
            Map (Credential 'Staking) RDPair
-> Map Ptr (Credential 'Staking)
-> Map (Credential 'Staking) (KeyHash 'StakePool)
-> Map (Credential 'Staking) DRep
-> UMap
UM.unify
              ( forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ CompactForm Coin -> CompactForm Coin -> RDPair
UM.RDPair (Word64 -> CompactForm Coin
CompactCoin Word64
0) (Word64 -> CompactForm Coin
CompactCoin Word64
0))
                  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj
                  forall a b. (a -> b) -> a -> b
$ Map (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStakeMap
              )
              forall a. Monoid a => a
mempty
              (forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys forall (kr :: KeyRole). KeyHash kr -> Credential kr
KeyHashObj Map (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStakeMap)
              forall a. Monoid a => a
mempty
        }
      where
        sgsStakeMap :: Map (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStakeMap = forall k v. Ord k => ListMap k v -> Map k v
ListMap.toMap ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStake

    -- We consider pools as having been registered in slot 0
    -- See STS POOL for details
    pState' :: PState era
    pState' :: PState era
pState' =
      (forall era. CertState era -> PState era
certPState CertState era
dpState)
        { psStakePoolParams :: Map (KeyHash 'StakePool) PoolParams
psStakePoolParams = forall k v. Ord k => ListMap k v -> Map k v
ListMap.toMap ListMap (KeyHash 'StakePool) PoolParams
sgsPools
        }

    pp :: PParams era
pp = NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL

    -- 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 =
      -- Since we build a stake from nothing, we first initialise an
      -- 'IncrementalStake' as empty, and then:
      --
      -- 1. Add the initial UTxO, whilst deleting nothing.
      -- 2. Update the stake map given the initial delegation.
      forall era.
EraPParams era =>
PParams era
-> IncrementalStake -> DState era -> PState era -> SnapShot
incrementalStakeDistr
        PParams era
pp
        -- Note that 'updateStakeDistribution' takes first the set of UTxO to
        -- delete, and then the set to add. In our case, there is nothing to
        -- delete, since this is an initial UTxO set.
        (forall era.
EraTxOut era =>
PParams era
-> IncrementalStake -> UTxO era -> UTxO era -> IncrementalStake
updateStakeDistribution PParams era
pp forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty (forall era. UTxOState era -> UTxO era
utxosUtxo (forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ledgerState)))
        DState era
dState'
        PState era
pState'

-- | 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 era
nesEs =
        EpochState era
epochState
          { esAccountState :: AccountState
esAccountState = AccountState
accountState'
          , esLState :: LedgerState era
esLState = LedgerState era
ledgerState'
          }
    }
  where
    epochState :: EpochState era
epochState = forall era. NewEpochState era -> EpochState era
nesEs NewEpochState era
nes
    accountState :: AccountState
accountState = forall era. EpochState era -> AccountState
esAccountState EpochState era
epochState
    ledgerState :: LedgerState era
ledgerState = forall era. EpochState era -> LedgerState era
esLState EpochState era
epochState
    utxoState :: UTxOState era
utxoState = forall era. LedgerState era -> UTxOState era
lsUTxOState LedgerState era
ledgerState
    utxo :: UTxO era
utxo = forall era. UTxOState era -> UTxO era
utxosUtxo UTxOState era
utxoState
    reserves :: Coin
reserves = AccountState -> Coin
asReserves AccountState
accountState

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

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

    -- Update the reserves
    accountState' :: AccountState
accountState' =
      AccountState
accountState
        { asReserves :: Coin
asReserves = Coin
reserves forall t. Val t => t -> t -> t
<-> forall t. Val t => t -> Coin
coin (forall era. EraTxOut era => UTxO era -> Value era
balance UTxO era
initialFundsUtxo)
        }

    -- Since we only add entries to our UTxO, rather than spending them, there
    -- is nothing to delete in the incremental update.
    utxoToDel :: UTxO era
utxoToDel = forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall a. Monoid a => a
mempty
    ledgerState' :: LedgerState era
ledgerState' =
      LedgerState era
ledgerState
        { lsUTxOState :: UTxOState era
lsUTxOState =
            UTxOState era
utxoState
              { utxosUtxo :: UTxO era
utxosUtxo = UTxO era
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 incremental stake.
                utxosStakeDistr :: IncrementalStake
utxosStakeDistr =
                  forall era.
EraTxOut era =>
PParams era
-> IncrementalStake -> UTxO era -> UTxO era -> IncrementalStake
updateStakeDistribution
                    (NewEpochState era
nes forall s a. s -> Getting a s a -> a
^. forall era. Lens' (NewEpochState era) (EpochState era)
nesEsL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraGov era => Lens' (EpochState era) (PParams era)
curPParamsEpochStateL)
                    forall a. Monoid a => a
mempty
                    forall {era}. UTxO era
utxoToDel
                    UTxO era
utxo'
              }
        }

    -- 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) =
      forall era. Map TxIn (TxOut era) -> UTxO era
UTxO forall a b. (a -> b) -> a -> b
$
        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
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"initial fund part of UTxO: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show TxIn
k)
          Map TxIn (TxOut era)
m1
          Map TxIn (TxOut era)
m2