{-# 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

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