{-# 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
forall era.
EraPParams era =>
EnactSignal era -> EnactSignal era -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EnactSignal era -> EnactSignal era -> Bool
$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
Eq, Int -> EnactSignal era -> ShowS
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
showList :: [EnactSignal era] -> ShowS
$cshowList :: forall era. EraPParams era => [EnactSignal era] -> ShowS
show :: EnactSignal era -> String
$cshow :: forall era. EraPParams era => EnactSignal era -> String
showsPrec :: Int -> EnactSignal era -> ShowS
$cshowsPrec :: forall era. EraPParams era => Int -> EnactSignal era -> ShowS
Show, 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
$cto :: forall era x. Rep (EnactSignal era) x -> EnactSignal era
$cfrom :: forall era x. EnactSignal era -> Rep (EnactSignal era) x
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
esGovAction :: GovAction era
esGovActionId :: GovActionId
esGovAction :: forall era. EnactSignal era -> GovAction era
esGovActionId :: forall era. EnactSignal era -> GovActionId
..} = EnactSignal era
x
     in forall (w :: Wrapped) t. Encode w t -> Encoding
encode forall a b. (a -> b) -> a -> b
$
          forall t. t -> Encode ('Closed 'Dense) t
Rec forall era. GovActionId -> GovAction era -> EnactSignal era
EnactSignal
            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 GovActionId
esGovActionId
            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 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 = [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) <- forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext

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