{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Cardano.Ledger.Conway.Rules.Ratify (
  RatifyState (..),
  committeeAccepted,
  committeeAcceptedRatio,
  spoAccepted,
  spoAcceptedRatio,
  dRepAccepted,
  dRepAcceptedRatio,
  acceptedByEveryone,
  -- Testing
  prevActionAsExpected,
  validCommitteeTerm,
  withdrawalCanWithdraw,
) where

import Cardano.Ledger.BaseTypes (
  BoundedRational (..),
  ProtVer,
  ShelleyBase,
  StrictMaybe (..),
  addEpochInterval,
 )
import Cardano.Ledger.CertState (CommitteeAuthorization (..), CommitteeState (csCommitteeCreds))
import Cardano.Ledger.Coin (Coin (..), CompactForm (..))
import Cardano.Ledger.Conway.Core (
  Era (EraCrypto),
  EraGov,
  EraRule,
  PParams,
 )
import Cardano.Ledger.Conway.Era (ConwayENACT, ConwayRATIFY)
import Cardano.Ledger.Conway.Governance (
  Committee (..),
  DefaultVote (..),
  GovAction (..),
  GovActionState (..),
  GovRelation,
  ProposalProcedure (..),
  RatifyEnv (..),
  RatifySignal (..),
  RatifyState (..),
  Vote (..),
  defaultStakePoolVote,
  ensCommitteeL,
  ensProtVerL,
  ensTreasuryL,
  gasAction,
  rsDelayedL,
  rsEnactStateL,
  rsEnactedL,
  rsExpiredL,
  votingCommitteeThreshold,
  votingDRepThreshold,
  votingStakePoolThreshold,
  withGovActionParent,
 )
import Cardano.Ledger.Conway.PParams (
  ConwayEraPParams,
  ppCommitteeMaxTermLengthL,
 )
import Cardano.Ledger.Conway.Rules.Enact (EnactSignal (..), EnactState (..))
import Cardano.Ledger.Credential (Credential (..))
import Cardano.Ledger.DRep (DRep (..), DRepState (..))
import Cardano.Ledger.Keys (KeyRole (..))
import Cardano.Ledger.PoolDistr (PoolDistr (..), individualTotalPoolStake)
import Cardano.Ledger.Shelley.HardForks (bootstrapPhase)
import Cardano.Ledger.Slot (EpochNo (..))
import Cardano.Ledger.Val (Val (..), (<+>))
import Control.State.Transition.Extended (
  Embed (..),
  STS (..),
  TRC (..),
  TransitionRule,
  judgmentContext,
  trans,
 )
import Data.Foldable (Foldable (..))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Ratio ((%))
import qualified Data.Sequence as Seq
import qualified Data.Sequence.Strict as SSeq
import qualified Data.Set as Set
import Data.Void (Void, absurd)
import Lens.Micro

instance
  ( ConwayEraPParams era
  , Embed (EraRule "ENACT" era) (ConwayRATIFY era)
  , State (EraRule "ENACT" era) ~ EnactState era
  , Environment (EraRule "ENACT" era) ~ ()
  , Signal (EraRule "ENACT" era) ~ EnactSignal era
  ) =>
  STS (ConwayRATIFY era)
  where
  type Environment (ConwayRATIFY era) = RatifyEnv era
  type PredicateFailure (ConwayRATIFY era) = Void
  type Signal (ConwayRATIFY era) = RatifySignal era
  type State (ConwayRATIFY era) = RatifyState era
  type BaseM (ConwayRATIFY era) = ShelleyBase

  initialRules :: [InitialRule (ConwayRATIFY era)]
initialRules = []
  transitionRules :: [TransitionRule (ConwayRATIFY era)]
transitionRules = [forall era.
(Embed (EraRule "ENACT" era) (ConwayRATIFY era),
 State (EraRule "ENACT" era) ~ EnactState era,
 Environment (EraRule "ENACT" era) ~ (),
 Signal (EraRule "ENACT" era) ~ EnactSignal era,
 ConwayEraPParams era) =>
TransitionRule (ConwayRATIFY era)
ratifyTransition]

-- Compute the ratio yes/(yes + no), where
-- yes:
--      - the number of registered, unexpired, unresigned committee members that voted yes
-- no:
--      - the number of registered, unexpired, unresigned committee members that voted no, plus
--      - the number of registered, unexpired, unresigned committee members that did not vote for this action
--
-- We iterate over the committee, and incrementally construct the numerator and denominator,
-- based on the votes and the committee state.
committeeAccepted ::
  ConwayEraPParams era =>
  RatifyEnv era ->
  RatifyState era ->
  GovActionState era ->
  Bool
committeeAccepted :: forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
committeeAccepted RatifyEnv {CommitteeState era
reCommitteeState :: forall era. RatifyEnv era -> CommitteeState era
reCommitteeState :: CommitteeState era
reCommitteeState, EpochNo
reCurrentEpoch :: forall era. RatifyEnv era -> EpochNo
reCurrentEpoch :: EpochNo
reCurrentEpoch} RatifyState era
rs GovActionState era
gas =
  case forall era.
ConwayEraPParams era =>
EpochNo
-> RatifyState era
-> CommitteeState era
-> GovAction era
-> StrictMaybe UnitInterval
votingCommitteeThreshold EpochNo
reCurrentEpoch RatifyState era
rs CommitteeState era
reCommitteeState (forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas) of
    StrictMaybe UnitInterval
SNothing -> Bool
False -- this happens if we have no committee, or if the committee is too small,
    -- in which case the committee vote is `no`
    SJust UnitInterval
r ->
      -- short circuit on zero threshold, in which case the committee vote is `yes`
      UnitInterval
r forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
minBound Bool -> Bool -> Bool
|| Rational
acceptedRatio forall a. Ord a => a -> a -> Bool
>= forall r. BoundedRational r => r -> Rational
unboundRational UnitInterval
r
  where
    acceptedRatio :: Rational
acceptedRatio =
      forall era.
Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
-> Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote
-> CommitteeState era
-> EpochNo
-> Rational
committeeAcceptedRatio Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
members (forall era.
GovActionState era
-> Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote
gasCommitteeVotes GovActionState era
gas) CommitteeState era
reCommitteeState EpochNo
reCurrentEpoch
    members :: Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
members = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' forall era.
Committee era
-> Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
committeeMembers (RatifyState era
rs forall s a. s -> Getting a s a -> a
^. forall era. Lens' (RatifyState era) (EnactState era)
rsEnactStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EnactState era) (StrictMaybe (Committee era))
ensCommitteeL)

