{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.Shelley.API.Genesis where

import Cardano.Ledger.BaseTypes (BlocksMade (..))
import Cardano.Ledger.Core (EraRule)
import Cardano.Ledger.Crypto (Crypto)
import Cardano.Ledger.Shelley (ShelleyEra)
import Cardano.Ledger.Shelley.API.Types
  ( AccountState (AccountState),
    Coin (Coin),
    DPState (DPState),
    DState (_genDelegs),
    EpochState (EpochState),
    GenDelegs (GenDelegs),
    LedgerState (LedgerState),
    NewEpochState (NewEpochState),
    PoolDistr (PoolDistr),
    ShelleyGenesis (sgGenDelegs, sgMaxLovelaceSupply, sgProtocolParams),
    StrictMaybe (SNothing),
    UTxOState (UTxOState),
    balance,
    genesisUTxO,
    word64ToCoin,
  )
import Cardano.Ledger.Shelley.EpochBoundary (emptySnapShots)
import Cardano.Ledger.Shelley.LedgerState (updateStakeDistribution)
import Cardano.Ledger.Shelley.UTxO (UTxO (..))
import Cardano.Ledger.Val (Val ((<->)))
import Control.State.Transition (STS (State))
import Data.Default.Class (Default, def)
import Data.Kind (Type)
import qualified Data.Map.Strict as Map

-- | Indicates that this era may be bootstrapped from 'ShelleyGenesis'.
class CanStartFromGenesis era where
  -- | Additional genesis configuration necessary for this era.
  type AdditionalGenesisConfig era :: Type

  type AdditionalGenesisConfig era = ()

  -- | Construct an initial state given a 'ShelleyGenesis' and any appropriate
  -- 'AdditionalGenesisConfig' for the era.
  initialState ::
    ShelleyGenesis era ->
    AdditionalGenesisConfig era ->
    NewEpochState era

instance
  ( Crypto c,
    Default (State (EraRule "PPUP" (ShelleyEra c)))
  ) =>
  CanStartFromGenesis (ShelleyEra c)
  where
  initialState :: ShelleyGenesis (ShelleyEra c)
-> AdditionalGenesisConfig (ShelleyEra c)
-> NewEpochState (ShelleyEra c)
initialState ShelleyGenesis (ShelleyEra c)
sg () =
    EpochNo
-> BlocksMade (Crypto (ShelleyEra c))
-> BlocksMade (Crypto (ShelleyEra c))
-> EpochState (ShelleyEra c)
-> StrictMaybe (PulsingRewUpdate (Crypto (ShelleyEra c)))
-> PoolDistr (Crypto (ShelleyEra c))
-> StashedAVVMAddresses (ShelleyEra c)
-> NewEpochState (ShelleyEra c)
forall era.
EpochNo
-> BlocksMade (Crypto era)
-> BlocksMade (Crypto era)
-> EpochState era
-> StrictMaybe (PulsingRewUpdate (Crypto era))
-> PoolDistr (Crypto era)
-> StashedAVVMAddresses era
-> NewEpochState era
NewEpochState
      EpochNo
initialEpochNo
      (Map (KeyHash 'StakePool c) Natural -> BlocksMade c
forall crypto.
Map (KeyHash 'StakePool crypto) Natural -> BlocksMade crypto
BlocksMade Map (KeyHash 'StakePool c) Natural
forall k a. Map k a
Map.empty)
      (Map (KeyHash 'StakePool c) Natural -> BlocksMade c
forall crypto.
Map (KeyHash 'StakePool crypto) Natural -> BlocksMade crypto
BlocksMade Map (KeyHash 'StakePool c) Natural
forall k a. Map k a
Map.empty)
      ( AccountState
-> SnapShots (Crypto (ShelleyEra c))
-> LedgerState (ShelleyEra c)
-> PParams (ShelleyEra c)
-> PParams (ShelleyEra c)
-> NonMyopic (Crypto (ShelleyEra c))
-> EpochState (ShelleyEra c)
forall era.
AccountState
-> SnapShots (Crypto era)
-> LedgerState era
-> PParams era
-> PParams era
-> NonMyopic (Crypto era)
-> EpochState era
EpochState
          (Coin -> Coin -> AccountState
AccountState (Integer -> Coin
Coin Integer
0) Coin
reserves)
          SnapShots (Crypto (ShelleyEra c))
forall crypto. SnapShots crypto
emptySnapShots
          ( UTxOState (ShelleyEra c)
-> DPState (Crypto (ShelleyEra c)) -> LedgerState (ShelleyEra c)
forall era.
UTxOState era -> DPState (Crypto era) -> LedgerState era
LedgerState
              ( UTxO (ShelleyEra c)
-> Coin
-> Coin
-> State (EraRule "PPUP" (ShelleyEra c))
-> IncrementalStake (Crypto (ShelleyEra c))
-> UTxOState (ShelleyEra c)
forall era.
UTxO era
-> Coin
-> Coin
-> State (EraRule "PPUP" era)
-> IncrementalStake (Crypto era)
-> UTxOState era
UTxOState
                  UTxO (ShelleyEra c)
initialUtxo
                  (Integer -> Coin
Coin Integer
0)
                  (Integer -> Coin
Coin Integer
0)
                  State (EraRule "PPUP" (ShelleyEra c))
forall a. Default a => a
def
                  (IncrementalStake (Crypto (ShelleyEra c))
-> UTxO (ShelleyEra c)
-> UTxO (ShelleyEra c)
-> IncrementalStake (Crypto (ShelleyEra c))
forall era.
Era era =>
IncrementalStake (Crypto era)
-> UTxO era -> UTxO era -> IncrementalStake (Crypto era)
updateStakeDistribution IncrementalStake (Crypto (ShelleyEra c))
forall a. Monoid a => a
mempty (Map (TxIn (Crypto (ShelleyEra c))) (TxOut (ShelleyEra c))
-> UTxO (ShelleyEra c)
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (Crypto (ShelleyEra c))) (TxOut (ShelleyEra c))
forall a. Monoid a => a
mempty) UTxO (ShelleyEra c)
initialUtxo)
              )
              (DState c -> PState c -> DPState c
forall crypto. DState crypto -> PState crypto -> DPState crypto
DPState (DState c
forall a. Default a => a
def {_genDelegs :: GenDelegs c
_genDelegs = Map (KeyHash 'Genesis c) (GenDelegPair c) -> GenDelegs c
forall crypto.
Map (KeyHash 'Genesis crypto) (GenDelegPair crypto)
-> GenDelegs crypto
GenDelegs Map (KeyHash 'Genesis c) (GenDelegPair c)
Map
  (KeyHash 'Genesis (Crypto (ShelleyEra c)))
  (GenDelegPair (Crypto (ShelleyEra c)))
genDelegs}) PState c
forall a. Default a => a
def)
          )
          PParams (ShelleyEra c)
PParams (ShelleyEra c)
pp
          PParams (ShelleyEra c)
PParams (ShelleyEra c)
pp
          NonMyopic (Crypto (ShelleyEra c))
forall a. Default a => a
def
      )
      StrictMaybe (PulsingRewUpdate (Crypto (ShelleyEra c)))
forall a. StrictMaybe a
SNothing
      (Map (KeyHash 'StakePool c) (IndividualPoolStake c) -> PoolDistr c
forall crypto.
Map (KeyHash 'StakePool crypto) (IndividualPoolStake crypto)
-> PoolDistr crypto
PoolDistr Map (KeyHash 'StakePool c) (IndividualPoolStake c)
forall k a. Map k a
Map.empty)
      (Map (TxIn (Crypto (ShelleyEra c))) (TxOut (ShelleyEra c))
-> UTxO (ShelleyEra c)
forall era. Map (TxIn (Crypto era)) (TxOut era) -> UTxO era
UTxO Map (TxIn (Crypto (ShelleyEra c))) (TxOut (ShelleyEra c))
forall a. Monoid a => a
mempty)
    where
      initialEpochNo :: EpochNo
initialEpochNo = EpochNo
0
      initialUtxo :: UTxO (ShelleyEra c)
initialUtxo = ShelleyGenesis (ShelleyEra c) -> UTxO (ShelleyEra c)
forall era.
(Era era, UsesTxOut era) =>
ShelleyGenesis era -> UTxO era
genesisUTxO ShelleyGenesis (ShelleyEra c)
sg
      reserves :: Coin
reserves =
        Word64 -> Coin
word64ToCoin (ShelleyGenesis (ShelleyEra c) -> Word64
forall era. ShelleyGenesis era -> Word64
sgMaxLovelaceSupply ShelleyGenesis (ShelleyEra c)
sg)
          Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> UTxO (ShelleyEra c) -> Value (ShelleyEra c)
forall era. Era era => UTxO era -> Value era
balance UTxO (ShelleyEra c)
initialUtxo
      genDelegs :: Map
  (KeyHash 'Genesis (Crypto (ShelleyEra c)))
  (GenDelegPair (Crypto (ShelleyEra c)))
genDelegs = ShelleyGenesis (ShelleyEra c)
-> Map
     (KeyHash 'Genesis (Crypto (ShelleyEra c)))
     (GenDelegPair (Crypto (ShelleyEra c)))
forall era.
ShelleyGenesis era
-> Map (KeyHash 'Genesis (Crypto era)) (GenDelegPair (Crypto era))
sgGenDelegs ShelleyGenesis (ShelleyEra c)
sg
      pp :: PParams (ShelleyEra c)
pp = ShelleyGenesis (ShelleyEra c) -> PParams (ShelleyEra c)
forall era. ShelleyGenesis era -> PParams era
sgProtocolParams ShelleyGenesis (ShelleyEra c)
sg