{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Cardano.Ledger.Shelley.Rules.Newpp (
ShelleyNEWPP,
ShelleyNewppState (..),
NewppEnv (..),
PredicateFailure,
) where
import Cardano.Ledger.BaseTypes (Globals (quorum), ShelleyBase)
import Cardano.Ledger.Core
import Cardano.Ledger.Shelley.Era (ShelleyNEWPP)
import Cardano.Ledger.Shelley.Governance
import Cardano.Ledger.Shelley.LedgerState (
CertState (..),
UTxOState,
)
import Cardano.Ledger.Shelley.PParams (
ProposedPPUpdates (ProposedPPUpdates),
emptyPPPUpdates,
hasLegalProtVerUpdate,
)
import Cardano.Ledger.Shelley.Rules.Ppup (votedFuturePParams)
import Control.Monad.Trans.Reader (asks)
import Control.State.Transition (
STS (..),
TRC (..),
TransitionRule,
judgmentContext,
liftSTS,
)
import Data.Default.Class (Default, def)
import Data.Void (Void)
import Data.Word (Word64)
data ShelleyNewppState era
= NewppState (PParams era) (ShelleyGovState era)
data NewppEnv era = NewppEnv
{ forall era. NewppEnv era -> CertState era
neCertState :: !(CertState era)
, forall era. NewppEnv era -> UTxOState era
neUTxOState :: !(UTxOState era)
}
instance
( EraGov era
, GovState era ~ ShelleyGovState era
, ProtVerAtMost era 8
) =>
STS (ShelleyNEWPP era)
where
type State (ShelleyNEWPP era) = ShelleyNewppState era
type Signal (ShelleyNEWPP era) = PParams era
type Environment (ShelleyNEWPP era) = NewppEnv era
type BaseM (ShelleyNEWPP era) = ShelleyBase
type PredicateFailure (ShelleyNEWPP era) = Void
transitionRules :: [TransitionRule (ShelleyNEWPP era)]
transitionRules = [forall era.
(GovState era ~ ShelleyGovState era, EraGov era,
ProtVerAtMost era 8) =>
TransitionRule (ShelleyNEWPP era)
newPpTransition]
instance EraPParams era => Default (ShelleyNewppState era) where
def :: ShelleyNewppState era
def = forall era.
PParams era -> ShelleyGovState era -> ShelleyNewppState era
NewppState forall a. Default a => a
def forall a. Default a => a
def
newPpTransition ::
forall era.
( GovState era ~ ShelleyGovState era
, EraGov era
, ProtVerAtMost era 8
) =>
TransitionRule (ShelleyNEWPP era)
newPpTransition :: forall era.
(GovState era ~ ShelleyGovState era, EraGov era,
ProtVerAtMost era 8) =>
TransitionRule (ShelleyNEWPP era)
newPpTransition = do
TRC
( NewppEnv CertState era
_certState UTxOState era
_utxoState
, NewppState PParams era
_pp ShelleyGovState era
ppupState
, Signal (ShelleyNEWPP era)
ppNew
) <-
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
Word64
coreNodeQuorum <- forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Word64
quorum
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall era.
(EraPParams era, GovState era ~ ShelleyGovState era,
ProtVerAtMost era 8) =>
Word64 -> GovState era -> PParams era -> ShelleyNewppState era
updatePpup Word64
coreNodeQuorum ShelleyGovState era
ppupState Signal (ShelleyNEWPP era)
ppNew
updatePpup ::
( EraPParams era
, GovState era ~ ShelleyGovState era
, ProtVerAtMost era 8
) =>
Word64 ->
GovState era ->
PParams era ->
ShelleyNewppState era
updatePpup :: forall era.
(EraPParams era, GovState era ~ ShelleyGovState era,
ProtVerAtMost era 8) =>
Word64 -> GovState era -> PParams era -> ShelleyNewppState era
updatePpup !Word64
coreNodeQuorum GovState era
ppupState PParams era
pp =
forall era.
PParams era -> ShelleyGovState era -> ShelleyNewppState era
NewppState PParams era
pp forall a b. (a -> b) -> a -> b
$
GovState era
ppupState
{ sgsCurProposals :: ProposedPPUpdates era
sgsCurProposals = ProposedPPUpdates era
curProposals
, sgsFutureProposals :: ProposedPPUpdates era
sgsFutureProposals = forall era. ProposedPPUpdates era
emptyPPPUpdates
, sgsFuturePParams :: FuturePParams era
sgsFuturePParams =
forall era. Maybe (PParams era) -> FuturePParams era
PotentialPParamsUpdate forall a b. (a -> b) -> a -> b
$ forall era.
EraPParams era =>
ProposedPPUpdates era
-> PParams era -> Word64 -> Maybe (PParams era)
votedFuturePParams ProposedPPUpdates era
curProposals PParams era
pp Word64
coreNodeQuorum
}
where
ProposedPPUpdates Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
newProposals = forall era. ShelleyGovState era -> ProposedPPUpdates era
sgsFutureProposals GovState era
ppupState
curProposals :: ProposedPPUpdates era
curProposals =
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall era.
(ProtVerAtMost era 8, EraPParams era) =>
PParams era -> PParamsUpdate era -> Bool
hasLegalProtVerUpdate PParams era
pp) Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
newProposals
then forall era.
Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
-> ProposedPPUpdates era
ProposedPPUpdates Map (KeyHash 'Genesis (EraCrypto era)) (PParamsUpdate era)
newProposals
else forall era. ProposedPPUpdates era
emptyPPPUpdates