{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Test.Cardano.Ledger.Shelley.Generator.Trace.Chain where
import Cardano.Ledger.BHeaderView (BHeaderView (..))
import Cardano.Ledger.Shelley.API
import Cardano.Ledger.Shelley.Core
import Cardano.Ledger.Shelley.Rules (
BbodyEnv,
ShelleyBbodyState,
)
import Cardano.Ledger.Shelley.State
import Cardano.Ledger.Shelley.Transition (
registerInitialStakePools,
resetStakeDistribution,
shelleyRegisterInitialAccounts,
)
import Cardano.Ledger.Slot (
BlockNo (..),
EpochNo (..),
SlotNo (..),
)
import Cardano.Ledger.Val ((<->))
import Cardano.Protocol.TPraos.API
import Cardano.Protocol.TPraos.BHeader (
LastAppliedBlock (..),
hashHeaderToNonce,
)
import Cardano.Protocol.TPraos.Rules.Tickn (
TicknEnv,
TicknState,
)
import Cardano.Slotting.Slot (WithOrigin (..))
import Control.Monad.Trans.Reader (runReaderT)
import Control.State.Transition
import Data.Functor.Identity (runIdentity)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (..))
import Numeric.Natural (Natural)
import Test.Cardano.Ledger.Shelley.ConcreteCryptoTypes (MockCrypto)
import Test.Cardano.Ledger.Shelley.Generator.Block (genBlock)
import Test.Cardano.Ledger.Shelley.Generator.Core (GenEnv (..))
import Test.Cardano.Ledger.Shelley.Generator.EraGen (
EraGen (..),
MinCHAIN_STS,
MinLEDGER_STS,
genUtxo0,
)
import Test.Cardano.Ledger.Shelley.Generator.Presets (genesisDelegs0)
import Test.Cardano.Ledger.Shelley.Rules.Chain (
CHAIN,
ChainState (..),
initialShelleyState,
)
import qualified Test.Cardano.Ledger.Shelley.Rules.Chain as STS (ChainState (ChainState))
import Test.Cardano.Ledger.Shelley.Utils (maxLLSupply, mkHash)
import Test.Control.State.Transition.Trace.Generator.QuickCheck (
BaseEnv,
HasTrace,
envGen,
interpretSTS,
sigGen,
)
import qualified Test.Control.State.Transition.Trace.Generator.QuickCheck as QC
import Test.QuickCheck (Gen)
instance
( EraGen era
, EraBlockBody era
, ApplyBlock era
, GetLedgerView era
, MinLEDGER_STS era
, MinCHAIN_STS era
, Embed (EraRule "BBODY" era) (CHAIN era)
, Environment (EraRule "BBODY" era) ~ BbodyEnv era
, State (EraRule "BBODY" era) ~ ShelleyBbodyState era
, Signal (EraRule "BBODY" era) ~ Block BHeaderView era
, Embed (EraRule "TICKN" era) (CHAIN era)
, Environment (EraRule "TICKN" era) ~ TicknEnv
, State (EraRule "TICKN" era) ~ TicknState
, Signal (EraRule "TICKN" era) ~ Bool
, Embed (EraRule "TICK" era) (CHAIN era)
, Environment (EraRule "TICK" era) ~ ()
, State (EraRule "TICK" era) ~ NewEpochState era
, Signal (EraRule "TICK" era) ~ SlotNo
, QC.HasTrace (EraRule "LEDGERS" era) (GenEnv MockCrypto era)
) =>
HasTrace (CHAIN era) (GenEnv MockCrypto era)
where
envGen :: HasCallStack =>
GenEnv MockCrypto era -> Gen (Environment (CHAIN era))
envGen GenEnv MockCrypto era
_ = () -> Gen ()
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
sigGen :: HasCallStack =>
GenEnv MockCrypto era
-> Environment (CHAIN era)
-> State (CHAIN era)
-> Gen (Signal (CHAIN era))
sigGen GenEnv MockCrypto era
ge Environment (CHAIN era)
_env State (CHAIN era)
st = GenEnv MockCrypto era
-> ChainState era -> Gen (Block (BHeader MockCrypto) era)
forall era c.
(MinLEDGER_STS era, ApplyBlock era, GetLedgerView era,
HasTrace (EraRule "LEDGERS" era) (GenEnv c era), EraGen era,
PraosCrypto c) =>
GenEnv c era -> ChainState era -> Gen (Block (BHeader c) era)
genBlock GenEnv MockCrypto era
ge State (CHAIN era)
ChainState era
st
shrinkSignal :: HasCallStack => Signal (CHAIN era) -> [Signal (CHAIN era)]
shrinkSignal = (\Signal (CHAIN era)
_x -> [])
type BaseEnv (CHAIN era) = Globals
interpretSTS :: forall a.
HasCallStack =>
BaseEnv (CHAIN era) -> BaseM (CHAIN era) a -> a
interpretSTS BaseEnv (CHAIN era)
globals BaseM (CHAIN era) a
act = Identity a -> a
forall a. Identity a -> a
runIdentity (Identity a -> a) -> Identity a -> a
forall a b. (a -> b) -> a -> b
$ ReaderT Globals Identity a -> Globals -> Identity a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Globals Identity a
BaseM (CHAIN era) a
act Globals
BaseEnv (CHAIN era)
globals
lastByronHeaderHash :: forall proxy era. proxy era -> HashHeader
proxy era
_ = Hash HASH EraIndependentBlockHeader -> HashHeader
HashHeader (Hash HASH EraIndependentBlockHeader -> HashHeader)
-> Hash HASH EraIndependentBlockHeader -> HashHeader
forall a b. (a -> b) -> a -> b
$ Int -> Hash HASH EraIndependentBlockHeader
forall a h. HashAlgorithm h => Int -> Hash h a
mkHash Int
0
mkGenesisChainState ::
forall era a c.
( EraGen era
, EraGov era
, EraStake era
) =>
GenEnv c era ->
IRC (CHAIN era) ->
Gen (Either a (ChainState era))
mkGenesisChainState :: forall era a c.
(EraGen era, EraGov era, EraStake era) =>
GenEnv c era -> IRC (CHAIN era) -> Gen (Either a (ChainState era))
mkGenesisChainState ge :: GenEnv c era
ge@(GenEnv KeySpace c era
_ ScriptSpace era
_ Constants
constants) (IRC Environment (CHAIN era)
_slotNo) = do
UTxO era
utxo0 <- GenEnv c era -> Gen (UTxO era)
forall era c. EraGen era => GenEnv c era -> Gen (UTxO era)
genUtxo0 GenEnv c era
ge
PParams era
pParams <- forall era. EraGen era => Constants -> Gen (PParams era)
genEraPParams @era Constants
constants
Either a (ChainState era) -> Gen (Either a (ChainState era))
forall a. a -> Gen a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either a (ChainState era) -> Gen (Either a (ChainState era)))
-> (ChainState era -> Either a (ChainState era))
-> ChainState era
-> Gen (Either a (ChainState era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainState era -> Either a (ChainState era)
forall a b. b -> Either a b
Right (ChainState era -> Either a (ChainState era))
-> (ChainState era -> ChainState era)
-> ChainState era
-> Either a (ChainState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ChainState era -> ChainState era
forall h. ChainState h -> ChainState h
withRewards (ChainState era -> Gen (Either a (ChainState era)))
-> ChainState era -> Gen (Either a (ChainState era))
forall a b. (a -> b) -> a -> b
$
forall era.
(EraGov era, EraStake era, EraCertState era,
Default (StashedAVVMAddresses era)) =>
WithOrigin LastAppliedBlock
-> EpochNo
-> UTxO era
-> Coin
-> Map (KeyHash 'Genesis) GenDelegPair
-> PParams era
-> Nonce
-> ChainState era
initialShelleyState @era
(LastAppliedBlock -> WithOrigin LastAppliedBlock
forall t. t -> WithOrigin t
At (LastAppliedBlock -> WithOrigin LastAppliedBlock)
-> LastAppliedBlock -> WithOrigin LastAppliedBlock
forall a b. (a -> b) -> a -> b
$ BlockNo -> SlotNo -> HashHeader -> LastAppliedBlock
LastAppliedBlock (Word64 -> BlockNo
BlockNo Word64
0) (Word64 -> SlotNo
SlotNo Word64
0) (Proxy era -> HashHeader
forall (proxy :: * -> *) era. proxy era -> HashHeader
lastByronHeaderHash Proxy era
p))
EpochNo
epoch0
UTxO era
utxo0
(Coin
maxLLSupply Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
<-> UTxO era -> Coin
forall era. EraTxOut era => UTxO era -> Coin
sumCoinUTxO UTxO era
utxo0)
Map (KeyHash 'Genesis) GenDelegPair
delegs0
PParams era
pParams
(HashHeader -> Nonce
hashHeaderToNonce (Proxy era -> HashHeader
forall (proxy :: * -> *) era. proxy era -> HashHeader
lastByronHeaderHash Proxy era
p))
where
epoch0 :: EpochNo
epoch0 = Word64 -> EpochNo
EpochNo Word64
0
delegs0 :: Map (KeyHash 'Genesis) GenDelegPair
delegs0 = Constants -> Map (KeyHash 'Genesis) GenDelegPair
genesisDelegs0 Constants
constants
withRewards :: ChainState h -> ChainState h
withRewards :: forall h. ChainState h -> ChainState h
withRewards st :: ChainState h
st@STS.ChainState {Map (KeyHash 'BlockIssuer) Word64
WithOrigin LastAppliedBlock
Nonce
NewEpochState h
chainNes :: NewEpochState h
chainOCertIssue :: Map (KeyHash 'BlockIssuer) Word64
chainEpochNonce :: Nonce
chainEvolvingNonce :: Nonce
chainCandidateNonce :: Nonce
chainPrevEpochNonce :: Nonce
chainLastAppliedBlock :: WithOrigin LastAppliedBlock
chainNes :: forall era. ChainState era -> NewEpochState era
chainOCertIssue :: forall era. ChainState era -> Map (KeyHash 'BlockIssuer) Word64
chainEpochNonce :: forall era. ChainState era -> Nonce
chainEvolvingNonce :: forall era. ChainState era -> Nonce
chainCandidateNonce :: forall era. ChainState era -> Nonce
chainPrevEpochNonce :: forall era. ChainState era -> Nonce
chainLastAppliedBlock :: forall era. ChainState era -> WithOrigin LastAppliedBlock
..} =
ChainState h
st
{ chainNes =
chainNes
{ nesEs =
(nesEs chainNes)
{ esChainAccountState =
(esChainAccountState (nesEs chainNes))
{ casTreasury = Coin 1000000
}
}
}
}
p :: Proxy era
p :: Proxy era
p = Proxy era
forall {k} (t :: k). Proxy t
Proxy
mkOCertIssueNos ::
GenDelegs ->
Map (KeyHash 'BlockIssuer) Natural
mkOCertIssueNos :: GenDelegs -> Map (KeyHash 'BlockIssuer) Natural
mkOCertIssueNos (GenDelegs Map (KeyHash 'Genesis) GenDelegPair
delegs0) =
[(KeyHash 'BlockIssuer, Natural)]
-> Map (KeyHash 'BlockIssuer) Natural
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((GenDelegPair -> (KeyHash 'BlockIssuer, Natural))
-> [GenDelegPair] -> [(KeyHash 'BlockIssuer, Natural)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap GenDelegPair -> (KeyHash 'BlockIssuer, Natural)
forall {b} {r' :: KeyRole}.
Num b =>
GenDelegPair -> (KeyHash r', b)
f (Map (KeyHash 'Genesis) GenDelegPair -> [GenDelegPair]
forall k a. Map k a -> [a]
Map.elems Map (KeyHash 'Genesis) GenDelegPair
delegs0))
where
f :: GenDelegPair -> (KeyHash r', b)
f (GenDelegPair KeyHash 'GenesisDelegate
vk VRFVerKeyHash 'GenDelegVRF
_) = (KeyHash 'GenesisDelegate -> KeyHash r'
forall (r :: KeyRole) (r' :: KeyRole). KeyHash r -> KeyHash r'
forall (a :: KeyRole -> *) (r :: KeyRole) (r' :: KeyRole).
HasKeyRole a =>
a r -> a r'
coerceKeyRole KeyHash 'GenesisDelegate
vk, b
0)
registerGenesisStaking ::
(EraGov era, EraStake era, EraCertState era, ShelleyEraAccounts era) =>
ShelleyGenesisStaking ->
ChainState era ->
ChainState era
registerGenesisStaking :: forall era.
(EraGov era, EraStake era, EraCertState era,
ShelleyEraAccounts era) =>
ShelleyGenesisStaking -> ChainState era -> ChainState era
registerGenesisStaking ShelleyGenesisStaking
sgs cs :: ChainState era
cs@STS.ChainState {chainNes :: forall era. ChainState era -> NewEpochState era
chainNes = NewEpochState era
oldChainNes} =
ChainState era
cs
{ chainNes =
resetStakeDistribution $
shelleyRegisterInitialAccounts sgs $
registerInitialStakePools sgs oldChainNes
}