{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Shelley.Governance (
  EraGov (..),
  ShelleyGovState (..),
  emptyShelleyGovState,
  FuturePParams (..),
  solidifyFuturePParams,
  knownFuturePParams,
  nextEpochPParams,
  nextEpochUpdatedPParams,
  -- Lens
  curPParamsShelleyGovStateL,
  prevPParamsShelleyGovStateL,
  futurePParamsShelleyGovStateL,
) where

import Cardano.Ledger.Binary (
  DecCBOR (decCBOR),
  DecShareCBOR (..),
  EncCBOR (encCBOR),
  FromCBOR (..),
  Interns,
  ToCBOR (..),
  decNoShareCBOR,
 )
import Cardano.Ledger.Binary.Coders (Decode (..), Encode (..), decode, encode, (!>), (<!))
import Cardano.Ledger.Core
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Shelley.Era (ShelleyEra)
import Cardano.Ledger.Shelley.PParams (ProposedPPUpdates, emptyPPPUpdates)
import Cardano.Ledger.State
import Control.DeepSeq (NFData (..))
import Data.Aeson (
  KeyValue,
  ToJSON (..),
  object,
  pairs,
  (.=),
 )
import Data.Default (Default (..))
import GHC.Generics (Generic)
import Lens.Micro (Lens', lens)
import NoThunks.Class (NoThunks (..))

instance EraGov ShelleyEra where
  type GovState ShelleyEra = ShelleyGovState ShelleyEra

  curPParamsGovStateL :: Lens' (GovState ShelleyEra) (PParams ShelleyEra)
curPParamsGovStateL = (PParams ShelleyEra -> f (PParams ShelleyEra))
-> GovState ShelleyEra -> f (GovState ShelleyEra)
(PParams ShelleyEra -> f (PParams ShelleyEra))
-> ShelleyGovState ShelleyEra -> f (ShelleyGovState ShelleyEra)
forall era (f :: * -> *).
Functor f =>
(PParams era -> f (PParams era))
-> ShelleyGovState era -> f (ShelleyGovState era)
curPParamsShelleyGovStateL

  prevPParamsGovStateL :: Lens' (GovState ShelleyEra) (PParams ShelleyEra)
prevPParamsGovStateL = (PParams ShelleyEra -> f (PParams ShelleyEra))
-> GovState ShelleyEra -> f (GovState ShelleyEra)
(PParams ShelleyEra -> f (PParams ShelleyEra))
-> ShelleyGovState ShelleyEra -> f (ShelleyGovState ShelleyEra)
forall era (f :: * -> *).
Functor f =>
(PParams era -> f (PParams era))
-> ShelleyGovState era -> f (ShelleyGovState era)
prevPParamsShelleyGovStateL

  futurePParamsGovStateL :: Lens' (GovState ShelleyEra) (FuturePParams ShelleyEra)
futurePParamsGovStateL = (FuturePParams ShelleyEra -> f (FuturePParams ShelleyEra))
-> GovState ShelleyEra -> f (GovState ShelleyEra)
(FuturePParams ShelleyEra -> f (FuturePParams ShelleyEra))
-> ShelleyGovState ShelleyEra -> f (ShelleyGovState ShelleyEra)
forall era (f :: * -> *).
Functor f =>
(FuturePParams era -> f (FuturePParams era))
-> ShelleyGovState era -> f (ShelleyGovState era)
futurePParamsShelleyGovStateL

  obligationGovState :: GovState ShelleyEra -> Obligations
obligationGovState = Obligations -> ShelleyGovState ShelleyEra -> Obligations
forall a b. a -> b -> a
const Obligations
forall a. Monoid a => a
mempty -- No GovState obigations in ShelleyEra

data ShelleyGovState era = ShelleyGovState
  { forall era. ShelleyGovState era -> ProposedPPUpdates era
sgsCurProposals :: !(ProposedPPUpdates era)
  , forall era. ShelleyGovState era -> ProposedPPUpdates era
sgsFutureProposals :: !(ProposedPPUpdates era)
  , forall era. ShelleyGovState era -> PParams era
sgsCurPParams :: !(PParams era)
  , forall era. ShelleyGovState era -> PParams era
sgsPrevPParams :: !(PParams era)
  , forall era. ShelleyGovState era -> FuturePParams era
sgsFuturePParams :: !(FuturePParams era)
  -- ^ Prediction of parameter changes that might happen on the epoch boundary.
  }
  deriving ((forall x. ShelleyGovState era -> Rep (ShelleyGovState era) x)
-> (forall x. Rep (ShelleyGovState era) x -> ShelleyGovState era)
-> Generic (ShelleyGovState era)
forall x. Rep (ShelleyGovState era) x -> ShelleyGovState era
forall x. ShelleyGovState era -> Rep (ShelleyGovState era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (ShelleyGovState era) x -> ShelleyGovState era
forall era x. ShelleyGovState era -> Rep (ShelleyGovState era) x
$cfrom :: forall era x. ShelleyGovState era -> Rep (ShelleyGovState era) x
from :: forall x. ShelleyGovState era -> Rep (ShelleyGovState era) x
$cto :: forall era x. Rep (ShelleyGovState era) x -> ShelleyGovState era
to :: forall x. Rep (ShelleyGovState era) x -> ShelleyGovState era
Generic)

curPParamsShelleyGovStateL :: Lens' (ShelleyGovState era) (PParams era)
curPParamsShelleyGovStateL :: forall era (f :: * -> *).
Functor f =>
(PParams era -> f (PParams era))
-> ShelleyGovState era -> f (ShelleyGovState era)
curPParamsShelleyGovStateL = (ShelleyGovState era -> PParams era)
-> (ShelleyGovState era -> PParams era -> ShelleyGovState era)
-> Lens
     (ShelleyGovState era)
     (ShelleyGovState era)
     (PParams era)
     (PParams era)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ShelleyGovState era -> PParams era
forall era. ShelleyGovState era -> PParams era
sgsCurPParams (\ShelleyGovState era
sps PParams era
x -> ShelleyGovState era
sps {sgsCurPParams = x})

prevPParamsShelleyGovStateL :: Lens' (ShelleyGovState era) (PParams era)
prevPParamsShelleyGovStateL :: forall era (f :: * -> *).
Functor f =>
(PParams era -> f (PParams era))
-> ShelleyGovState era -> f (ShelleyGovState era)
prevPParamsShelleyGovStateL = (ShelleyGovState era -> PParams era)
-> (ShelleyGovState era -> PParams era -> ShelleyGovState era)
-> Lens
     (ShelleyGovState era)
     (ShelleyGovState era)
     (PParams era)
     (PParams era)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ShelleyGovState era -> PParams era
forall era. ShelleyGovState era -> PParams era
sgsPrevPParams (\ShelleyGovState era
sps PParams era
x -> ShelleyGovState era
sps {sgsPrevPParams = x})

futurePParamsShelleyGovStateL :: Lens' (ShelleyGovState era) (FuturePParams era)
futurePParamsShelleyGovStateL :: forall era (f :: * -> *).
Functor f =>
(FuturePParams era -> f (FuturePParams era))
-> ShelleyGovState era -> f (ShelleyGovState era)
futurePParamsShelleyGovStateL =
  (ShelleyGovState era -> FuturePParams era)
-> (ShelleyGovState era
    -> FuturePParams era -> ShelleyGovState era)
-> Lens
     (ShelleyGovState era)
     (ShelleyGovState era)
     (FuturePParams era)
     (FuturePParams era)
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens ShelleyGovState era -> FuturePParams era
forall era. ShelleyGovState era -> FuturePParams era
sgsFuturePParams (\ShelleyGovState era
sps FuturePParams era
x -> ShelleyGovState era
sps {sgsFuturePParams = x})

deriving instance
  ( Show (PParamsUpdate era)
  , Show (PParams era)
  ) =>
  Show (ShelleyGovState era)

deriving instance
  ( Eq (PParamsUpdate era)
  , Eq (PParams era)
  ) =>
  Eq (ShelleyGovState era)

instance
  ( NFData (PParamsUpdate era)
  , NFData (PParams era)
  ) =>
  NFData (ShelleyGovState era)

instance
  ( NoThunks (PParamsUpdate era)
  , NoThunks (PParams era)
  ) =>
  NoThunks (ShelleyGovState era)

instance
  ( Era era
  , EncCBOR (PParamsUpdate era)
  , EncCBOR (PParams era)
  ) =>
  EncCBOR (ShelleyGovState era)
  where
  encCBOR :: ShelleyGovState era -> Encoding
encCBOR (ShelleyGovState ProposedPPUpdates era
ppup ProposedPPUpdates era
fppup PParams era
pp PParams era
ppp FuturePParams era
fpp) =
    Encode ('Closed 'Dense) (ShelleyGovState era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode ('Closed 'Dense) (ShelleyGovState era) -> Encoding)
-> Encode ('Closed 'Dense) (ShelleyGovState era) -> Encoding
forall a b. (a -> b) -> a -> b
$
      (ProposedPPUpdates era
 -> ProposedPPUpdates era
 -> PParams era
 -> PParams era
 -> FuturePParams era
 -> ShelleyGovState era)
-> Encode
     ('Closed 'Dense)
     (ProposedPPUpdates era
      -> ProposedPPUpdates era
      -> PParams era
      -> PParams era
      -> FuturePParams era
      -> ShelleyGovState era)
forall t. t -> Encode ('Closed 'Dense) t
Rec ProposedPPUpdates era
-> ProposedPPUpdates era
-> PParams era
-> PParams era
-> FuturePParams era
-> ShelleyGovState era
forall era.
ProposedPPUpdates era
-> ProposedPPUpdates era
-> PParams era
-> PParams era
-> FuturePParams era
-> ShelleyGovState era
ShelleyGovState
        Encode
  ('Closed 'Dense)
  (ProposedPPUpdates era
   -> ProposedPPUpdates era
   -> PParams era
   -> PParams era
   -> FuturePParams era
   -> ShelleyGovState era)
-> Encode ('Closed 'Dense) (ProposedPPUpdates era)
-> Encode
     ('Closed 'Dense)
     (ProposedPPUpdates era
      -> PParams era
      -> PParams era
      -> FuturePParams era
      -> ShelleyGovState era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> ProposedPPUpdates era
-> Encode ('Closed 'Dense) (ProposedPPUpdates era)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To ProposedPPUpdates era
ppup
        Encode
  ('Closed 'Dense)
  (ProposedPPUpdates era
   -> PParams era
   -> PParams era
   -> FuturePParams era
   -> ShelleyGovState era)
-> Encode ('Closed 'Dense) (ProposedPPUpdates era)
-> Encode
     ('Closed 'Dense)
     (PParams era
      -> PParams era -> FuturePParams era -> ShelleyGovState era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> ProposedPPUpdates era
-> Encode ('Closed 'Dense) (ProposedPPUpdates era)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To ProposedPPUpdates era
fppup
        Encode
  ('Closed 'Dense)
  (PParams era
   -> PParams era -> FuturePParams era -> ShelleyGovState era)
-> Encode ('Closed 'Dense) (PParams era)
-> Encode
     ('Closed 'Dense)
     (PParams era -> FuturePParams era -> ShelleyGovState 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
        Encode
  ('Closed 'Dense)
  (PParams era -> FuturePParams era -> ShelleyGovState era)
-> Encode ('Closed 'Dense) (PParams era)
-> Encode
     ('Closed 'Dense) (FuturePParams era -> ShelleyGovState 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
ppp
        Encode ('Closed 'Dense) (FuturePParams era -> ShelleyGovState era)
-> Encode ('Closed 'Dense) (FuturePParams era)
-> Encode ('Closed 'Dense) (ShelleyGovState era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> FuturePParams era -> Encode ('Closed 'Dense) (FuturePParams era)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To FuturePParams era
fpp

instance
  ( Era era
  , DecCBOR (PParamsUpdate era)
  , DecCBOR (PParams era)
  ) =>
  DecShareCBOR (ShelleyGovState era)
  where
  type
    Share (ShelleyGovState era) =
      ( Interns (Credential 'Staking)
      , Interns (KeyHash 'StakePool)
      , Interns (Credential 'DRepRole)
      , Interns (Credential 'HotCommitteeRole)
      )
  decShareCBOR :: forall s.
Share (ShelleyGovState era) -> Decoder s (ShelleyGovState era)
decShareCBOR Share (ShelleyGovState era)
_ =
    Decode ('Closed 'Dense) (ShelleyGovState era)
-> Decoder s (ShelleyGovState era)
forall t (w :: Wrapped) s. Typeable t => Decode w t -> Decoder s t
decode (Decode ('Closed 'Dense) (ShelleyGovState era)
 -> Decoder s (ShelleyGovState era))
-> Decode ('Closed 'Dense) (ShelleyGovState era)
-> Decoder s (ShelleyGovState era)
forall a b. (a -> b) -> a -> b
$
      (ProposedPPUpdates era
 -> ProposedPPUpdates era
 -> PParams era
 -> PParams era
 -> FuturePParams era
 -> ShelleyGovState era)
-> Decode
     ('Closed 'Dense)
     (ProposedPPUpdates era
      -> ProposedPPUpdates era
      -> PParams era
      -> PParams era
      -> FuturePParams era
      -> ShelleyGovState era)
forall t. t -> Decode ('Closed 'Dense) t
RecD ProposedPPUpdates era
-> ProposedPPUpdates era
-> PParams era
-> PParams era
-> FuturePParams era
-> ShelleyGovState era
forall era.
ProposedPPUpdates era
-> ProposedPPUpdates era
-> PParams era
-> PParams era
-> FuturePParams era
-> ShelleyGovState era
ShelleyGovState
        Decode
  ('Closed 'Dense)
  (ProposedPPUpdates era
   -> ProposedPPUpdates era
   -> PParams era
   -> PParams era
   -> FuturePParams era
   -> ShelleyGovState era)
-> Decode ('Closed Any) (ProposedPPUpdates era)
-> Decode
     ('Closed 'Dense)
     (ProposedPPUpdates era
      -> PParams era
      -> PParams era
      -> FuturePParams era
      -> ShelleyGovState era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (ProposedPPUpdates era)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        Decode
  ('Closed 'Dense)
  (ProposedPPUpdates era
   -> PParams era
   -> PParams era
   -> FuturePParams era
   -> ShelleyGovState era)
-> Decode ('Closed Any) (ProposedPPUpdates era)
-> Decode
     ('Closed 'Dense)
     (PParams era
      -> PParams era -> FuturePParams era -> ShelleyGovState era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (ProposedPPUpdates era)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From
        Decode
  ('Closed 'Dense)
  (PParams era
   -> PParams era -> FuturePParams era -> ShelleyGovState era)
-> Decode ('Closed Any) (PParams era)
-> Decode
     ('Closed 'Dense)
     (PParams era -> FuturePParams era -> ShelleyGovState 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
        Decode
  ('Closed 'Dense)
  (PParams era -> FuturePParams era -> ShelleyGovState era)
-> Decode ('Closed Any) (PParams era)
-> Decode
     ('Closed 'Dense) (FuturePParams era -> ShelleyGovState 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
        Decode ('Closed 'Dense) (FuturePParams era -> ShelleyGovState era)
-> Decode ('Closed Any) (FuturePParams era)
-> Decode ('Closed 'Dense) (ShelleyGovState era)
forall a (w1 :: Wrapped) t (w :: Density).
Typeable a =>
Decode w1 (a -> t) -> Decode ('Closed w) a -> Decode w1 t
<! Decode ('Closed Any) (FuturePParams era)
forall t (w :: Wrapped). DecCBOR t => Decode w t
From

instance
  ( Era era
  , DecCBOR (PParamsUpdate era)
  , DecCBOR (PParams era)
  ) =>
  DecCBOR (ShelleyGovState era)
  where
  decCBOR :: forall s. Decoder s (ShelleyGovState era)
decCBOR = Decoder s (ShelleyGovState era)
forall a s. DecShareCBOR a => Decoder s a
decNoShareCBOR

instance
  ( Era era
  , EncCBOR (PParamsUpdate era)
  , EncCBOR (PParams era)
  ) =>
  ToCBOR (ShelleyGovState era)
  where
  toCBOR :: ShelleyGovState era -> Encoding
toCBOR = forall era t. (Era era, EncCBOR t) => t -> Encoding
toEraCBOR @era

instance
  ( Era era
  , DecCBOR (PParamsUpdate era)
  , DecCBOR (PParams era)
  ) =>
  FromCBOR (ShelleyGovState era)
  where
  fromCBOR :: forall s. Decoder s (ShelleyGovState era)
fromCBOR = forall era t s. (Era era, DecCBOR t) => Decoder s t
fromEraCBOR @era

instance EraPParams era => ToJSON (ShelleyGovState era) where
  toJSON :: ShelleyGovState era -> Value
toJSON = [Pair] -> Value
object ([Pair] -> Value)
-> (ShelleyGovState era -> [Pair]) -> ShelleyGovState era -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGovState era -> [Pair]
forall e a era.
(KeyValue e a, EraPParams era) =>
ShelleyGovState era -> [a]
toPPUPStatePairs
  toEncoding :: ShelleyGovState era -> Encoding
toEncoding = Series -> Encoding
pairs (Series -> Encoding)
-> (ShelleyGovState era -> Series)
-> ShelleyGovState era
-> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat ([Series] -> Series)
-> (ShelleyGovState era -> [Series])
-> ShelleyGovState era
-> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyGovState era -> [Series]
forall e a era.
(KeyValue e a, EraPParams era) =>
ShelleyGovState era -> [a]
toPPUPStatePairs

toPPUPStatePairs :: (KeyValue e a, EraPParams era) => ShelleyGovState era -> [a]
toPPUPStatePairs :: forall e a era.
(KeyValue e a, EraPParams era) =>
ShelleyGovState era -> [a]
toPPUPStatePairs ShelleyGovState {PParams era
FuturePParams era
ProposedPPUpdates era
sgsCurProposals :: forall era. ShelleyGovState era -> ProposedPPUpdates era
sgsFutureProposals :: forall era. ShelleyGovState era -> ProposedPPUpdates era
sgsCurPParams :: forall era. ShelleyGovState era -> PParams era
sgsPrevPParams :: forall era. ShelleyGovState era -> PParams era
sgsFuturePParams :: forall era. ShelleyGovState era -> FuturePParams era
sgsCurProposals :: ProposedPPUpdates era
sgsFutureProposals :: ProposedPPUpdates era
sgsCurPParams :: PParams era
sgsPrevPParams :: PParams era
sgsFuturePParams :: FuturePParams era
..} =
  [ Key
"proposals" Key -> ProposedPPUpdates era -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ProposedPPUpdates era
sgsCurProposals
  , Key
"futureProposals" Key -> ProposedPPUpdates era -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= ProposedPPUpdates era
sgsFutureProposals
  , Key
"curPParams" Key -> PParams era -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PParams era
sgsCurPParams
  , Key
"prevPParams" Key -> PParams era -> a
forall v. ToJSON v => Key -> v -> a
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= PParams era
sgsPrevPParams
  ]

instance EraPParams era => Default (ShelleyGovState era) where
  def :: ShelleyGovState era
def = ShelleyGovState era
forall era. EraPParams era => ShelleyGovState era
emptyShelleyGovState

emptyShelleyGovState :: EraPParams era => ShelleyGovState era
emptyShelleyGovState :: forall era. EraPParams era => ShelleyGovState era
emptyShelleyGovState =
  ProposedPPUpdates era
-> ProposedPPUpdates era
-> PParams era
-> PParams era
-> FuturePParams era
-> ShelleyGovState era
forall era.
ProposedPPUpdates era
-> ProposedPPUpdates era
-> PParams era
-> PParams era
-> FuturePParams era
-> ShelleyGovState era
ShelleyGovState
    ProposedPPUpdates era
forall era. ProposedPPUpdates era
emptyPPPUpdates
    ProposedPPUpdates era
forall era. ProposedPPUpdates era
emptyPPPUpdates
    PParams era
forall era. EraPParams era => PParams era
emptyPParams
    PParams era
forall era. EraPParams era => PParams era
emptyPParams
    FuturePParams era
forall era. FuturePParams era
NoPParamsUpdate