{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.Rules.Enact (
  ConwayENACT,
  EnactSignal (..),
  EnactState (..),
) where

import Cardano.Ledger.Address (RewardAccount (..))
import Cardano.Ledger.BaseTypes
import Cardano.Ledger.Binary (EncCBOR (..))
import Cardano.Ledger.Binary.Coders (Encode (..), encode, (!>))
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Era (ConwayENACT, ConwayEra)
import Cardano.Ledger.Conway.Governance (
  Committee (..),
  EnactState (..),
  GovAction (..),
  GovActionId (..),
  GovPurposeId (GovPurposeId),
  ensCommitteeL,
  ensConstitutionL,
  ensCurPParamsL,
  ensPrevCommitteeL,
  ensPrevConstitutionL,
  ensPrevHardForkL,
  ensPrevPParamUpdateL,
  ensProtVerL,
 )
import Cardano.Ledger.Credential (Credential)
import Cardano.Ledger.Val (Val (..))
import Control.DeepSeq (NFData)
import Control.State.Transition.Extended (
  STS (..),
  TRC (..),
  TransitionRule,
  judgmentContext,
 )
import Data.Foldable (fold)
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.Void (Void)
import GHC.Generics
import Lens.Micro

type instance EraRuleEvent "ENACT" ConwayEra = VoidEraRule "ENACT" ConwayEra

data EnactSignal era = EnactSignal
  { forall era. EnactSignal era -> GovActionId
esGovActionId :: !GovActionId
  , forall era. EnactSignal era -> GovAction era
esGovAction :: !(GovAction era)
  }
  deriving (EnactSignal era -> EnactSignal era -> Bool
(EnactSignal era -> EnactSignal era -> Bool)
-> (EnactSignal era -> EnactSignal era -> Bool)
-> Eq (EnactSignal era)
forall era.
EraPParams era =>
EnactSignal era -> EnactSignal era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall era.
EraPParams era =>
EnactSignal era -> EnactSignal era -> Bool
== :: EnactSignal era -> EnactSignal era -> Bool
$c/= :: forall era.
EraPParams era =>
EnactSignal era -> EnactSignal era -> Bool
/= :: EnactSignal era -> EnactSignal era -> Bool
Eq, Int -> EnactSignal era -> ShowS
[EnactSignal era] -> ShowS
EnactSignal era -> String
(Int -> EnactSignal era -> ShowS)
-> (EnactSignal era -> String)
-> ([EnactSignal era] -> ShowS)
-> Show (EnactSignal era)
forall era. EraPParams era => Int -> EnactSignal era -> ShowS
forall era. EraPParams era => [EnactSignal era] -> ShowS
forall era. EraPParams era => EnactSignal era -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall era. EraPParams era => Int -> EnactSignal era -> ShowS
showsPrec :: Int -> EnactSignal era -> ShowS
$cshow :: forall era. EraPParams era => EnactSignal era -> String
show :: EnactSignal era -> String
$cshowList :: forall era. EraPParams era => [EnactSignal era] -> ShowS
showList :: [EnactSignal era] -> ShowS
Show, (forall x. EnactSignal era -> Rep (EnactSignal era) x)
-> (forall x. Rep (EnactSignal era) x -> EnactSignal era)
-> Generic (EnactSignal era)
forall x. Rep (EnactSignal era) x -> EnactSignal era
forall x. EnactSignal era -> Rep (EnactSignal era) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall era x. Rep (EnactSignal era) x -> EnactSignal era
forall era x. EnactSignal era -> Rep (EnactSignal era) x
$cfrom :: forall era x. EnactSignal era -> Rep (EnactSignal era) x
from :: forall x. EnactSignal era -> Rep (EnactSignal era) x
$cto :: forall era x. Rep (EnactSignal era) x -> EnactSignal era
to :: forall x. Rep (EnactSignal era) x -> EnactSignal era
Generic)

instance EraPParams era => EncCBOR (EnactSignal era) where
  encCBOR :: EnactSignal era -> Encoding
encCBOR x :: EnactSignal era
x@(EnactSignal GovActionId
_ GovAction era
_) =
    let EnactSignal {GovAction era
GovActionId
esGovActionId :: forall era. EnactSignal era -> GovActionId
esGovAction :: forall era. EnactSignal era -> GovAction era
esGovActionId :: GovActionId
esGovAction :: GovAction era
..} = EnactSignal era
x
     in Encode ('Closed 'Dense) (EnactSignal era) -> Encoding
forall (w :: Wrapped) t. Encode w t -> Encoding
encode (Encode ('Closed 'Dense) (EnactSignal era) -> Encoding)
-> Encode ('Closed 'Dense) (EnactSignal era) -> Encoding
forall a b. (a -> b) -> a -> b
$
          (GovActionId -> GovAction era -> EnactSignal era)
-> Encode
     ('Closed 'Dense) (GovActionId -> GovAction era -> EnactSignal era)
forall t. t -> Encode ('Closed 'Dense) t
Rec GovActionId -> GovAction era -> EnactSignal era
forall era. GovActionId -> GovAction era -> EnactSignal era
EnactSignal
            Encode
  ('Closed 'Dense) (GovActionId -> GovAction era -> EnactSignal era)
-> Encode ('Closed 'Dense) GovActionId
-> Encode ('Closed 'Dense) (GovAction era -> EnactSignal era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> GovActionId -> Encode ('Closed 'Dense) GovActionId
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To GovActionId
esGovActionId
            Encode ('Closed 'Dense) (GovAction era -> EnactSignal era)
-> Encode ('Closed 'Dense) (GovAction era)
-> Encode ('Closed 'Dense) (EnactSignal era)
forall (w :: Wrapped) a t (r :: Density).
Encode w (a -> t) -> Encode ('Closed r) a -> Encode w t
!> GovAction era -> Encode ('Closed 'Dense) (GovAction era)
forall t. EncCBOR t => t -> Encode ('Closed 'Dense) t
To GovAction era
esGovAction

instance EraPParams era => NFData (EnactSignal era)

instance EraGov era => STS (ConwayENACT era) where
  type Environment (ConwayENACT era) = ()
  type PredicateFailure (ConwayENACT era) = Void
  type Signal (ConwayENACT era) = EnactSignal era
  type State (ConwayENACT era) = EnactState era
  type BaseM (ConwayENACT era) = ShelleyBase

  initialRules :: [InitialRule (ConwayENACT era)]
initialRules = []
  transitionRules :: [TransitionRule (ConwayENACT era)]
transitionRules = [TransitionRule (ConwayENACT era)
forall era. EraPParams era => TransitionRule (ConwayENACT era)
enactmentTransition]

enactmentTransition :: forall era. EraPParams era => TransitionRule (ConwayENACT era)
enactmentTransition :: forall era. EraPParams era => TransitionRule (ConwayENACT era)
enactmentTransition = do
  TRC ((), State (ConwayENACT era)
st, EnactSignal GovActionId
govActionId GovAction era
act) <- Rule
  (ConwayENACT era)
  'Transition
  (RuleContext 'Transition (ConwayENACT era))
F (Clause (ConwayENACT era) 'Transition) (TRC (ConwayENACT era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext

  EnactState era
-> F (Clause (ConwayENACT era) 'Transition) (EnactState era)
forall a. a -> F (Clause (ConwayENACT era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EnactState era
 -> F (Clause (ConwayENACT era) 'Transition) (EnactState era))
-> EnactState era
-> F (Clause (ConwayENACT era) 'Transition) (EnactState era)
forall a b. (a -> b) -> a -> b
$!
    case GovAction era
act of
      ParameterChange StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
_ PParamsUpdate era
ppup StrictMaybe ScriptHash
_ ->
        State (ConwayENACT era)
EnactState era
st
          EnactState era
-> (EnactState era -> EnactState era) -> EnactState era
forall a b. a -> (a -> b) -> b
& (PParams era -> Identity (PParams era))
-> EnactState era -> Identity (EnactState era)
forall era (f :: * -> *).
Functor f =>
(PParams era -> f (PParams era))
-> EnactState era -> f (EnactState era)
ensCurPParamsL ((PParams era -> Identity (PParams era))
 -> EnactState era -> Identity (EnactState era))
-> (PParams era -> PParams era) -> EnactState era -> EnactState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (PParams era -> PParamsUpdate era -> PParams era
forall era.
EraPParams era =>
PParams era -> PParamsUpdate era -> PParams era
`applyPPUpdates` PParamsUpdate era
ppup)
          EnactState era
-> (EnactState era -> EnactState era) -> EnactState era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
 -> Identity (StrictMaybe (GovPurposeId 'PParamUpdatePurpose)))
-> EnactState era -> Identity (EnactState era)
forall era (f :: * -> *).
Functor f =>
(StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
 -> f (StrictMaybe (GovPurposeId 'PParamUpdatePurpose)))
-> EnactState era -> f (EnactState era)
ensPrevPParamUpdateL ((StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
  -> Identity (StrictMaybe (GovPurposeId 'PParamUpdatePurpose)))
 -> EnactState era -> Identity (EnactState era))
-> StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
-> EnactState era
-> EnactState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ GovPurposeId 'PParamUpdatePurpose
-> StrictMaybe (GovPurposeId 'PParamUpdatePurpose)
forall a. a -> StrictMaybe a
SJust (GovActionId -> GovPurposeId 'PParamUpdatePurpose
forall (p :: GovActionPurpose). GovActionId -> GovPurposeId p
GovPurposeId GovActionId
govActionId)
      HardForkInitiation StrictMaybe (GovPurposeId 'HardForkPurpose)
_ ProtVer
pv ->
        State (ConwayENACT era)
EnactState era
st
          EnactState era
-> (EnactState era -> EnactState era) -> EnactState era
forall a b. a -> (a -> b) -> b
& (ProtVer -> Identity ProtVer)
-> EnactState era -> Identity (EnactState era)
forall era. EraPParams era => Lens' (EnactState era) ProtVer
Lens' (EnactState era) ProtVer
ensProtVerL ((ProtVer -> Identity ProtVer)
 -> EnactState era -> Identity (EnactState era))
-> ProtVer -> EnactState era -> EnactState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ProtVer
pv
          EnactState era
-> (EnactState era -> EnactState era) -> EnactState era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (GovPurposeId 'HardForkPurpose)
 -> Identity (StrictMaybe (GovPurposeId 'HardForkPurpose)))
-> EnactState era -> Identity (EnactState era)
forall era (f :: * -> *).
Functor f =>
(StrictMaybe (GovPurposeId 'HardForkPurpose)
 -> f (StrictMaybe (GovPurposeId 'HardForkPurpose)))
-> EnactState era -> f (EnactState era)
ensPrevHardForkL ((StrictMaybe (GovPurposeId 'HardForkPurpose)
  -> Identity (StrictMaybe (GovPurposeId 'HardForkPurpose)))
 -> EnactState era -> Identity (EnactState era))
-> StrictMaybe (GovPurposeId 'HardForkPurpose)
-> EnactState era
-> EnactState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ GovPurposeId 'HardForkPurpose
-> StrictMaybe (GovPurposeId 'HardForkPurpose)
forall a. a -> StrictMaybe a
SJust (GovActionId -> GovPurposeId 'HardForkPurpose
forall (p :: GovActionPurpose). GovActionId -> GovPurposeId p
GovPurposeId GovActionId
govActionId)
      TreasuryWithdrawals Map RewardAccount Coin
wdrls StrictMaybe ScriptHash
_ ->
        let wdrlsAmount :: Coin
wdrlsAmount = Map RewardAccount Coin -> Coin
forall m. Monoid m => Map RewardAccount m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Map RewardAccount Coin
wdrls
            wdrlsNoNetworkId :: Map (Credential 'Staking) Coin
wdrlsNoNetworkId = (RewardAccount -> Credential 'Staking)
-> Map RewardAccount Coin -> Map (Credential 'Staking) Coin
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys RewardAccount -> Credential 'Staking
raCredential Map RewardAccount Coin
wdrls
         in State (ConwayENACT era)
st
              { ensWithdrawals = Map.unionWith (<>) wdrlsNoNetworkId $ ensWithdrawals st
              , ensTreasury = ensTreasury st <-> wdrlsAmount
              }
      NoConfidence StrictMaybe (GovPurposeId 'CommitteePurpose)
_ ->
        State (ConwayENACT era)
EnactState era
st
          EnactState era
-> (EnactState era -> EnactState era) -> EnactState era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Committee era)
 -> Identity (StrictMaybe (Committee era)))
-> EnactState era -> Identity (EnactState era)
forall era (f :: * -> *).
Functor f =>
(StrictMaybe (Committee era) -> f (StrictMaybe (Committee era)))
-> EnactState era -> f (EnactState era)
ensCommitteeL ((StrictMaybe (Committee era)
  -> Identity (StrictMaybe (Committee era)))
 -> EnactState era -> Identity (EnactState era))
-> StrictMaybe (Committee era) -> EnactState era -> EnactState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ StrictMaybe (Committee era)
forall a. StrictMaybe a
SNothing
          EnactState era
-> (EnactState era -> EnactState era) -> EnactState era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (GovPurposeId 'CommitteePurpose)
 -> Identity (StrictMaybe (GovPurposeId 'CommitteePurpose)))
-> EnactState era -> Identity (EnactState era)
forall era (f :: * -> *).
Functor f =>
(StrictMaybe (GovPurposeId 'CommitteePurpose)
 -> f (StrictMaybe (GovPurposeId 'CommitteePurpose)))
-> EnactState era -> f (EnactState era)
ensPrevCommitteeL ((StrictMaybe (GovPurposeId 'CommitteePurpose)
  -> Identity (StrictMaybe (GovPurposeId 'CommitteePurpose)))
 -> EnactState era -> Identity (EnactState era))
-> StrictMaybe (GovPurposeId 'CommitteePurpose)
-> EnactState era
-> EnactState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ GovPurposeId 'CommitteePurpose
-> StrictMaybe (GovPurposeId 'CommitteePurpose)
forall a. a -> StrictMaybe a
SJust (GovActionId -> GovPurposeId 'CommitteePurpose
forall (p :: GovActionPurpose). GovActionId -> GovPurposeId p
GovPurposeId GovActionId
govActionId)
      UpdateCommittee StrictMaybe (GovPurposeId 'CommitteePurpose)
_ Set (Credential 'ColdCommitteeRole)
membersToRemove Map (Credential 'ColdCommitteeRole) EpochNo
membersToAdd UnitInterval
newThreshold -> do
        State (ConwayENACT era)
EnactState era
st
          EnactState era
-> (EnactState era -> EnactState era) -> EnactState era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (Committee era)
 -> Identity (StrictMaybe (Committee era)))
-> EnactState era -> Identity (EnactState era)
forall era (f :: * -> *).
Functor f =>
(StrictMaybe (Committee era) -> f (StrictMaybe (Committee era)))
-> EnactState era -> f (EnactState era)
ensCommitteeL ((StrictMaybe (Committee era)
  -> Identity (StrictMaybe (Committee era)))
 -> EnactState era -> Identity (EnactState era))
-> (StrictMaybe (Committee era) -> StrictMaybe (Committee era))
-> EnactState era
-> EnactState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Committee era -> StrictMaybe (Committee era)
forall a. a -> StrictMaybe a
SJust (Committee era -> StrictMaybe (Committee era))
-> (StrictMaybe (Committee era) -> Committee era)
-> StrictMaybe (Committee era)
-> StrictMaybe (Committee era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set (Credential 'ColdCommitteeRole)
-> Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval
-> StrictMaybe (Committee era)
-> Committee era
forall era.
Set (Credential 'ColdCommitteeRole)
-> Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval
-> StrictMaybe (Committee era)
-> Committee era
updatedCommittee Set (Credential 'ColdCommitteeRole)
membersToRemove Map (Credential 'ColdCommitteeRole) EpochNo
membersToAdd UnitInterval
newThreshold
          EnactState era
-> (EnactState era -> EnactState era) -> EnactState era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (GovPurposeId 'CommitteePurpose)
 -> Identity (StrictMaybe (GovPurposeId 'CommitteePurpose)))
-> EnactState era -> Identity (EnactState era)
forall era (f :: * -> *).
Functor f =>
(StrictMaybe (GovPurposeId 'CommitteePurpose)
 -> f (StrictMaybe (GovPurposeId 'CommitteePurpose)))
-> EnactState era -> f (EnactState era)
ensPrevCommitteeL ((StrictMaybe (GovPurposeId 'CommitteePurpose)
  -> Identity (StrictMaybe (GovPurposeId 'CommitteePurpose)))
 -> EnactState era -> Identity (EnactState era))
-> StrictMaybe (GovPurposeId 'CommitteePurpose)
-> EnactState era
-> EnactState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ GovPurposeId 'CommitteePurpose
-> StrictMaybe (GovPurposeId 'CommitteePurpose)
forall a. a -> StrictMaybe a
SJust (GovActionId -> GovPurposeId 'CommitteePurpose
forall (p :: GovActionPurpose). GovActionId -> GovPurposeId p
GovPurposeId GovActionId
govActionId)
      NewConstitution StrictMaybe (GovPurposeId 'ConstitutionPurpose)
_ Constitution era
c ->
        State (ConwayENACT era)
EnactState era
st
          EnactState era
-> (EnactState era -> EnactState era) -> EnactState era
forall a b. a -> (a -> b) -> b
& (Constitution era -> Identity (Constitution era))
-> EnactState era -> Identity (EnactState era)
forall era (f :: * -> *).
Functor f =>
(Constitution era -> f (Constitution era))
-> EnactState era -> f (EnactState era)
ensConstitutionL ((Constitution era -> Identity (Constitution era))
 -> EnactState era -> Identity (EnactState era))
-> Constitution era -> EnactState era -> EnactState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Constitution era
c
          EnactState era
-> (EnactState era -> EnactState era) -> EnactState era
forall a b. a -> (a -> b) -> b
& (StrictMaybe (GovPurposeId 'ConstitutionPurpose)
 -> Identity (StrictMaybe (GovPurposeId 'ConstitutionPurpose)))
-> EnactState era -> Identity (EnactState era)
forall era (f :: * -> *).
Functor f =>
(StrictMaybe (GovPurposeId 'ConstitutionPurpose)
 -> f (StrictMaybe (GovPurposeId 'ConstitutionPurpose)))
-> EnactState era -> f (EnactState era)
ensPrevConstitutionL ((StrictMaybe (GovPurposeId 'ConstitutionPurpose)
  -> Identity (StrictMaybe (GovPurposeId 'ConstitutionPurpose)))
 -> EnactState era -> Identity (EnactState era))
-> StrictMaybe (GovPurposeId 'ConstitutionPurpose)
-> EnactState era
-> EnactState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ GovPurposeId 'ConstitutionPurpose
-> StrictMaybe (GovPurposeId 'ConstitutionPurpose)
forall a. a -> StrictMaybe a
SJust (GovActionId -> GovPurposeId 'ConstitutionPurpose
forall (p :: GovActionPurpose). GovActionId -> GovPurposeId p
GovPurposeId GovActionId
govActionId)
      GovAction era
InfoAction -> State (ConwayENACT era)
EnactState era
st

updatedCommittee ::
  Set.Set (Credential 'ColdCommitteeRole) ->
  Map.Map (Credential 'ColdCommitteeRole) EpochNo ->
  UnitInterval ->
  StrictMaybe (Committee era) ->
  Committee era
updatedCommittee :: forall era.
Set (Credential 'ColdCommitteeRole)
-> Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval
-> StrictMaybe (Committee era)
-> Committee era
updatedCommittee Set (Credential 'ColdCommitteeRole)
membersToRemove Map (Credential 'ColdCommitteeRole) EpochNo
membersToAdd UnitInterval
newThreshold StrictMaybe (Committee era)
committee =
  case StrictMaybe (Committee era)
committee of
    StrictMaybe (Committee era)
SNothing -> Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval -> Committee era
forall era.
Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval -> Committee era
Committee Map (Credential 'ColdCommitteeRole) EpochNo
membersToAdd UnitInterval
newThreshold
    SJust (Committee Map (Credential 'ColdCommitteeRole) EpochNo
currentMembers UnitInterval
_) ->
      let newCommitteeMembers :: Map (Credential 'ColdCommitteeRole) EpochNo
newCommitteeMembers =
            Map (Credential 'ColdCommitteeRole) EpochNo
-> Map (Credential 'ColdCommitteeRole) EpochNo
-> Map (Credential 'ColdCommitteeRole) EpochNo
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union
              Map (Credential 'ColdCommitteeRole) EpochNo
membersToAdd
              (Map (Credential 'ColdCommitteeRole) EpochNo
currentMembers Map (Credential 'ColdCommitteeRole) EpochNo
-> Set (Credential 'ColdCommitteeRole)
-> Map (Credential 'ColdCommitteeRole) EpochNo
forall k a. Ord k => Map k a -> Set k -> Map k a
`Map.withoutKeys` Set (Credential 'ColdCommitteeRole)
membersToRemove)
       in Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval -> Committee era
forall era.
Map (Credential 'ColdCommitteeRole) EpochNo
-> UnitInterval -> Committee era
Committee
            Map (Credential 'ColdCommitteeRole) EpochNo
newCommitteeMembers
            UnitInterval
newThreshold