{-# 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.Coin
import Cardano.Ledger.Core
import Cardano.Ledger.Credential
import Cardano.Ledger.Genesis (EraGenesis)
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 qualified Cardano.Ledger.UMap as UM
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
  , EraStake era
  , EraGenesis era
  , EraCertState 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 = (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)

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

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.
  TransitionConfig era -> NewEpochState era -> NewEpochState era
forall era.
(HasCallStack, EraTransition era) =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialStaking TransitionConfig era
cfg (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 -> ShowS
[TransitionConfig ShelleyEra] -> ShowS
TransitionConfig ShelleyEra -> String
(Int -> TransitionConfig ShelleyEra -> ShowS)
-> (TransitionConfig ShelleyEra -> String)
-> ([TransitionConfig ShelleyEra] -> ShowS)
-> Show (TransitionConfig ShelleyEra)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> TransitionConfig ShelleyEra -> ShowS
showsPrec :: Int -> TransitionConfig ShelleyEra -> ShowS
$cshow :: TransitionConfig ShelleyEra -> String
show :: TransitionConfig ShelleyEra -> String
$cshowList :: [TransitionConfig ShelleyEra] -> ShowS
showList :: [TransitionConfig ShelleyEra] -> ShowS
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 =>
TransitionConfig era -> NewEpochState era -> NewEpochState era
registerInitialFundsThenStaking

  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 'Genesis) GenDelegPair
PParams ShelleyEra
fbtcGenDelegs :: Map (KeyHash 'Genesis) GenDelegPair
fbtcProtocolParams :: PParams ShelleyEra
fbtcMaxLovelaceSupply :: Word64
fbtcGenDelegs :: FromByronTranslationContext -> Map (KeyHash 'Genesis) GenDelegPair
fbtcProtocolParams :: FromByronTranslationContext -> PParams ShelleyEra
fbtcMaxLovelaceSupply :: FromByronTranslationContext -> Word64
..} =
        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)

-- | 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 =
  String
-> (ListMap Addr Coin -> Bool)
-> (forall {f :: * -> *}.
    Functor f =>
    (ListMap Addr Coin -> f (ListMap Addr Coin))
    -> TransitionConfig era -> f (TransitionConfig era))
-> forall {f :: * -> *}.
   Functor f =>
   (ListMap Addr Coin -> f (ListMap Addr Coin))
   -> TransitionConfig era -> f (TransitionConfig era)
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 ((forall {f :: * -> *}.
  Functor f =>
  (ListMap Addr Coin -> f (ListMap Addr Coin))
  -> TransitionConfig era -> f (TransitionConfig era))
 -> forall {f :: * -> *}.
    Functor f =>
    (ListMap Addr Coin -> f (ListMap Addr Coin))
    -> TransitionConfig era -> f (TransitionConfig era))
-> (forall {f :: * -> *}.
    Functor f =>
    (ListMap Addr Coin -> f (ListMap Addr Coin))
    -> TransitionConfig era -> f (TransitionConfig era))
-> forall {f :: * -> *}.
   Functor f =>
   (ListMap Addr Coin -> f (ListMap Addr Coin))
   -> TransitionConfig era -> f (TransitionConfig era)
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)
-> (forall {f :: * -> *}.
    Functor f =>
    (ShelleyGenesisStaking -> f ShelleyGenesisStaking)
    -> TransitionConfig era -> f (TransitionConfig era))
-> forall {f :: * -> *}.
   Functor f =>
   (ShelleyGenesisStaking -> f ShelleyGenesisStaking)
   -> TransitionConfig era -> f (TransitionConfig era)
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) ((forall {f :: * -> *}.
  Functor f =>
  (ShelleyGenesisStaking -> f ShelleyGenesisStaking)
  -> TransitionConfig era -> f (TransitionConfig era))
 -> forall {f :: * -> *}.
    Functor f =>
    (ShelleyGenesisStaking -> f ShelleyGenesisStaking)
    -> TransitionConfig era -> f (TransitionConfig era))
-> (forall {f :: * -> *}.
    Functor f =>
    (ShelleyGenesisStaking -> f ShelleyGenesisStaking)
    -> TransitionConfig era -> f (TransitionConfig era))
-> forall {f :: * -> *}.
   Functor f =>
   (ShelleyGenesisStaking -> f ShelleyGenesisStaking)
   -> TransitionConfig era -> f (TransitionConfig era)
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 -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
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 ([Pair] -> Value)
-> (TransitionConfig ShelleyEra -> [Pair])
-> TransitionConfig ShelleyEra
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransitionConfig ShelleyEra -> [Pair]
forall e a. KeyValue e a => TransitionConfig ShelleyEra -> [a]
toShelleyTransitionConfigPairs
  toEncoding :: TransitionConfig ShelleyEra -> Encoding
toEncoding = Series -> Encoding
pairs (Series -> Encoding)
-> (TransitionConfig ShelleyEra -> Series)
-> TransitionConfig ShelleyEra
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat ([Series] -> Series)
-> (TransitionConfig ShelleyEra -> [Series])
-> TransitionConfig ShelleyEra
-> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TransitionConfig ShelleyEra -> [Series]
forall e a. KeyValue e a => TransitionConfig ShelleyEra -> [a]
toShelleyTransitionConfigPairs