committeeAcceptedRatio ::
  forall era.
  Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo ->
  Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote ->
  CommitteeState era ->
  EpochNo ->
  Rational
committeeAcceptedRatio :: forall era.
Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
-> Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote
-> CommitteeState era
-> EpochNo
-> Rational
committeeAcceptedRatio Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
members Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote
votes CommitteeState era
committeeState EpochNo
currentEpoch
  | Integer
totalExcludingAbstain forall a. Eq a => a -> a -> Bool
== Integer
0 = Rational
0
  | Bool
otherwise = Integer
yesVotes forall a. Integral a => a -> a -> Ratio a
% Integer
totalExcludingAbstain
  where
    accumVotes ::
      (Integer, Integer) ->
      Credential 'ColdCommitteeRole (EraCrypto era) ->
      EpochNo ->
      (Integer, Integer)
    accumVotes :: (Integer, Integer)
-> Credential 'ColdCommitteeRole (EraCrypto era)
-> EpochNo
-> (Integer, Integer)
accumVotes (!Integer
yes, !Integer
tot) Credential 'ColdCommitteeRole (EraCrypto era)
member EpochNo
expiry
      | EpochNo
currentEpoch forall a. Ord a => a -> a -> Bool
> EpochNo
expiry = (Integer
yes, Integer
tot) -- member is expired, vote "abstain" (don't count it)
      | Bool
otherwise =
          case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'ColdCommitteeRole (EraCrypto era)
member (forall era.
CommitteeState era
-> Map
     (Credential 'ColdCommitteeRole (EraCrypto era))
     (CommitteeAuthorization (EraCrypto era))
csCommitteeCreds CommitteeState era
committeeState) of
            Maybe (CommitteeAuthorization (EraCrypto era))
Nothing -> (Integer
yes, Integer
tot) -- member is not registered, vote "abstain"
            Just (CommitteeMemberResigned StrictMaybe (Anchor (EraCrypto era))
_) -> (Integer
yes, Integer
tot) -- member has resigned, vote "abstain"
            Just (CommitteeHotCredential Credential 'HotCommitteeRole (EraCrypto era)
hotKey) ->
              case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'HotCommitteeRole (EraCrypto era)
hotKey Map (Credential 'HotCommitteeRole (EraCrypto era)) Vote
votes of
                Maybe Vote
Nothing -> (Integer
yes, Integer
tot forall a. Num a => a -> a -> a
+ Integer
1) -- member hasn't voted, vote "no"
                Just Vote
Abstain -> (Integer
yes, Integer
tot) -- member voted "abstain"
                Just Vote
VoteNo -> (Integer
yes, Integer
tot forall a. Num a => a -> a -> a
+ Integer
1) -- member voted "no"
                Just Vote
VoteYes -> (Integer
yes forall a. Num a => a -> a -> a
+ Integer
1, Integer
tot forall a. Num a => a -> a -> a
+ Integer
1) -- member voted "yes"
    (Integer
yesVotes, Integer
totalExcludingAbstain) = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (Integer, Integer)
-> Credential 'ColdCommitteeRole (EraCrypto era)
-> EpochNo
-> (Integer, Integer)
accumVotes (Integer
0, Integer
0) Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
members

spoAccepted ::
  ConwayEraPParams era => RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
spoAccepted :: forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
spoAccepted RatifyEnv era
re RatifyState era
rs GovActionState era
gas =
  case forall era.
ConwayEraPParams era =>
RatifyState era -> GovAction era -> StrictMaybe UnitInterval
votingStakePoolThreshold RatifyState era
rs (forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas) of
    -- Short circuit on zero threshold in order to avoid redundant computation.
    SJust UnitInterval
r ->
      UnitInterval
r forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
minBound Bool -> Bool -> Bool
|| forall era.
RatifyEnv era -> GovActionState era -> ProtVer -> Rational
spoAcceptedRatio RatifyEnv era
re GovActionState era
gas (RatifyState era
rs forall s a. s -> Getting a s a -> a
^. forall era. Lens' (RatifyState era) (EnactState era)
rsEnactStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. EraPParams era => Lens' (EnactState era) ProtVer
ensProtVerL) forall a. Ord a => a -> a -> Bool
>= forall r. BoundedRational r => r -> Rational
unboundRational UnitInterval
r
    StrictMaybe UnitInterval
SNothing -> Bool
False

-- | Final ratio for `totalAcceptedStakePoolsRatio` we want during the bootstrap period is:
-- t = y \/ (s - a)
-- Where:
--  * `y` - total delegated stake that voted Yes
--  * `a` - total delegated stake that voted Abstain
--  * `s` - total delegated stake
--
-- For `HardForkInitiation` all SPOs that didn't vote are considered as
-- `No` votes. Whereas, for all other `GovAction`s, SPOs that didn't
-- vote are considered as `Abstain` votes.
--
-- `No` votes are not counted.
-- After the bootstrap period if an SPO didn't vote, it will be considered as a `No` vote by default.
-- The only exceptions are when a pool delegated to an `AlwaysNoConfidence` or an `AlwaysAbstain` DRep.
-- In those cases, behaviour is as expected: vote `Yes` on `NoConfidence` proposals in case of the former and
-- and vote `Abstain` by default in case of the latter. For `HardForkInitiation`, behaviour is the same as
-- during the bootstrap period: if an SPO didn't vote, their vote will always count as `No`.
spoAcceptedRatio :: forall era. RatifyEnv era -> GovActionState era -> ProtVer -> Rational
spoAcceptedRatio :: forall era.
RatifyEnv era -> GovActionState era -> ProtVer -> Rational
spoAcceptedRatio
  RatifyEnv
    { reStakePoolDistr :: forall era. RatifyEnv era -> PoolDistr (EraCrypto era)
reStakePoolDistr = PoolDistr Map
  (KeyHash 'StakePool (EraCrypto era))
  (IndividualPoolStake (EraCrypto era))
individualPoolStake (CompactCoin Word64
totalActiveStake)
    , Map (Credential 'Staking (EraCrypto era)) (DRep (EraCrypto era))
reDelegatees :: forall era.
RatifyEnv era
-> Map (Credential 'Staking (EraCrypto era)) (DRep (EraCrypto era))
reDelegatees :: Map (Credential 'Staking (EraCrypto era)) (DRep (EraCrypto era))
reDelegatees
    , Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
rePoolParams :: forall era.
RatifyEnv era
-> Map
     (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
rePoolParams :: Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
rePoolParams
    }
  GovActionState
    { Map (KeyHash 'StakePool (EraCrypto era)) Vote
gasStakePoolVotes :: forall era.
GovActionState era -> Map (KeyHash 'StakePool (EraCrypto era)) Vote
gasStakePoolVotes :: Map (KeyHash 'StakePool (EraCrypto era)) Vote
gasStakePoolVotes
    , gasProposalProcedure :: forall era. GovActionState era -> ProposalProcedure era
gasProposalProcedure = ProposalProcedure {GovAction era
pProcGovAction :: forall era. ProposalProcedure era -> GovAction era
pProcGovAction :: GovAction era
pProcGovAction}
    }
  ProtVer
pv
    | Word64
totalActiveStake forall a. Eq a => a -> a -> Bool
== Word64
0 = Rational
0 -- guard against the degenerate case when active stake is zero.
    | Word64
totalActiveStake forall a. Eq a => a -> a -> Bool
== Word64
abstainStake = Rational
0 -- guard against the degenerate case when all abstain.
    | Bool
otherwise = forall a. Integral a => a -> Integer
toInteger Word64
yesStake forall a. Integral a => a -> a -> Ratio a
% forall a. Integral a => a -> Integer
toInteger (Word64
totalActiveStake forall a. Num a => a -> a -> a
- Word64
abstainStake)
    where
      accumStake :: (Word64, Word64)
-> KeyHash 'StakePool (EraCrypto era)
-> IndividualPoolStake (EraCrypto era)
-> (Word64, Word64)
accumStake (!Word64
yes, !Word64
abstain) KeyHash 'StakePool (EraCrypto era)
poolId IndividualPoolStake (EraCrypto era)
distr =
        let CompactCoin Word64
stake = forall c. IndividualPoolStake c -> CompactForm Coin
individualTotalPoolStake IndividualPoolStake (EraCrypto era)
distr
            vote :: Maybe Vote
vote = forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash 'StakePool (EraCrypto era)
poolId Map (KeyHash 'StakePool (EraCrypto era)) Vote
gasStakePoolVotes
         in case Maybe Vote
vote of
              Maybe Vote
Nothing
                | HardForkInitiation {} <- GovAction era
pProcGovAction -> (Word64
yes, Word64
abstain)
                | ProtVer -> Bool
bootstrapPhase ProtVer
pv -> (Word64
yes, Word64
abstain forall a. Num a => a -> a -> a
+ Word64
stake)
                | Bool
otherwise -> case forall c.
KeyHash 'StakePool c
-> Map (KeyHash 'StakePool c) (PoolParams c)
-> Map (Credential 'Staking c) (DRep c)
-> DefaultVote
defaultStakePoolVote KeyHash 'StakePool (EraCrypto era)
poolId Map
  (KeyHash 'StakePool (EraCrypto era)) (PoolParams (EraCrypto era))
rePoolParams Map (Credential 'Staking (EraCrypto era)) (DRep (EraCrypto era))
reDelegatees of
                    DefaultVote
DefaultNoConfidence
                      | NoConfidence {} <- GovAction era
pProcGovAction -> (Word64
yes forall a. Num a => a -> a -> a
+ Word64
stake, Word64
abstain)
                    DefaultVote
DefaultAbstain -> (Word64
yes, Word64
abstain forall a. Num a => a -> a -> a
+ Word64
stake)
                    DefaultVote
_ -> (Word64
yes, Word64
abstain) -- Default is No, unless overridden by one of the above cases
              Just Vote
Abstain -> (Word64
yes, Word64
abstain forall a. Num a => a -> a -> a
+ Word64
stake)
              Just Vote
VoteNo -> (Word64
yes, Word64
abstain)
              Just Vote
VoteYes -> (Word64
yes forall a. Num a => a -> a -> a
+ Word64
stake, Word64
abstain)
      (Word64
yesStake, Word64
abstainStake) =
        forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (Word64, Word64)
-> KeyHash 'StakePool (EraCrypto era)
-> IndividualPoolStake (EraCrypto era)
-> (Word64, Word64)
accumStake (Word64
0, Word64
0) Map
  (KeyHash 'StakePool (EraCrypto era))
  (IndividualPoolStake (EraCrypto era))
individualPoolStake

dRepAccepted ::
  ConwayEraPParams era => RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
dRepAccepted :: forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
dRepAccepted RatifyEnv era
re RatifyState era
rs GovActionState {Map (Credential 'DRepRole (EraCrypto era)) Vote
gasDRepVotes :: forall era.
GovActionState era
-> Map (Credential 'DRepRole (EraCrypto era)) Vote
gasDRepVotes :: Map (Credential 'DRepRole (EraCrypto era)) Vote
gasDRepVotes, ProposalProcedure era
gasProposalProcedure :: ProposalProcedure era
gasProposalProcedure :: forall era. GovActionState era -> ProposalProcedure era
gasProposalProcedure} =
  case forall era.
ConwayEraPParams era =>
RatifyState era -> GovAction era -> StrictMaybe UnitInterval
votingDRepThreshold RatifyState era
rs GovAction era
govAction of
    SJust UnitInterval
r ->
      -- Short circuit on zero threshold in order to avoid redundant computation.
      UnitInterval
r forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
minBound
        Bool -> Bool -> Bool
|| forall era.
RatifyEnv era
-> Map (Credential 'DRepRole (EraCrypto era)) Vote
-> GovAction era
-> Rational
dRepAcceptedRatio RatifyEnv era
re Map (Credential 'DRepRole (EraCrypto era)) Vote
gasDRepVotes GovAction era
govAction forall a. Ord a => a -> a -> Bool
>= forall r. BoundedRational r => r -> Rational
unboundRational UnitInterval
r
    StrictMaybe UnitInterval
SNothing -> Bool
False
  where
    govAction :: GovAction era
govAction = forall era. ProposalProcedure era -> GovAction era
pProcGovAction ProposalProcedure era
gasProposalProcedure

-- Compute the dRep ratio yes/(yes + no), where
-- yes: is the total stake of
--    - registered dReps that voted 'yes', plus
--    - the AlwaysNoConfidence dRep, in case the action is NoConfidence
-- no: is the total stake of
--    - registered dReps that voted 'no', plus
--    - registered dReps that did not vote for this action, plus
--    - the AlwaysNoConfidence dRep
-- In other words, the denominator `yes + no` is the total stake of all registered dReps, minus the abstain votes stake
-- (both credential DReps and AlwaysAbstain)
--
-- We iterate over the dRep distribution, and incrementally construct the numerator and denominator.
dRepAcceptedRatio ::
  forall era.
  RatifyEnv era ->
  Map (Credential 'DRepRole (EraCrypto era)) Vote ->
  GovAction era ->
  Rational
dRepAcceptedRatio :: forall era.
RatifyEnv era
-> Map (Credential 'DRepRole (EraCrypto era)) Vote
-> GovAction era
-> Rational
dRepAcceptedRatio RatifyEnv {Map (DRep (EraCrypto era)) (CompactForm Coin)
reDRepDistr :: forall era.
RatifyEnv era -> Map (DRep (EraCrypto era)) (CompactForm Coin)
reDRepDistr :: Map (DRep (EraCrypto era)) (CompactForm Coin)
reDRepDistr, Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
reDRepState :: forall era.
RatifyEnv era
-> Map
     (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
reDRepState :: Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
reDRepState, EpochNo
reCurrentEpoch :: EpochNo
reCurrentEpoch :: forall era. RatifyEnv era -> EpochNo
reCurrentEpoch} Map (Credential 'DRepRole (EraCrypto era)) Vote
gasDRepVotes GovAction era
govAction
  | Word64
totalExcludingAbstainStake forall a. Eq a => a -> a -> Bool
== Word64
0 = Rational
0
  | Bool
otherwise = forall a. Integral a => a -> Integer
toInteger Word64
yesStake forall a. Integral a => a -> a -> Ratio a
% forall a. Integral a => a -> Integer
toInteger Word64
totalExcludingAbstainStake
  where
    accumStake :: (Word64, Word64)
-> DRep (EraCrypto era) -> CompactForm Coin -> (Word64, Word64)
accumStake (!Word64
yes, !Word64
tot) DRep (EraCrypto era)
drep (CompactCoin Word64
stake) =
      case DRep (EraCrypto era)
drep of
        DRepCredential Credential 'DRepRole (EraCrypto era)
cred ->
          case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole (EraCrypto era)
cred Map
  (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))
reDRepState of
            Maybe (DRepState (EraCrypto era))
Nothing -> (Word64
yes, Word64
tot) -- drep is not registered, so we don't consider it
            Just DRepState (EraCrypto era)
drepState
              | EpochNo
reCurrentEpoch forall a. Ord a => a -> a -> Bool
> forall c. DRepState c -> EpochNo
drepExpiry DRepState (EraCrypto era)
drepState -> (Word64
yes, Word64
tot) -- drep is expired, so we don't consider it
              | Bool
otherwise ->
                  case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential 'DRepRole (EraCrypto era)
cred Map (Credential 'DRepRole (EraCrypto era)) Vote
gasDRepVotes of
                    -- drep hasn't voted for this action, so we don't count
                    -- the vote but we consider it in the denominator:
                    Maybe Vote
Nothing -> (Word64
yes, Word64
tot forall a. Num a => a -> a -> a
+ Word64
stake)
                    Just Vote
VoteYes -> (Word64
yes forall a. Num a => a -> a -> a
+ Word64
stake, Word64
tot forall a. Num a => a -> a -> a
+ Word64
stake)
                    Just Vote
Abstain -> (Word64
yes, Word64
tot)
                    Just Vote
VoteNo -> (Word64
yes, Word64
tot forall a. Num a => a -> a -> a
+ Word64
stake)
        DRep (EraCrypto era)
DRepAlwaysNoConfidence ->
          case GovAction era
govAction of
            NoConfidence StrictMaybe (GovPurposeId 'CommitteePurpose era)
_ -> (Word64
yes forall a. Num a => a -> a -> a
+ Word64
stake, Word64
tot forall a. Num a => a -> a -> a
+ Word64
stake)
            GovAction era
_ -> (Word64
yes, Word64
tot forall a. Num a => a -> a -> a
+ Word64
stake)
        DRep (EraCrypto era)
DRepAlwaysAbstain -> (Word64
yes, Word64
tot)
    (Word64
yesStake, Word64
totalExcludingAbstainStake) = forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (Word64, Word64)
-> DRep (EraCrypto era) -> CompactForm Coin -> (Word64, Word64)
accumStake (Word64
0, Word64
0) Map (DRep (EraCrypto era)) (CompactForm Coin)
reDRepDistr

delayingAction :: GovAction era -> Bool
delayingAction :: forall era. GovAction era -> Bool
delayingAction NoConfidence {} = Bool
True
delayingAction HardForkInitiation {} = Bool
True
delayingAction UpdateCommittee {} = Bool
True
delayingAction NewConstitution {} = Bool
True
delayingAction TreasuryWithdrawals {} = Bool
False
delayingAction ParameterChange {} = Bool
False
delayingAction InfoAction {} = Bool
False

withdrawalCanWithdraw :: GovAction era -> Coin -> Bool
withdrawalCanWithdraw :: forall era. GovAction era -> Coin -> Bool
withdrawalCanWithdraw (TreasuryWithdrawals Map (RewardAccount (EraCrypto era)) Coin
m StrictMaybe (ScriptHash (EraCrypto era))
_) Coin
treasury =
  forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr' forall t. Val t => t -> t -> t
(<+>) forall t. Val t => t
zero Map (RewardAccount (EraCrypto era)) Coin
m forall a. Ord a => a -> a -> Bool
<= Coin
treasury
withdrawalCanWithdraw GovAction era
_ Coin
_ = Bool
True

acceptedByEveryone ::
  ConwayEraPParams era =>
  RatifyEnv era ->
  RatifyState era ->
  GovActionState era ->
  Bool
acceptedByEveryone :: forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
acceptedByEveryone RatifyEnv era
env RatifyState era
st GovActionState era
gas =
  forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
committeeAccepted RatifyEnv era
env RatifyState era
st GovActionState era
gas
    Bool -> Bool -> Bool
&& forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
spoAccepted RatifyEnv era
env RatifyState era
st GovActionState era
gas
    Bool -> Bool -> Bool
&& forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
dRepAccepted RatifyEnv era
env RatifyState era
st GovActionState era
gas

ratifyTransition ::
  forall era.
  ( Embed (EraRule "ENACT" era) (ConwayRATIFY era)
  , State (EraRule "ENACT" era) ~ EnactState era
  , Environment (EraRule "ENACT" era) ~ ()
  , Signal (EraRule "ENACT" era) ~ EnactSignal era
  , ConwayEraPParams era
  ) =>
  TransitionRule (ConwayRATIFY era)
ratifyTransition :: forall era.
(Embed (EraRule "ENACT" era) (ConwayRATIFY era),
 State (EraRule "ENACT" era) ~ EnactState era,
 Environment (EraRule "ENACT" era) ~ (),
 Signal (EraRule "ENACT" era) ~ EnactSignal era,
 ConwayEraPParams era) =>
TransitionRule (ConwayRATIFY era)
ratifyTransition = do
  TRC
    ( env :: Environment (ConwayRATIFY era)
env@RatifyEnv {EpochNo
reCurrentEpoch :: EpochNo
reCurrentEpoch :: forall era. RatifyEnv era -> EpochNo
reCurrentEpoch}
      , st :: State (ConwayRATIFY era)
st@( RatifyState
              rsEnactState :: EnactState era
rsEnactState@EnactState
                { PParams era
ensCurPParams :: forall era. EnactState era -> PParams era
ensCurPParams :: PParams era
ensCurPParams
                , Coin
ensTreasury :: forall era. EnactState era -> Coin
ensTreasury :: Coin
ensTreasury
                , GovRelation StrictMaybe era
ensPrevGovActionIds :: forall era. EnactState era -> GovRelation StrictMaybe era
ensPrevGovActionIds :: GovRelation StrictMaybe era
ensPrevGovActionIds
                }
              Seq (GovActionState era)
_rsEnacted
              Set (GovActionId (EraCrypto era))
_rsExpired
              Bool
rsDelayed
            )
      , RatifySignal StrictSeq (GovActionState era)
rsig
      ) <-
    forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  case StrictSeq (GovActionState era)
rsig of
    gas :: GovActionState era
gas@GovActionState {GovActionId (EraCrypto era)
gasId :: forall era. GovActionState era -> GovActionId (EraCrypto era)
gasId :: GovActionId (EraCrypto era)
gasId, EpochNo
gasExpiresAfter :: forall era. GovActionState era -> EpochNo
gasExpiresAfter :: EpochNo
gasExpiresAfter} SSeq.:<| StrictSeq (GovActionState era)
sigs -> do
      let govAction :: GovAction era
govAction = forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas
      if forall era.
GovActionState era -> GovRelation StrictMaybe era -> Bool
prevActionAsExpected GovActionState era
gas GovRelation StrictMaybe era
ensPrevGovActionIds
        Bool -> Bool -> Bool
&& forall era.
ConwayEraPParams era =>
GovAction era -> PParams era -> EpochNo -> Bool
validCommitteeTerm GovAction era
govAction PParams era
ensCurPParams EpochNo
reCurrentEpoch
        Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
rsDelayed
        Bool -> Bool -> Bool
&& forall era. GovAction era -> Coin -> Bool
withdrawalCanWithdraw GovAction era
govAction Coin
ensTreasury
        Bool -> Bool -> Bool
&& forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
acceptedByEveryone Environment (ConwayRATIFY era)
env State (ConwayRATIFY era)
st GovActionState era
gas
        then do
          EnactState era
newEnactState <-
            forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(EraRule "ENACT" era) forall a b. (a -> b) -> a -> b
$
              forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), EnactState era
rsEnactState, forall era.
GovActionId (EraCrypto era) -> GovAction era -> EnactSignal era
EnactSignal GovActionId (EraCrypto era)
gasId GovAction era
govAction)
          let
            st' :: RatifyState era
st' =
              State (ConwayRATIFY era)
st
                forall a b. a -> (a -> b) -> b
& forall era. Lens' (RatifyState era) (EnactState era)
rsEnactStateL forall s t a b. ASetter s t a b -> b -> s -> t
.~ EnactState era
newEnactState
                forall a b. a -> (a -> b) -> b
& forall era. Lens' (RatifyState era) Bool
rsDelayedL forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall era. GovAction era -> Bool
delayingAction GovAction era
govAction
                forall a b. a -> (a -> b) -> b
& forall era. Lens' (RatifyState era) (Seq (GovActionState era))
rsEnactedL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Seq a -> a -> Seq a
Seq.:|> GovActionState era
gas)
          forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(ConwayRATIFY era) forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (Environment (ConwayRATIFY era)
env, RatifyState era
st', forall era. StrictSeq (GovActionState era) -> RatifySignal era
RatifySignal StrictSeq (GovActionState era)
sigs)
        else do
          -- This action hasn't been ratified yet. Process the remaining actions.
          RatifyState era
st' <- forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(ConwayRATIFY era) forall a b. (a -> b) -> a -> b
$ forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (Environment (ConwayRATIFY era)
env, State (ConwayRATIFY era)
st, forall era. StrictSeq (GovActionState era) -> RatifySignal era
RatifySignal StrictSeq (GovActionState era)
sigs)
          -- Finally, filter out actions that have expired.
          if EpochNo
gasExpiresAfter forall a. Ord a => a -> a -> Bool
< EpochNo
reCurrentEpoch
            then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ RatifyState era
st' forall a b. a -> (a -> b) -> b
& forall era.
Lens' (RatifyState era) (Set (GovActionId (EraCrypto era)))
rsExpiredL forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert GovActionId (EraCrypto era)
gasId
            else forall (f :: * -> *) a. Applicative f => a -> f a
pure RatifyState era
st'
    StrictSeq (GovActionState era)
SSeq.Empty -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ State (ConwayRATIFY era)
st forall a b. a -> (a -> b) -> b
& forall era. Lens' (RatifyState era) (EnactState era)
rsEnactStateL forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall era. Lens' (EnactState era) Coin
ensTreasuryL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Integer -> Coin
Coin Integer
0

-- | Check that the previous governance action id specified in the proposal
-- does match the last one of the same purpose that was enacted.
prevActionAsExpected :: GovActionState era -> GovRelation StrictMaybe era -> Bool
prevActionAsExpected :: forall era.
GovActionState era -> GovRelation StrictMaybe era -> Bool
prevActionAsExpected GovActionState era
gas GovRelation StrictMaybe era
prevGovActionIds =
  forall era a.
GovActionState era
-> a
-> (forall (p :: GovActionPurpose).
    (forall (f :: * -> *).
     Lens' (GovRelation f era) (f (GovPurposeId p era)))
    -> StrictMaybe (GovPurposeId p era) -> GovPurposeId p era -> a)
-> a
withGovActionParent GovActionState era
gas Bool
True forall a b. (a -> b) -> a -> b
$ \forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL StrictMaybe (GovPurposeId p era)
parent GovPurposeId p era
_ ->
    StrictMaybe (GovPurposeId p era)
parent forall a. Eq a => a -> a -> Bool
== GovRelation StrictMaybe era
prevGovActionIds forall s a. s -> Getting a s a -> a
^. forall (f :: * -> *).
Lens' (GovRelation f era) (f (GovPurposeId p era))
govRelationL

validCommitteeTerm ::
  ConwayEraPParams era =>
  GovAction era ->
  PParams era ->
  EpochNo ->
  Bool
validCommitteeTerm :: forall era.
ConwayEraPParams era =>
GovAction era -> PParams era -> EpochNo -> Bool
validCommitteeTerm GovAction era
govAction PParams era
pp EpochNo
currentEpoch =
  case GovAction era
govAction of
    UpdateCommittee StrictMaybe (GovPurposeId 'CommitteePurpose era)
_ Set (Credential 'ColdCommitteeRole (EraCrypto era))
_ Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
newMembers UnitInterval
_ -> Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo -> Bool
withinMaxTermLength Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo
newMembers
    GovAction era
_ -> Bool
True
  where
    committeeMaxTermLength :: EpochInterval
committeeMaxTermLength = PParams era
pp forall s a. s -> Getting a s a -> a
^. forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
ppCommitteeMaxTermLengthL
    withinMaxTermLength :: Map (Credential 'ColdCommitteeRole (EraCrypto era)) EpochNo -> Bool
withinMaxTermLength = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Ord a => a -> a -> Bool
<= EpochNo -> EpochInterval -> EpochNo
addEpochInterval EpochNo
currentEpoch EpochInterval
committeeMaxTermLength)

instance EraGov era => Embed (ConwayENACT era) (ConwayRATIFY era) where
  wrapFailed :: PredicateFailure (ConwayENACT era)
-> PredicateFailure (ConwayRATIFY era)
wrapFailed = forall a. Void -> a
absurd
  wrapEvent :: Event (ConwayENACT era) -> Event (ConwayRATIFY era)
wrapEvent = forall a. Void -> a
absurd