{-# 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 #-}
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.Crypto
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.Class
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
data TransitionConfig era :: Type
mkTransitionConfig ::
TranslationContext era ->
TransitionConfig (PreviousEra era) ->
TransitionConfig era
injectIntoTestState ::
TransitionConfig era ->
NewEpochState era ->
NewEpochState era
tcPreviousEraConfigL ::
EraTransition (PreviousEra era) =>
Lens' (TransitionConfig era) (TransitionConfig (PreviousEra era))
tcTranslationContextL ::
Lens' (TransitionConfig era) (TranslationContext era)
tcShelleyGenesisL :: Lens' (TransitionConfig era) (ShelleyGenesis (EraCrypto era))
default tcShelleyGenesisL ::
(EraTransition (PreviousEra era), EraCrypto (PreviousEra era) ~ EraCrypto era) =>
Lens' (TransitionConfig era) (ShelleyGenesis (EraCrypto era))
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 (EraCrypto era))
tcShelleyGenesisL
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 (EraCrypto era))
tcShelleyGenesisL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. (s -> a) -> SimpleGetter s a
to forall c. ShelleyGenesis c -> 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 =
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 Crypto c => EraTransition (ShelleyEra c) where
newtype TransitionConfig (ShelleyEra c) = ShelleyTransitionConfig
{ forall c. TransitionConfig (ShelleyEra c) -> ShelleyGenesis c
stcShelleyGenesis :: ShelleyGenesis c
}
deriving (TransitionConfig (ShelleyEra c)
-> TransitionConfig (ShelleyEra c) -> Bool
forall c.
Crypto c =>
TransitionConfig (ShelleyEra c)
-> TransitionConfig (ShelleyEra c) -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TransitionConfig (ShelleyEra c)
-> TransitionConfig (ShelleyEra c) -> Bool
$c/= :: forall c.
Crypto c =>
TransitionConfig (ShelleyEra c)
-> TransitionConfig (ShelleyEra c) -> Bool
== :: TransitionConfig (ShelleyEra c)
-> TransitionConfig (ShelleyEra c) -> Bool
$c== :: forall c.
Crypto c =>
TransitionConfig (ShelleyEra c)
-> TransitionConfig (ShelleyEra c) -> Bool
Eq, Int -> TransitionConfig (ShelleyEra c) -> ShowS
forall c.
Crypto c =>
Int -> TransitionConfig (ShelleyEra c) -> ShowS
forall c. Crypto c => [TransitionConfig (ShelleyEra c)] -> ShowS
forall c. Crypto c => TransitionConfig (ShelleyEra c) -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransitionConfig (ShelleyEra c)] -> ShowS
$cshowList :: forall c. Crypto c => [TransitionConfig (ShelleyEra c)] -> ShowS
show :: TransitionConfig (ShelleyEra c) -> String
$cshow :: forall c. Crypto c => TransitionConfig (ShelleyEra c) -> String
showsPrec :: Int -> TransitionConfig (ShelleyEra c) -> ShowS
$cshowsPrec :: forall c.
Crypto c =>
Int -> TransitionConfig (ShelleyEra c) -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall c x.
Rep (TransitionConfig (ShelleyEra c)) x
-> TransitionConfig (ShelleyEra c)
forall c x.
TransitionConfig (ShelleyEra c)
-> Rep (TransitionConfig (ShelleyEra c)) x
$cto :: forall c x.
Rep (TransitionConfig (ShelleyEra c)) x
-> TransitionConfig (ShelleyEra c)
$cfrom :: forall c x.
TransitionConfig (ShelleyEra c)
-> Rep (TransitionConfig (ShelleyEra c)) x
Generic)
mkTransitionConfig :: TranslationContext (ShelleyEra c)
-> TransitionConfig (PreviousEra (ShelleyEra c))
-> TransitionConfig (ShelleyEra c)
mkTransitionConfig =
forall a. HasCallStack => String -> a
error String
"Impossible: There is no EraTransition instance for ByronEra"
injectIntoTestState :: TransitionConfig (ShelleyEra c)
-> NewEpochState (ShelleyEra c) -> NewEpochState (ShelleyEra c)
injectIntoTestState = forall era.
EraTransition era =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialFundsThenStaking
tcPreviousEraConfigL :: EraTransition (PreviousEra (ShelleyEra c)) =>
Lens'
(TransitionConfig (ShelleyEra c))
(TransitionConfig (PreviousEra (ShelleyEra c)))
tcPreviousEraConfigL = forall a b. HasCallStack => Lens' a b
notSupportedInThisEraL
tcTranslationContextL :: Lens'
(TransitionConfig (ShelleyEra c))
(TranslationContext (ShelleyEra c))
tcTranslationContextL =
forall era.
EraTransition era =>
Lens' (TransitionConfig era) (ShelleyGenesis (EraCrypto era))
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 forall c. ShelleyGenesis c -> FromByronTranslationContext c
toFromByronTranslationContext forall {c}.
ShelleyGenesis c
-> FromByronTranslationContext c -> ShelleyGenesis c
setFBTC
where
setFBTC :: ShelleyGenesis c
-> FromByronTranslationContext c -> ShelleyGenesis c
setFBTC ShelleyGenesis c
shelleyGenesis FromByronTranslationContext {Word64
Map (KeyHash 'Genesis c) (GenDelegPair c)
PParams (ShelleyEra c)
fbtcMaxLovelaceSupply :: forall c. FromByronTranslationContext c -> Word64
fbtcProtocolParams :: forall c. FromByronTranslationContext c -> PParams (ShelleyEra c)
fbtcGenDelegs :: forall c.
FromByronTranslationContext c
-> Map (KeyHash 'Genesis c) (GenDelegPair c)
fbtcMaxLovelaceSupply :: Word64
fbtcProtocolParams :: PParams (ShelleyEra c)
fbtcGenDelegs :: Map (KeyHash 'Genesis c) (GenDelegPair c)
..} =
ShelleyGenesis c
shelleyGenesis
{ sgGenDelegs :: Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs = Map (KeyHash 'Genesis c) (GenDelegPair c)
fbtcGenDelegs
, sgProtocolParams :: PParams (ShelleyEra c)
sgProtocolParams = PParams (ShelleyEra c)
fbtcProtocolParams
, sgMaxLovelaceSupply :: Word64
sgMaxLovelaceSupply = Word64
fbtcMaxLovelaceSupply
}
tcShelleyGenesisL :: Lens'
(TransitionConfig (ShelleyEra c))
(ShelleyGenesis (EraCrypto (ShelleyEra c)))
tcShelleyGenesisL = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall c. TransitionConfig (ShelleyEra c) -> ShelleyGenesis c
stcShelleyGenesis (\TransitionConfig (ShelleyEra c)
tc ShelleyGenesis c
sg -> TransitionConfig (ShelleyEra c)
tc {stcShelleyGenesis :: ShelleyGenesis c
stcShelleyGenesis = ShelleyGenesis c
sg})
tcInitialPParamsG :: SimpleGetter
(TransitionConfig (ShelleyEra c)) (PParams (ShelleyEra c))
tcInitialPParamsG = forall s a. (s -> a) -> SimpleGetter s a
to (forall c. ShelleyGenesis c -> PParams (ShelleyEra c)
sgProtocolParams forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. TransitionConfig (ShelleyEra c) -> ShelleyGenesis c
stcShelleyGenesis)
tcInitialFundsL ::
(HasCallStack, EraTransition era) =>
Lens' (TransitionConfig era) (LM.ListMap (Addr (EraCrypto era)) Coin)
tcInitialFundsL :: forall era.
(HasCallStack, EraTransition era) =>
Lens' (TransitionConfig era) (ListMap (Addr (EraCrypto era)) 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 (EraCrypto era))
tcShelleyGenesisL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Lens' (ShelleyGenesis c) (ListMap (Addr c) Coin)
sgInitialFundsL
tcInitialStakingL ::
(HasCallStack, EraTransition era) =>
Lens' (TransitionConfig era) (ShelleyGenesisStaking (EraCrypto era))
tcInitialStakingL :: forall era.
(HasCallStack, EraTransition era) =>
Lens'
(TransitionConfig era) (ShelleyGenesisStaking (EraCrypto era))
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 (EraCrypto era))
tcShelleyGenesisL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall c. Lens' (ShelleyGenesis c) (ShelleyGenesisStaking c)
sgStakingL
mkShelleyTransitionConfig :: ShelleyGenesis c -> TransitionConfig (ShelleyEra c)
mkShelleyTransitionConfig :: forall c. ShelleyGenesis c -> TransitionConfig (ShelleyEra c)
mkShelleyTransitionConfig = forall c. ShelleyGenesis c -> TransitionConfig (ShelleyEra c)
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 Crypto c => NoThunks (TransitionConfig (ShelleyEra c))
instance Crypto c => ToJSON (TransitionConfig (ShelleyEra c)) where
toJSON :: TransitionConfig (ShelleyEra c) -> Value
toJSON = [Pair] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a c.
(KeyValue e a, Crypto c) =>
TransitionConfig (ShelleyEra c) -> [a]
toShelleyTransitionConfigPairs
toEncoding :: TransitionConfig (ShelleyEra c) -> 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 c.
(KeyValue e a, Crypto c) =>
TransitionConfig (ShelleyEra c) -> [a]
toShelleyTransitionConfigPairs
instance Crypto c => FromJSON (TransitionConfig (ShelleyEra c)) where
parseJSON :: Value -> Parser (TransitionConfig (ShelleyEra c))
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"ShelleyTransitionConfig" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
ShelleyGenesis c
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 c
stcShelleyGenesis = ShelleyGenesis c
sg}
toShelleyTransitionConfigPairs ::
(KeyValue e a, Crypto c) =>
TransitionConfig (ShelleyEra c) ->
[a]
toShelleyTransitionConfigPairs :: forall e a c.
(KeyValue e a, Crypto c) =>
TransitionConfig (ShelleyEra c) -> [a]
toShelleyTransitionConfigPairs stc :: TransitionConfig (ShelleyEra c)
stc@(ShelleyTransitionConfig ShelleyGenesis c
_) =
[Key
"shelley" forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object (forall e a c. (KeyValue e a, Crypto c) => ShelleyGenesis c -> [a]
toShelleyGenesisPairs (forall c. TransitionConfig (ShelleyEra c) -> ShelleyGenesis c
stcShelleyGenesis TransitionConfig (ShelleyEra c)
stc))]
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 (EraCrypto era)
nesBprev = forall c. Map (KeyHash 'StakePool c) Natural -> BlocksMade c
BlocksMade forall k a. Map k a
Map.empty
, nesBcur :: BlocksMade (EraCrypto era)
nesBcur = forall c. Map (KeyHash 'StakePool c) Natural -> BlocksMade c
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 (EraCrypto era)
esSnapshots = forall c. SnapShots c
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 (EraCrypto era)
dsGenDelegs = forall c. Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c
GenDelegs (forall c.
ShelleyGenesis c -> Map (KeyHash 'Genesis c) (GenDelegPair c)
sgGenDelegs ShelleyGenesis (EraCrypto era)
sg)}
, certPState :: PState era
certPState = forall a. Default a => a
def
, certVState :: VState era
certVState = forall a. Default a => a
def
}
}
, esNonMyopic :: NonMyopic (EraCrypto era)
esNonMyopic = forall a. Default a => a
def
}
, nesRu :: StrictMaybe (PulsingRewUpdate (EraCrypto era))
nesRu = forall a. StrictMaybe a
SNothing
, nesPd :: PoolDistr (EraCrypto era)
nesPd = forall c.
Map (KeyHash 'StakePool c) (IndividualPoolStake c)
-> CompactForm Coin -> PoolDistr c
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 (EraCrypto era)
sg :: ShelleyGenesis (EraCrypto era)
sg = TransitionConfig era
tc forall s a. s -> Getting a s a -> a
^. forall era.
EraTransition era =>
Lens' (TransitionConfig era) (ShelleyGenesis (EraCrypto era))
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 (forall c. ShelleyGenesis c -> Word64
sgMaxLovelaceSupply ShelleyGenesis (EraCrypto era)
sg) forall t. Val t => t -> t -> t
<-> forall era. EraTxOut era => UTxO era -> Coin
coinBalance UTxO era
initialUtxo
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 (EraCrypto era)
esSnapshots =
(forall era. EpochState era -> SnapShots (EraCrypto era)
esSnapshots EpochState era
epochState)
{ $sel:ssStakeMark:SnapShots :: SnapShot (EraCrypto era)
ssStakeMark = SnapShot (EraCrypto era)
initSnapShot
, $sel:ssStakeMarkPoolDistr:SnapShots :: PoolDistr (EraCrypto era)
ssStakeMarkPoolDistr = forall c. SnapShot c -> PoolDistr c
calculatePoolDistr SnapShot (EraCrypto era)
initSnapShot
}
}
,
nesPd :: PoolDistr (EraCrypto era)
nesPd = forall c. SnapShot c -> PoolDistr c
calculatePoolDistr SnapShot (EraCrypto era)
initSnapShot
}
where
ShelleyGenesisStaking {ListMap
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
sgsPools :: forall c.
ShelleyGenesisStaking c
-> ListMap (KeyHash 'StakePool c) (PoolParams c)
sgsPools :: ListMap
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
sgsPools, ListMap
(KeyHash 'Staking (EraCrypto era))
(KeyHash 'StakePool (EraCrypto era))
sgsStake :: forall c.
ShelleyGenesisStaking c
-> ListMap (KeyHash 'Staking c) (KeyHash 'StakePool c)
sgsStake :: ListMap
(KeyHash 'Staking (EraCrypto era))
(KeyHash 'StakePool (EraCrypto era))
sgsStake} = TransitionConfig era
tc forall s a. s -> Getting a s a -> a
^. forall era.
(HasCallStack, EraTransition era) =>
Lens'
(TransitionConfig era) (ShelleyGenesisStaking (EraCrypto era))
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
dState' :: DState era
dState' :: DState era
dState' =
(forall era. CertState era -> DState era
certDState CertState era
dpState)
{ dsUnified :: UMap (EraCrypto era)
dsUnified =
forall c.
Map (Credential 'Staking c) RDPair
-> Map Ptr (Credential 'Staking c)
-> Map (Credential 'Staking c) (KeyHash 'StakePool c)
-> Map (Credential 'Staking c) (DRep c)
-> UMap c
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) c. KeyHash kr c -> Credential kr c
KeyHashObj
forall a b. (a -> b) -> a -> b
$ Map
(KeyHash 'Staking (EraCrypto era))
(KeyHash 'StakePool (EraCrypto era))
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) c. KeyHash kr c -> Credential kr c
KeyHashObj Map
(KeyHash 'Staking (EraCrypto era))
(KeyHash 'StakePool (EraCrypto era))
sgsStakeMap)
forall a. Monoid a => a
mempty
}
where
sgsStakeMap :: Map
(KeyHash 'Staking (EraCrypto era))
(KeyHash 'StakePool (EraCrypto era))
sgsStakeMap = forall k v. Ord k => ListMap k v -> Map k v
ListMap.toMap ListMap
(KeyHash 'Staking (EraCrypto era))
(KeyHash 'StakePool (EraCrypto era))
sgsStake
pState' :: PState era
pState' :: PState era
pState' =
(forall era. CertState era -> PState era
certPState CertState era
dpState)
{ psStakePoolParams :: Map
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
psStakePoolParams = forall k v. Ord k => ListMap k v -> Map k v
ListMap.toMap ListMap
(KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
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
initSnapShot :: SnapShot (EraCrypto era)
initSnapShot :: SnapShot (EraCrypto era)
initSnapShot =
forall era.
EraPParams era =>
PParams era
-> IncrementalStake (EraCrypto era)
-> DState era
-> PState era
-> SnapShot (EraCrypto era)
incrementalStakeDistr
PParams era
pp
(forall era.
EraTxOut era =>
PParams era
-> IncrementalStake (EraCrypto era)
-> UTxO era
-> UTxO era
-> IncrementalStake (EraCrypto era)
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'
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 (EraCrypto era)) (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 (EraCrypto era)
txIn, TxOut era
txOut)
| (Addr (EraCrypto era)
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 (EraCrypto era)) Coin)
tcInitialFundsL)
, let txIn :: TxIn (EraCrypto era)
txIn = forall c. Crypto c => Addr c -> TxIn c
initialFundsPseudoTxIn Addr (EraCrypto era)
addr
txOut :: TxOut era
txOut = forall era.
(EraTxOut era, HasCallStack) =>
Addr (EraCrypto era) -> Value era -> TxOut era
mkBasicTxOut Addr (EraCrypto era)
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
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)
}
utxoToDel :: UTxO era
utxoToDel = forall era. Map (TxIn (EraCrypto era)) (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'
,
utxosStakeDistr :: IncrementalStake (EraCrypto era)
utxosStakeDistr =
forall era.
EraTxOut era =>
PParams era
-> IncrementalStake (EraCrypto era)
-> UTxO era
-> UTxO era
-> IncrementalStake (EraCrypto era)
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'
}
}
mergeUtxoNoOverlap ::
HasCallStack =>
UTxO era ->
UTxO era ->
UTxO era
mergeUtxoNoOverlap :: HasCallStack => UTxO era -> UTxO era -> UTxO era
mergeUtxoNoOverlap (UTxO Map (TxIn (EraCrypto era)) (TxOut era)
m1) (UTxO Map (TxIn (EraCrypto era)) (TxOut era)
m2) =
forall era. Map (TxIn (EraCrypto era)) (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 (EraCrypto era)
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 (EraCrypto era)
k)
Map (TxIn (EraCrypto era)) (TxOut era)
m1
Map (TxIn (EraCrypto era)) (TxOut era)
m2