{-# 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.CertState (Obligations)
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential)
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 = 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 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
$cto :: forall era x. Rep (FuturePParams era) x -> FuturePParams era
$cfrom :: forall era x. FuturePParams era -> Rep (FuturePParams era) x
Generic)

instance Default (FuturePParams era) where
  def :: FuturePParams era
def = 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 -> forall a. a -> Maybe a
Just PParams era
pp
  FuturePParams 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 =
  forall a. a -> StrictMaybe a -> a
fromSMaybe (GovState era
govState forall s a. s -> Getting a s a -> a
^. forall era. EraGov era => Lens' (GovState era) (PParams era)
curPParamsGovStateL) forall a b. (a -> b) -> a -> b
$ 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 =
  forall a. Maybe a -> StrictMaybe a
maybeToStrictMaybe forall a b. (a -> b) -> a -> b
$ forall era. FuturePParams era -> Maybe (PParams era)
knownFuturePParams (GovState era
govState forall s a. s -> Getting a s a -> a
^. forall era. EraGov 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 -> forall era. FuturePParams era
NoPParamsUpdate
  PotentialPParamsUpdate (Just PParams era
pp) -> 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 =
    forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      FuturePParams era
NoPParamsUpdate -> forall t. t -> Word -> Encode 'Open t
Sum forall era. FuturePParams era
NoPParamsUpdate Word
0
      DefinitePParamsUpdate PParams era
pp -> forall t. t -> Word -> Encode 'Open t
Sum forall era. PParams era -> FuturePParams era
DefinitePParamsUpdate Word
1 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To PParams era
pp
      PotentialPParamsUpdate Maybe (PParams era)
pp -> forall t. t -> Word -> Encode 'Open t
Sum forall era. Maybe (PParams era) -> FuturePParams era
PotentialPParamsUpdate Word
2 forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> 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 = forall (w :: Wrapped) t s. Decode w t -> Decoder s t
decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t.
Text -> (Word -> Decode 'Open t) -> Decode ('Closed 'Dense) t
Summands Text
"FuturePParams" forall a b. (a -> b) -> a -> b
$ \case
    Word
0 -> forall t. t -> Decode 'Open t
SumD forall era. FuturePParams era
NoPParamsUpdate
    Word
1 -> forall t. t -> Decode 'Open t
SumD forall era. PParams era -> FuturePParams era
DefinitePParamsUpdate forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
2 -> forall t. t -> Decode 'Open t
SumD forall era. Maybe (PParams era) -> FuturePParams era
PotentialPParamsUpdate forall (w1 :: Wrapped) a t (w :: Density).
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! forall t (w :: Wrapped). DecCBOR t => Decode w t
From
    Word
k -> 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 -> forall a. NFData a => a -> ()
rnf Maybe (PParams era)
pp
    DefinitePParamsUpdate PParams era
pp -> forall a. NFData a => a -> ()
rnf PParams era
pp