{-# 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 (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 = [TransitionRule (ShelleyNEWPP era)
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 = PParams era -> ShelleyGovState era -> ShelleyNewppState era
forall era.
PParams era -> ShelleyGovState era -> ShelleyNewppState era
NewppState PParams era
forall a. Default a => a
def ShelleyGovState era
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
      ) <-
    Rule
  (ShelleyNEWPP era)
  'Transition
  (RuleContext 'Transition (ShelleyNEWPP era))
F (Clause (ShelleyNEWPP era) 'Transition) (TRC (ShelleyNEWPP era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  Word64
coreNodeQuorum <- BaseM (ShelleyNEWPP era) Word64
-> Rule (ShelleyNEWPP era) 'Transition Word64
forall sts a (ctx :: RuleType).
STS sts =>
BaseM sts a -> Rule sts ctx a
liftSTS (BaseM (ShelleyNEWPP era) Word64
 -> Rule (ShelleyNEWPP era) 'Transition Word64)
-> BaseM (ShelleyNEWPP era) Word64
-> Rule (ShelleyNEWPP era) 'Transition Word64
forall a b. (a -> b) -> a -> b
$ (Globals -> Word64) -> ReaderT Globals Identity Word64
forall (m :: * -> *) r a. Monad m => (r -> a) -> ReaderT r m a
asks Globals -> Word64
quorum
  ShelleyNewppState era
-> F (Clause (ShelleyNEWPP era) 'Transition)
     (ShelleyNewppState era)
forall a. a -> F (Clause (ShelleyNEWPP era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ShelleyNewppState era
 -> F (Clause (ShelleyNEWPP era) 'Transition)
      (ShelleyNewppState era))
-> ShelleyNewppState era
-> F (Clause (ShelleyNEWPP era) 'Transition)
     (ShelleyNewppState era)
forall a b. (a -> b) -> a -> b
$ Word64 -> GovState era -> PParams era -> ShelleyNewppState era
forall era.
(EraPParams era, GovState era ~ ShelleyGovState era,
 ProtVerAtMost era 8) =>
Word64 -> GovState era -> PParams era -> ShelleyNewppState era
updatePpup Word64
coreNodeQuorum GovState era
ShelleyGovState era
ppupState PParams era
Signal (ShelleyNEWPP era)
ppNew

-- | Update the protocol parameter updates by clearing out the proposals
-- and making the future proposals become the new proposals,
-- provided the new proposals can follow (otherwise reset them).
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 =
  PParams era -> ShelleyGovState era -> ShelleyNewppState era
forall era.
PParams era -> ShelleyGovState era -> ShelleyNewppState era
NewppState PParams era
pp (ShelleyGovState era -> ShelleyNewppState era)
-> ShelleyGovState era -> ShelleyNewppState era
forall a b. (a -> b) -> a -> b
$
    GovState era
ppupState
      { sgsCurProposals = curProposals
      , sgsFutureProposals = emptyPPPUpdates
      , sgsFuturePParams =
          PotentialPParamsUpdate $ votedFuturePParams curProposals pp coreNodeQuorum
      }
  where
    ProposedPPUpdates Map (KeyHash 'Genesis) (PParamsUpdate era)
newProposals = ShelleyGovState era -> ProposedPPUpdates era
forall era. ShelleyGovState era -> ProposedPPUpdates era
sgsFutureProposals GovState era
ShelleyGovState era
ppupState
    curProposals :: ProposedPPUpdates era
curProposals =
      if (PParamsUpdate era -> Bool)
-> Map (KeyHash 'Genesis) (PParamsUpdate era) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (PParams era -> PParamsUpdate era -> Bool
forall era.
(ProtVerAtMost era 8, EraPParams era) =>
PParams era -> PParamsUpdate era -> Bool
hasLegalProtVerUpdate PParams era
pp) Map (KeyHash 'Genesis) (PParamsUpdate era)
newProposals
        then Map (KeyHash 'Genesis) (PParamsUpdate era) -> ProposedPPUpdates era
forall era.
Map (KeyHash 'Genesis) (PParamsUpdate era) -> ProposedPPUpdates era
ProposedPPUpdates Map (KeyHash 'Genesis) (PParamsUpdate era)
newProposals
        else ProposedPPUpdates era
forall era. ProposedPPUpdates era
emptyPPPUpdates