{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Cardano.Ledger.State.Governance (
  EraGov (..),
  FuturePParams (..),
  solidifyFuturePParams,
  nextEpochPParams,
  nextEpochUpdatedPParams,
  knownFuturePParams,
) where

import Cardano.Ledger.BaseTypes (StrictMaybe (..), fromSMaybe, maybeToStrictMaybe)
import Cardano.Ledger.Binary (
  DecCBOR (decCBOR),
  DecShareCBOR (..),
  EncCBOR (encCBOR),
  FromCBOR (..),
  Interns,
  ToCBOR (..),
 )
import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), (<!))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.State.CertState (Obligations)
import Control.DeepSeq (NFData (..))
import Data.Aeson (ToJSON (..))
import Data.Default (Default (..))
import Data.Kind (Type)
import Data.Typeable
import GHC.Generics (Generic)
import Lens.Micro (Lens', (^.))
import NoThunks.Class (AllowThunk (..), NoThunks (..))

class
  ( EraPParams era
  , Eq (GovState era)
  , Show (GovState era)
  , NoThunks (GovState era)
  , NFData (GovState era)
  , EncCBOR (GovState era)
  , DecCBOR (GovState era)
  , DecShareCBOR (GovState era)
  , Share (GovState era)
      ~ ( Interns (Credential 'Staking)
        , Interns (KeyHash 'StakePool)
        , Interns (Credential 'DRepRole)
        , Interns (Credential 'HotCommitteeRole)
        )
  , ToCBOR (GovState era)
  , FromCBOR (GovState era)
  , Default (GovState era)
  , ToJSON (GovState era)
  ) =>
  EraGov era
  where
  type GovState era = (r :: Type) | r -> era

  -- | Construct empty governance state
  emptyGovState :: GovState era
  emptyGovState = GovState era
forall a. Default a => a
def

  -- | Lens for accessing current protocol parameters
  curPParamsGovStateL :: Lens' (GovState era) (PParams era)

  -- | Lens for accessing the previous protocol parameters
  prevPParamsGovStateL :: Lens' (GovState era) (PParams era)

  -- | Lens for accessing the future protocol parameters.
  --
  -- This lens will produce `DefinitePParamsUpdate` whenever we are absolutely sure that
  -- the new PParams will be updated. Which means there will be no chance of a
  -- `DefinitePParamsUpdate` value until we are past the point of no return, which is 2
  -- stability windows before the end of the epoch. This lens is mostly intended for
  -- ledger usage and `nextEpochUpdatedPParams` should be used instead whenever definite
  -- results are desired.
  futurePParamsGovStateL :: Lens' (GovState era) (FuturePParams era)

  obligationGovState :: GovState era -> Obligations

data FuturePParams era
  = -- | This indicates that there is definitely not going to be an update to PParams
    -- expected at the next epoch boundary.
    NoPParamsUpdate
  | -- | This case specifies the PParams that will be adopted at the next epoch boundary.
    DefinitePParamsUpdate !(PParams era)
  | -- | With this case there is no guarantee that these will be the new PParams, users
    -- should not rely on this value to be computed efficiently and should use
    -- `nextEpochPParams` instead. The field is lazy on purpose, since we truly need to
    -- compute this field only towards the end of the epoch, which is done by
    -- `solidifyFuturePParams` two stability windows before the end of the epoch.
    PotentialPParamsUpdate (Maybe (PParams era))
  deriving ((forall x. FuturePParams era -> Rep (FuturePParams era) x)
-> (forall x. Rep (FuturePParams era) x -> FuturePParams era)
-> Generic (FuturePParams era)
forall x. Rep (FuturePParams era) x -> FuturePParams era
forall x. FuturePParams era -> Rep (FuturePParams era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (FuturePParams era) x -> FuturePParams era
forall era x. FuturePParams era -> Rep (FuturePParams era) x
$cfrom :: forall era x. FuturePParams era -> Rep (FuturePParams era) x
from :: forall x. FuturePParams era -> Rep (FuturePParams era) x
$cto :: forall era x. Rep (FuturePParams era) x -> FuturePParams era
to :: forall x. Rep (FuturePParams era) x -> FuturePParams era
Generic)

instance Default (FuturePParams era) where
  def :: FuturePParams era
def = FuturePParams era
forall era. FuturePParams era
NoPParamsUpdate

instance ToJSON (PParams era) => ToJSON (FuturePParams era)

-- | Return new PParams only when it is known that there was an update proposed and it is
-- guaranteed to be applied
knownFuturePParams :: FuturePParams era -> Maybe (PParams era)
knownFuturePParams :: forall era. FuturePParams era -> Maybe (PParams era)
knownFuturePParams = \case
  DefinitePParamsUpdate PParams era
pp -> PParams era -> Maybe (PParams era)
forall a. a -> Maybe a
Just PParams era
pp
  FuturePParams era
_ -> Maybe (PParams era)
forall a. Maybe a
Nothing

-- | This function is guaranteed to produce `PParams` that will be adopted at the next
-- epoch boundary, whenever this function is applied to the `GovState` that was produced
-- by ledger at any point that is two stability windows before the end of the epoch. If
-- you need to know if there were actual changes to those PParams then use
-- `nextEpochUpdatedPParams` instead.
nextEpochPParams :: EraGov era => GovState era -> PParams era
nextEpochPParams :: forall era. EraGov era => GovState era -> PParams era
nextEpochPParams GovState era
govState =
  PParams era -> StrictMaybe (PParams era) -> PParams era
forall a. a -> StrictMaybe a -> a
fromSMaybe (GovState era
govState GovState era
-> Getting (PParams era) (GovState era) (PParams era)
-> PParams era
forall s a. s -> Getting a s a -> a
^. Getting (PParams era) (GovState era) (PParams era)
forall era. EraGov era => Lens' (GovState era) (PParams era)
Lens' (GovState era) (PParams era)
curPParamsGovStateL) (StrictMaybe (PParams era) -> PParams era)
-> StrictMaybe (PParams era) -> PParams era
forall a b. (a -> b) -> a -> b
$ GovState era -> StrictMaybe (PParams era)
forall era. EraGov era => GovState era -> StrictMaybe (PParams era)
nextEpochUpdatedPParams GovState era
govState

-- | This function is guaranteed to return updated PParams when it is called during the
-- last two stability windows of the epoch and there were proposals to update PParams that
-- all relevant parties reached consensus on. In other words whenever there is a definite
-- update to PParams coming on the epoch boundary those PParams will be returned,
-- otherwise it will return `Nothing`. This function is inexpensive and can be invoked at
-- any time without danger of forcing some suspended computation.
nextEpochUpdatedPParams :: EraGov era => GovState era -> StrictMaybe (PParams era)
nextEpochUpdatedPParams :: forall era. EraGov era => GovState era -> StrictMaybe (PParams era)
nextEpochUpdatedPParams GovState era
govState =
  Maybe (PParams era) -> StrictMaybe (PParams era)
forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe (Maybe (PParams era) -> StrictMaybe (PParams era))
-> Maybe (PParams era) -> StrictMaybe (PParams era)
forall a b. (a -> b) -> a -> b
$ FuturePParams era -> Maybe (PParams era)
forall era. FuturePParams era -> Maybe (PParams era)
knownFuturePParams (GovState era
govState GovState era
-> Getting (FuturePParams era) (GovState era) (FuturePParams era)
-> FuturePParams era
forall s a. s -> Getting a s a -> a
^. Getting (FuturePParams era) (GovState era) (FuturePParams era)
forall era. EraGov era => Lens' (GovState era) (FuturePParams era)
Lens' (GovState era) (FuturePParams era)
futurePParamsGovStateL)

solidifyFuturePParams :: FuturePParams era -> FuturePParams era
solidifyFuturePParams :: forall era. FuturePParams era -> FuturePParams era
solidifyFuturePParams = \case
  -- Here we convert a potential to a definite update:
  PotentialPParamsUpdate Maybe (PParams era)
Nothing -> FuturePParams era
forall era. FuturePParams era
NoPParamsUpdate
  PotentialPParamsUpdate (Just PParams era
pp) -> PParams era -> FuturePParams era
forall era. PParams era -> FuturePParams era
DefinitePParamsUpdate PParams era
pp
  FuturePParams era
fpp -> FuturePParams era
fpp

deriving stock instance Eq (PParams era) => Eq (FuturePParams era)

deriving stock instance Show (PParams era) => Show (FuturePParams era)

deriving via AllowThunk (FuturePParams era) instance NoThunks (FuturePParams era)

instance (Typeable era, EncCBOR (PParams era)) => EncCBOR (FuturePParams era) where
  encCBOR :: FuturePParams era -> Encoding
encCBOR =
    Encode 'Open (FuturePParams era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode 'Open (FuturePParams era) -> Encoding)
-> (FuturePParams era -> Encode 'Open (FuturePParams era))
-> FuturePParams era
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      FuturePParams era
NoPParamsUpdate -> FuturePParams era -> Word -> Encode 'Open (FuturePParams era)
forall t. t -> Word -> Encode 'Open t
Sum FuturePParams era
forall era. FuturePParams era
NoPParamsUpdate Word
0
      DefinitePParamsUpdate PParams era
pp -> (PParams era -> FuturePParams era)
-> Word -> Encode 'Open (PParams era -> FuturePParams era)
forall t. t -> Word -> Encode 'Open t
Sum PParams era -> FuturePParams era
forall era. PParams era -> FuturePParams era
DefinitePParamsUpdate Word
1 Encode 'Open (PParams era -> FuturePParams era)
-> Encode ('Closed 'Dense) (PParams era)
-> Encode 'Open (FuturePParams era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> PParams era -> Encode ('Closed 'Dense) (PParams era)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To PParams era
pp
      PotentialPParamsUpdate Maybe (PParams era)
pp -> (Maybe (PParams era) -> FuturePParams era)
-> Word -> Encode 'Open (Maybe (PParams era) -> FuturePParams era)
forall t. t -> Word -> Encode 'Open t
Sum Maybe (PParams era) -> FuturePParams era
forall era. Maybe (PParams era) -> FuturePParams era
PotentialPParamsUpdate Word
2 Encode 'Open (Maybe (PParams era) -> FuturePParams era)
-> Encode ('Closed 'Dense) (Maybe (PParams era))
-> Encode 'Open (FuturePParams era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> Maybe (PParams era)
-> Encode ('Closed 'Dense) (Maybe (PParams era))
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To Maybe (PParams era)
pp

instance (Typeable era, DecCBOR (PParams era)) => DecCBOR (FuturePParams era) where
  decCBOR :: forall s. Decoder s (FuturePParams era)
decCBOR = Decode ('Closed 'Dense) (FuturePParams era)
-> Decoder s (FuturePParams era)
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (Decode ('Closed 'Dense) (FuturePParams era)
 -> Decoder s (FuturePParams era))
-> ((Word -> Decode 'Open (FuturePParams era))
    -> Decode ('Closed 'Dense) (FuturePParams era))
-> (Word -> Decode 'Open (FuturePParams era))
-> Decoder s (FuturePParams era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text
-> (Word -> Decode 'Open (FuturePParams era))
-> Decode ('Closed 'Dense) (FuturePParams era)
forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"FuturePParams" ((Word -> Decode 'Open (FuturePParams era))
 -> Decoder s (FuturePParams era))
-> (Word -> Decode 'Open (FuturePParams era))
-> Decoder s (FuturePParams era)
forall a b. (a -> b) -> a -> b
$ \case
    Word
0 -> FuturePParams era -> Decode 'Open (FuturePParams era)
forall t. t -> Decode 'Open t
SumD FuturePParams era
forall era. FuturePParams era
NoPParamsUpdate
    Word
1 -> (PParams era -> FuturePParams era)
-> Decode 'Open (PParams era -> FuturePParams era)
forall t. t -> Decode 'Open t
SumD PParams era -> FuturePParams era
forall era. PParams era -> FuturePParams era
DefinitePParamsUpdate Decode 'Open (PParams era -> FuturePParams era)
-> Decode ('Closed Any) (PParams era)
-> Decode 'Open (FuturePParams era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (PParams era)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
2 -> (Maybe (PParams era) -> FuturePParams era)
-> Decode 'Open (Maybe (PParams era) -> FuturePParams era)
forall t. t -> Decode 'Open t
SumD Maybe (PParams era) -> FuturePParams era
forall era. Maybe (PParams era) -> FuturePParams era
PotentialPParamsUpdate Decode 'Open (Maybe (PParams era) -> FuturePParams era)
-> Decode ('Closed Any) (Maybe (PParams era))
-> Decode 'Open (FuturePParams era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (Maybe (PParams era))
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
k -> Word -> Decode 'Open (FuturePParams era)
forall (w :: Wrapped) t. Word -> Decode w t
Invalid Word
k

instance NFData (PParams era) => NFData (FuturePParams era) where
  rnf :: FuturePParams era -> ()
rnf = \case
    FuturePParams era
NoPParamsUpdate -> ()
    PotentialPParamsUpdate Maybe (PParams era)
pp -> Maybe (PParams era) -> ()
forall a. NFData a => a -> ()
rnf Maybe (PParams era)
pp
    DefinitePParamsUpdate PParams era
pp -> PParams era -> ()
forall a. NFData a => a -> ()
rnf PParams era
pp