instance FromJSON (TransitionConfig ShelleyEra) where
  parseJSON :: Value -> Parser (TransitionConfig ShelleyEra)
parseJSON = 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
    ShelleyGenesis
sg <- Object
o Object -> Key -> Parser ShelleyGenesis
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"shelley"
    TransitionConfig ShelleyEra -> Parser (TransitionConfig ShelleyEra)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TransitionConfig ShelleyEra
 -> Parser (TransitionConfig ShelleyEra))
-> TransitionConfig ShelleyEra
-> Parser (TransitionConfig ShelleyEra)
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" 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 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 =
  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 'Genesis) GenDelegPair -> GenDelegs
GenDelegs (ShelleyGenesis -> Map (KeyHash 'Genesis) 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 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
          { esLState =
              ledgerState
                { lsCertState =
                    dpState
                      & certDStateL .~ dState'
                      & certPStateL .~ pState'
                }
          , esSnapshots =
              (esSnapshots epochState)
                { ssStakeMark = initSnapShot
                , ssStakeMarkPoolDistr = calculatePoolDistr 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 = calculatePoolDistr initSnapShot
    }
  where
    ShelleyGenesisStaking {ListMap (KeyHash 'StakePool) PoolParams
sgsPools :: ListMap (KeyHash 'StakePool) PoolParams
sgsPools :: ShelleyGenesisStaking -> ListMap (KeyHash 'StakePool) PoolParams
sgsPools, ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStake :: ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStake :: ShelleyGenesisStaking
-> ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStake} = TransitionConfig era
tc 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 {nesEs :: forall era. NewEpochState era -> EpochState era
nesEs = EpochState era
epochState} = NewEpochState era
nes
    ledgerState :: LedgerState era
ledgerState = EpochState era -> LedgerState era
forall era. EpochState era -> LedgerState era
esLState EpochState era
epochState
    dpState :: CertState era
dpState = LedgerState era -> CertState era
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' =
      (CertState era
dpState CertState era
-> Getting (DState era) (CertState era) (DState era) -> DState era
forall s a. s -> Getting a s a -> a
^. Getting (DState era) (CertState era) (DState era)
forall era. EraCertState era => Lens' (CertState era) (DState era)
Lens' (CertState era) (DState era)
certDStateL)
        { dsUnified =
            UM.unify
              ( Map.map (const $ UM.RDPair (CompactCoin 0) (CompactCoin 0))
                  . Map.mapKeys KeyHashObj
                  $ sgsStakeMap
              )
              mempty
              (Map.mapKeys KeyHashObj sgsStakeMap)
              mempty
        }
      where
        sgsStakeMap :: Map (KeyHash 'Staking) (KeyHash 'StakePool)
sgsStakeMap = ListMap (KeyHash 'Staking) (KeyHash 'StakePool)
-> Map (KeyHash 'Staking) (KeyHash 'StakePool)
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' =
      (CertState era
dpState CertState era
-> Getting (PState era) (CertState era) (PState era) -> PState era
forall s a. s -> Getting a s a -> a
^. Getting (PState era) (CertState era) (PState era)
forall era. EraCertState era => Lens' (CertState era) (PState era)
Lens' (CertState era) (PState era)
certPStateL)
        { psStakePoolParams = ListMap.toMap sgsPools
        }

    _pp :: PParams era
_pp = NewEpochState era
nes NewEpochState era
-> Getting (PParams era) (NewEpochState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. (EpochState era -> Const (PParams era) (EpochState era))
-> NewEpochState era -> Const (PParams era) (NewEpochState era)
forall era (f :: * -> *).
Functor f =>
(EpochState era -> f (EpochState era))
-> NewEpochState era -> f (NewEpochState era)
nesEsL ((EpochState era -> Const (PParams era) (EpochState era))
 -> NewEpochState era -> Const (PParams era) (NewEpochState era))
-> ((PParams era -> Const (PParams era) (PParams era))
    -> EpochState era -> Const (PParams era) (EpochState era))
-> Getting (PParams era) (NewEpochState era) (PParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PParams era -> Const (PParams era) (PParams era))
-> EpochState era -> Const (PParams era) (EpochState era)
forall era. EraGov era => Lens' (EpochState era) (PParams 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.
      -- 2. Update the stake map given the initial delegation.
      InstantStake era -> DState era -> PState era -> SnapShot
forall era.
EraStake era =>
InstantStake era -> DState era -> PState era -> SnapShot
snapShotFromInstantStake (UTxO era -> InstantStake era -> InstantStake era
forall era.
EraStake era =>
UTxO era -> InstantStake era -> InstantStake era
addInstantStake (LedgerState era
ledgerState LedgerState era
-> Getting (UTxO era) (LedgerState era) (UTxO era) -> UTxO era
forall s a. s -> Getting a s a -> a
^. Getting (UTxO era) (LedgerState era) (UTxO era)
forall era. Lens' (LedgerState 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'

-- | 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 -> ShowS
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