{-# 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 (
  ConwayRATIFY,
  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.Coin (Coin (..), CompactForm (..))
import Cardano.Ledger.Conway.Core
import Cardano.Ledger.Conway.Era (ConwayENACT, ConwayRATIFY, hardforkConwayBootstrapPhase)
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.Rules.Enact (EnactSignal (..), EnactState (..))
import Cardano.Ledger.Conway.State
import Cardano.Ledger.Credential (Credential (..))
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 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
  , ConwayEraAccounts 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 = [TransitionRule (ConwayRATIFY era)
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, ConwayEraAccounts 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 :: CommitteeState era
reCommitteeState :: forall era. RatifyEnv era -> CommitteeState era
reCommitteeState, EpochNo
reCurrentEpoch :: EpochNo
reCurrentEpoch :: forall era. RatifyEnv era -> EpochNo
reCurrentEpoch} RatifyState era
rs GovActionState era
gas =
  case EpochNo
-> RatifyState era
-> CommitteeState era
-> GovAction era
-> StrictMaybe UnitInterval
forall era.
ConwayEraPParams era =>
EpochNo
-> RatifyState era
-> CommitteeState era
-> GovAction era
-> StrictMaybe UnitInterval
votingCommitteeThreshold EpochNo
reCurrentEpoch RatifyState era
rs CommitteeState era
reCommitteeState (GovActionState era -> GovAction era
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 UnitInterval -> UnitInterval -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInterval
forall a. Bounded a => a
minBound Bool -> Bool -> Bool
|| Rational
acceptedRatio Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational UnitInterval
r
  where
    acceptedRatio :: Rational
acceptedRatio =
      Map (Credential ColdCommitteeRole) EpochNo
-> Map (Credential HotCommitteeRole) Vote
-> CommitteeState era
-> EpochNo
-> Rational
forall era.
Map (Credential ColdCommitteeRole) EpochNo
-> Map (Credential HotCommitteeRole) Vote
-> CommitteeState era
-> EpochNo
-> Rational
committeeAcceptedRatio Map (Credential ColdCommitteeRole) EpochNo
members (GovActionState era -> Map (Credential HotCommitteeRole) Vote
forall era.
GovActionState era -> Map (Credential HotCommitteeRole) Vote
gasCommitteeVotes GovActionState era
gas) CommitteeState era
reCommitteeState EpochNo
reCurrentEpoch
    members :: Map (Credential ColdCommitteeRole) EpochNo
members = (Committee era -> Map (Credential ColdCommitteeRole) EpochNo)
-> StrictMaybe (Committee era)
-> Map (Credential ColdCommitteeRole) EpochNo
forall m a. Monoid m => (a -> m) -> StrictMaybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap' Committee era -> Map (Credential ColdCommitteeRole) EpochNo
forall era.
Committee era -> Map (Credential ColdCommitteeRole) EpochNo
committeeMembers (RatifyState era
rs RatifyState era
-> Getting
     (StrictMaybe (Committee era))
     (RatifyState era)
     (StrictMaybe (Committee era))
-> StrictMaybe (Committee era)
forall s a. s -> Getting a s a -> a
^. (EnactState era
 -> Const (StrictMaybe (Committee era)) (EnactState era))
-> RatifyState era
-> Const (StrictMaybe (Committee era)) (RatifyState era)
forall era (f :: * -> *).
Functor f =>
(EnactState era -> f (EnactState era))
-> RatifyState era -> f (RatifyState era)
rsEnactStateL ((EnactState era
  -> Const (StrictMaybe (Committee era)) (EnactState era))
 -> RatifyState era
 -> Const (StrictMaybe (Committee era)) (RatifyState era))
-> ((StrictMaybe (Committee era)
     -> Const
          (StrictMaybe (Committee era)) (StrictMaybe (Committee era)))
    -> EnactState era
    -> Const (StrictMaybe (Committee era)) (EnactState era))
-> Getting
     (StrictMaybe (Committee era))
     (RatifyState era)
     (StrictMaybe (Committee era))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StrictMaybe (Committee era)
 -> Const
      (StrictMaybe (Committee era)) (StrictMaybe (Committee era)))
-> EnactState era
-> Const (StrictMaybe (Committee era)) (EnactState era)
forall era (f :: * -> *).
Functor f =>
(StrictMaybe (Committee era) -> f (StrictMaybe (Committee era)))
-> EnactState era -> f (EnactState era)
ensCommitteeL)

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

spoAccepted ::
  (ConwayEraPParams era, ConwayEraAccounts era) =>
  RatifyEnv era ->
  RatifyState era ->
  GovActionState era ->
  Bool
spoAccepted :: forall era.
(ConwayEraPParams era, ConwayEraAccounts era) =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
spoAccepted RatifyEnv era
re RatifyState era
rs GovActionState era
gas =
  case RatifyState era -> GovAction era -> StrictMaybe UnitInterval
forall era.
ConwayEraPParams era =>
RatifyState era -> GovAction era -> StrictMaybe UnitInterval
votingStakePoolThreshold RatifyState era
rs (GovActionState era -> GovAction era
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 UnitInterval -> UnitInterval -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInterval
forall a. Bounded a => a
minBound Bool -> Bool -> Bool
|| RatifyEnv era -> GovActionState era -> ProtVer -> Rational
forall era.
ConwayEraAccounts era =>
RatifyEnv era -> GovActionState era -> ProtVer -> Rational
spoAcceptedRatio RatifyEnv era
re GovActionState era
gas (RatifyState era
rs RatifyState era
-> Getting ProtVer (RatifyState era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. (EnactState era -> Const ProtVer (EnactState era))
-> RatifyState era -> Const ProtVer (RatifyState era)
forall era (f :: * -> *).
Functor f =>
(EnactState era -> f (EnactState era))
-> RatifyState era -> f (RatifyState era)
rsEnactStateL ((EnactState era -> Const ProtVer (EnactState era))
 -> RatifyState era -> Const ProtVer (RatifyState era))
-> ((ProtVer -> Const ProtVer ProtVer)
    -> EnactState era -> Const ProtVer (EnactState era))
-> Getting ProtVer (RatifyState era) ProtVer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProtVer -> Const ProtVer ProtVer)
-> EnactState era -> Const ProtVer (EnactState era)
forall era. EraPParams era => Lens' (EnactState era) ProtVer
Lens' (EnactState era) ProtVer
ensProtVerL) Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= UnitInterval -> Rational
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 ::
  ConwayEraAccounts era => RatifyEnv era -> GovActionState era -> ProtVer -> Rational
spoAcceptedRatio :: forall era.
ConwayEraAccounts era =>
RatifyEnv era -> GovActionState era -> ProtVer -> Rational
spoAcceptedRatio
  RatifyEnv
    { reStakePoolDistr :: forall era. RatifyEnv era -> PoolDistr
reStakePoolDistr = PoolDistr Map (KeyHash StakePool) IndividualPoolStake
individualPoolStake (CompactCoin Word64
totalActiveStake)
    , Accounts era
reAccounts :: Accounts era
reAccounts :: forall era. RatifyEnv era -> Accounts era
reAccounts
    , Map (KeyHash StakePool) StakePoolState
reStakePools :: Map (KeyHash StakePool) StakePoolState
reStakePools :: forall era. RatifyEnv era -> Map (KeyHash StakePool) StakePoolState
reStakePools
    }
  GovActionState
    { Map (KeyHash StakePool) Vote
gasStakePoolVotes :: Map (KeyHash StakePool) Vote
gasStakePoolVotes :: forall era. GovActionState era -> Map (KeyHash StakePool) Vote
gasStakePoolVotes
    , gasProposalProcedure :: forall era. GovActionState era -> ProposalProcedure era
gasProposalProcedure = ProposalProcedure {GovAction era
pProcGovAction :: GovAction era
pProcGovAction :: forall era. ProposalProcedure era -> GovAction era
pProcGovAction}
    }
  ProtVer
pv =
    Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
yesStake Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%? Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64
totalActiveStake Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
abstainStake)
    where
      accumStake :: (Word64, Word64)
-> KeyHash StakePool -> IndividualPoolStake -> (Word64, Word64)
accumStake (!Word64
yes, !Word64
abstain) KeyHash StakePool
poolId IndividualPoolStake
distr =
        let CompactCoin Word64
stake = IndividualPoolStake -> CompactForm Coin
individualTotalPoolStake IndividualPoolStake
distr
            vote :: Maybe Vote
vote = KeyHash StakePool -> Map (KeyHash StakePool) Vote -> Maybe Vote
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup KeyHash StakePool
poolId Map (KeyHash StakePool) Vote
gasStakePoolVotes
         in case Maybe Vote
vote of
              Maybe Vote
Nothing
                | HardForkInitiation {} <- GovAction era
pProcGovAction -> (Word64
yes, Word64
abstain)
                | ProtVer -> Bool
hardforkConwayBootstrapPhase ProtVer
pv -> (Word64
yes, Word64
abstain Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
stake)
                | Bool
otherwise -> case KeyHash StakePool
-> Map (KeyHash StakePool) StakePoolState
-> Accounts era
-> DefaultVote
forall era.
ConwayEraAccounts era =>
KeyHash StakePool
-> Map (KeyHash StakePool) StakePoolState
-> Accounts era
-> DefaultVote
defaultStakePoolVote KeyHash StakePool
poolId Map (KeyHash StakePool) StakePoolState
reStakePools Accounts era
reAccounts of
                    DefaultVote
DefaultNoConfidence
                      | NoConfidence {} <- GovAction era
pProcGovAction -> (Word64
yes Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
stake, Word64
abstain)
                    DefaultVote
DefaultAbstain -> (Word64
yes, Word64
abstain Word64 -> Word64 -> Word64
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 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
stake)
              Just Vote
VoteNo -> (Word64
yes, Word64
abstain)
              Just Vote
VoteYes -> (Word64
yes Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
stake, Word64
abstain)
      (Word64
yesStake, Word64
abstainStake) =
        ((Word64, Word64)
 -> KeyHash StakePool -> IndividualPoolStake -> (Word64, Word64))
-> (Word64, Word64)
-> Map (KeyHash StakePool) IndividualPoolStake
-> (Word64, Word64)
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (Word64, Word64)
-> KeyHash StakePool -> IndividualPoolStake -> (Word64, Word64)
accumStake (Word64
0, Word64
0) Map (KeyHash StakePool) IndividualPoolStake
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) Vote
gasDRepVotes :: Map (Credential DRepRole) Vote
gasDRepVotes :: forall era. GovActionState era -> Map (Credential DRepRole) Vote
gasDRepVotes, ProposalProcedure era
gasProposalProcedure :: forall era. GovActionState era -> ProposalProcedure era
gasProposalProcedure :: ProposalProcedure era
gasProposalProcedure} =
  case RatifyState era -> GovAction era -> StrictMaybe UnitInterval
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 UnitInterval -> UnitInterval -> Bool
forall a. Eq a => a -> a -> Bool
== UnitInterval
forall a. Bounded a => a
minBound
        Bool -> Bool -> Bool
|| RatifyEnv era
-> Map (Credential DRepRole) Vote -> GovAction era -> Rational
forall era.
RatifyEnv era
-> Map (Credential DRepRole) Vote -> GovAction era -> Rational
dRepAcceptedRatio RatifyEnv era
re Map (Credential DRepRole) Vote
gasDRepVotes GovAction era
govAction Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= UnitInterval -> Rational
forall r. BoundedRational r => r -> Rational
unboundRational UnitInterval
r
    StrictMaybe UnitInterval
SNothing -> Bool
False
  where
    govAction :: GovAction era
govAction = ProposalProcedure era -> GovAction era
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) Vote ->
  GovAction era ->
  Rational
dRepAcceptedRatio :: forall era.
RatifyEnv era
-> Map (Credential DRepRole) Vote -> GovAction era -> Rational
dRepAcceptedRatio RatifyEnv {Map DRep (CompactForm Coin)
reDRepDistr :: Map DRep (CompactForm Coin)
reDRepDistr :: forall era. RatifyEnv era -> Map DRep (CompactForm Coin)
reDRepDistr, Map (Credential DRepRole) DRepState
reDRepState :: Map (Credential DRepRole) DRepState
reDRepState :: forall era. RatifyEnv era -> Map (Credential DRepRole) DRepState
reDRepState, EpochNo
reCurrentEpoch :: forall era. RatifyEnv era -> EpochNo
reCurrentEpoch :: EpochNo
reCurrentEpoch} Map (Credential DRepRole) Vote
gasDRepVotes GovAction era
govAction =
  Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
yesStake Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%? Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
totalExcludingAbstainStake
  where
    accumStake :: (Word64, Word64) -> DRep -> CompactForm Coin -> (Word64, Word64)
accumStake (!Word64
yes, !Word64
tot) DRep
drep (CompactCoin Word64
stake) =
      case DRep
drep of
        DRepCredential Credential DRepRole
cred ->
          case Credential DRepRole
-> Map (Credential DRepRole) DRepState -> Maybe DRepState
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential DRepRole
cred Map (Credential DRepRole) DRepState
reDRepState of
            Maybe DRepState
Nothing -> (Word64
yes, Word64
tot) -- drep is not registered, so we don't consider it
            Just DRepState
drepState
              | EpochNo
reCurrentEpoch EpochNo -> EpochNo -> Bool
forall a. Ord a => a -> a -> Bool
> DRepState -> EpochNo
drepExpiry DRepState
drepState -> (Word64
yes, Word64
tot) -- drep is expired, so we don't consider it
              | Bool
otherwise ->
                  case Credential DRepRole -> Map (Credential DRepRole) Vote -> Maybe Vote
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Credential DRepRole
cred Map (Credential DRepRole) 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 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
stake)
                    Just Vote
VoteYes -> (Word64
yes Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
stake, Word64
tot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
stake)
                    Just Vote
Abstain -> (Word64
yes, Word64
tot)
                    Just Vote
VoteNo -> (Word64
yes, Word64
tot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
stake)
        DRep
DRepAlwaysNoConfidence ->
          case GovAction era
govAction of
            NoConfidence StrictMaybe (GovPurposeId 'CommitteePurpose)
_ -> (Word64
yes Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
stake, Word64
tot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
stake)
            GovAction era
_ -> (Word64
yes, Word64
tot Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
stake)
        DRep
DRepAlwaysAbstain -> (Word64
yes, Word64
tot)
    (Word64
yesStake, Word64
totalExcludingAbstainStake) = ((Word64, Word64) -> DRep -> CompactForm Coin -> (Word64, Word64))
-> (Word64, Word64)
-> Map DRep (CompactForm Coin)
-> (Word64, Word64)
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
Map.foldlWithKey' (Word64, Word64) -> DRep -> CompactForm Coin -> (Word64, Word64)
accumStake (Word64
0, Word64
0) Map DRep (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 Coin
m StrictMaybe ScriptHash
_) Coin
treasury =
  (Coin -> Coin -> Coin) -> Coin -> Map RewardAccount Coin -> Coin
forall a b k. (a -> b -> b) -> b -> Map k a -> b
Map.foldr' Coin -> Coin -> Coin
forall t. Val t => t -> t -> t
(<+>) Coin
forall t. Val t => t
zero Map RewardAccount Coin
m Coin -> Coin -> Bool
forall a. Ord a => a -> a -> Bool
<= Coin
treasury
withdrawalCanWithdraw GovAction era
_ Coin
_ = Bool
True

acceptedByEveryone ::
  (ConwayEraPParams era, ConwayEraAccounts era) =>
  RatifyEnv era ->
  RatifyState era ->
  GovActionState era ->
  Bool
acceptedByEveryone :: forall era.
(ConwayEraPParams era, ConwayEraAccounts era) =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
acceptedByEveryone RatifyEnv era
env RatifyState era
st GovActionState era
gas =
  RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
forall era.
ConwayEraPParams era =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
committeeAccepted RatifyEnv era
env RatifyState era
st GovActionState era
gas
    Bool -> Bool -> Bool
&& RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
forall era.
(ConwayEraPParams era, ConwayEraAccounts era) =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
spoAccepted RatifyEnv era
env RatifyState era
st GovActionState era
gas
    Bool -> Bool -> Bool
&& RatifyEnv era -> RatifyState era -> GovActionState era -> 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
  , ConwayEraAccounts 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, ConwayEraAccounts era) =>
TransitionRule (ConwayRATIFY era)
ratifyTransition = do
  TRC
    ( env@RatifyEnv {reCurrentEpoch}
      , st@( RatifyState
               rsEnactState@EnactState
                 { ensCurPParams
                 , ensTreasury
                 , ensPrevGovActionIds
                 }
               _rsEnacted
               _rsExpired
               rsDelayed
             )
      , RatifySignal rsig
      ) <-
    Rule
  (ConwayRATIFY era)
  'Transition
  (RuleContext 'Transition (ConwayRATIFY era))
F (Clause (ConwayRATIFY era) 'Transition) (TRC (ConwayRATIFY era))
forall sts (rtype :: RuleType).
Rule sts rtype (RuleContext rtype sts)
judgmentContext
  case rsig of
    gas :: GovActionState era
gas@GovActionState {GovActionId
gasId :: GovActionId
gasId :: forall era. GovActionState era -> GovActionId
gasId, EpochNo
gasExpiresAfter :: EpochNo
gasExpiresAfter :: forall era. GovActionState era -> EpochNo
gasExpiresAfter} SSeq.:<| StrictSeq (GovActionState era)
sigs -> do
      let govAction :: GovAction era
govAction = GovActionState era -> GovAction era
forall era. GovActionState era -> GovAction era
gasAction GovActionState era
gas
      if GovActionState era -> GovRelation StrictMaybe -> Bool
forall era. GovActionState era -> GovRelation StrictMaybe -> Bool
prevActionAsExpected GovActionState era
gas GovRelation StrictMaybe
ensPrevGovActionIds
        Bool -> Bool -> Bool
&& GovAction era -> PParams era -> EpochNo -> 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
&& GovAction era -> Coin -> Bool
forall era. GovAction era -> Coin -> Bool
withdrawalCanWithdraw GovAction era
govAction Coin
ensTreasury
        Bool -> Bool -> Bool
&& RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
forall era.
(ConwayEraPParams era, ConwayEraAccounts era) =>
RatifyEnv era -> RatifyState era -> GovActionState era -> Bool
acceptedByEveryone Environment (ConwayRATIFY era)
RatifyEnv era
env State (ConwayRATIFY era)
RatifyState era
st GovActionState era
gas
        then do
          newEnactState <-
            forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(EraRule "ENACT" era) (RuleContext 'Transition (EraRule "ENACT" era)
 -> Rule
      (ConwayRATIFY era) 'Transition (State (EraRule "ENACT" era)))
-> RuleContext 'Transition (EraRule "ENACT" era)
-> Rule
     (ConwayRATIFY era) 'Transition (State (EraRule "ENACT" era))
forall a b. (a -> b) -> a -> b
$
              (Environment (EraRule "ENACT" era), State (EraRule "ENACT" era),
 Signal (EraRule "ENACT" era))
-> TRC (EraRule "ENACT" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), State (EraRule "ENACT" era)
EnactState era
rsEnactState, GovActionId -> GovAction era -> EnactSignal era
forall era. GovActionId -> GovAction era -> EnactSignal era
EnactSignal GovActionId
gasId GovAction era
govAction)
          let
            st' =
              State (ConwayRATIFY era)
RatifyState era
st
                RatifyState era
-> (RatifyState era -> RatifyState era) -> RatifyState era
forall a b. a -> (a -> b) -> b
& (EnactState era -> Identity (EnactState era))
-> RatifyState era -> Identity (RatifyState era)
forall era (f :: * -> *).
Functor f =>
(EnactState era -> f (EnactState era))
-> RatifyState era -> f (RatifyState era)
rsEnactStateL ((EnactState era -> Identity (EnactState era))
 -> RatifyState era -> Identity (RatifyState era))
-> EnactState era -> RatifyState era -> RatifyState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ EnactState era
newEnactState
                RatifyState era
-> (RatifyState era -> RatifyState era) -> RatifyState era
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool)
-> RatifyState era -> Identity (RatifyState era)
forall era (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> RatifyState era -> f (RatifyState era)
rsDelayedL ((Bool -> Identity Bool)
 -> RatifyState era -> Identity (RatifyState era))
-> Bool -> RatifyState era -> RatifyState era
forall s t a b. ASetter s t a b -> b -> s -> t
.~ GovAction era -> Bool
forall era. GovAction era -> Bool
delayingAction GovAction era
govAction
                RatifyState era
-> (RatifyState era -> RatifyState era) -> RatifyState era
forall a b. a -> (a -> b) -> b
& (Seq (GovActionState era) -> Identity (Seq (GovActionState era)))
-> RatifyState era -> Identity (RatifyState era)
forall era (f :: * -> *).
Functor f =>
(Seq (GovActionState era) -> f (Seq (GovActionState era)))
-> RatifyState era -> f (RatifyState era)
rsEnactedL ((Seq (GovActionState era) -> Identity (Seq (GovActionState era)))
 -> RatifyState era -> Identity (RatifyState era))
-> (Seq (GovActionState era) -> Seq (GovActionState era))
-> RatifyState era
-> RatifyState era
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Seq (GovActionState era)
-> GovActionState era -> Seq (GovActionState era)
forall a. Seq a -> a -> Seq a
Seq.:|> GovActionState era
gas)
          trans @(ConwayRATIFY era) $ TRC (env, st', RatifySignal sigs)
        else do
          -- This action hasn't been ratified yet. Process the remaining actions.
          st' <- forall sub super (rtype :: RuleType).
Embed sub super =>
RuleContext rtype sub -> Rule super rtype (State sub)
trans @(ConwayRATIFY era) (RuleContext 'Transition (ConwayRATIFY era)
 -> F (Clause (ConwayRATIFY era) 'Transition)
      (State (ConwayRATIFY era)))
-> RuleContext 'Transition (ConwayRATIFY era)
-> F (Clause (ConwayRATIFY era) 'Transition)
     (State (ConwayRATIFY era))
forall a b. (a -> b) -> a -> b
$ (Environment (ConwayRATIFY era), State (ConwayRATIFY era),
 Signal (ConwayRATIFY era))
-> TRC (ConwayRATIFY era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC (Environment (ConwayRATIFY era)
env, State (ConwayRATIFY era)
st, StrictSeq (GovActionState era) -> RatifySignal era
forall era. StrictSeq (GovActionState era) -> RatifySignal era
RatifySignal StrictSeq (GovActionState era)
sigs)
          -- Finally, filter out actions that have expired.
          if gasExpiresAfter < reCurrentEpoch
            then pure $ st' & rsExpiredL %~ Set.insert gasId
            else pure st'
    StrictSeq (GovActionState era)
SSeq.Empty -> RatifyState era
-> F (Clause (ConwayRATIFY era) 'Transition) (RatifyState era)
forall a. a -> F (Clause (ConwayRATIFY era) 'Transition) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RatifyState era
 -> F (Clause (ConwayRATIFY era) 'Transition) (RatifyState era))
-> RatifyState era
-> F (Clause (ConwayRATIFY era) 'Transition) (RatifyState era)
forall a b. (a -> b) -> a -> b
$ State (ConwayRATIFY era)
RatifyState era
st RatifyState era
-> (RatifyState era -> RatifyState era) -> RatifyState era
forall a b. a -> (a -> b) -> b
& (EnactState era -> Identity (EnactState era))
-> RatifyState era -> Identity (RatifyState era)
forall era (f :: * -> *).
Functor f =>
(EnactState era -> f (EnactState era))
-> RatifyState era -> f (RatifyState era)
rsEnactStateL ((EnactState era -> Identity (EnactState era))
 -> RatifyState era -> Identity (RatifyState era))
-> ((Coin -> Identity Coin)
    -> EnactState era -> Identity (EnactState era))
-> (Coin -> Identity Coin)
-> RatifyState era
-> Identity (RatifyState era)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coin -> Identity Coin)
-> EnactState era -> Identity (EnactState era)
forall era (f :: * -> *).
Functor f =>
(Coin -> f Coin) -> EnactState era -> f (EnactState era)
ensTreasuryL ((Coin -> Identity Coin)
 -> RatifyState era -> Identity (RatifyState era))
-> Coin -> RatifyState era -> RatifyState era
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 -> Bool
prevActionAsExpected :: forall era. GovActionState era -> GovRelation StrictMaybe -> Bool
prevActionAsExpected GovActionState era
gas GovRelation StrictMaybe
prevGovActionIds =
  GovActionState era
-> Bool
-> (forall (p :: GovActionPurpose).
    (forall (f1 :: * -> *) (f2 :: * -> *).
     Functor f2 =>
     (f1 (GovPurposeId p) -> f2 (f1 (GovPurposeId p)))
     -> GovRelation f1 -> f2 (GovRelation f1))
    -> StrictMaybe (GovPurposeId p) -> GovPurposeId p -> Bool)
-> Bool
forall era a.
GovActionState era
-> a
-> (forall (p :: GovActionPurpose).
    (forall (f1 :: * -> *) (f2 :: * -> *).
     Functor f2 =>
     (f1 (GovPurposeId p) -> f2 (f1 (GovPurposeId p)))
     -> GovRelation f1 -> f2 (GovRelation f1))
    -> StrictMaybe (GovPurposeId p) -> GovPurposeId p -> a)
-> a
withGovActionParent GovActionState era
gas Bool
True ((forall (p :: GovActionPurpose).
  (forall (f1 :: * -> *) (f2 :: * -> *).
   Functor f2 =>
   (f1 (GovPurposeId p) -> f2 (f1 (GovPurposeId p)))
   -> GovRelation f1 -> f2 (GovRelation f1))
  -> StrictMaybe (GovPurposeId p) -> GovPurposeId p -> Bool)
 -> Bool)
-> (forall (p :: GovActionPurpose).
    (forall (f1 :: * -> *) (f2 :: * -> *).
     Functor f2 =>
     (f1 (GovPurposeId p) -> f2 (f1 (GovPurposeId p)))
     -> GovRelation f1 -> f2 (GovRelation f1))
    -> StrictMaybe (GovPurposeId p) -> GovPurposeId p -> Bool)
-> Bool
forall a b. (a -> b) -> a -> b
$ \forall (f1 :: * -> *) (f2 :: * -> *).
Functor f2 =>
(f1 (GovPurposeId p) -> f2 (f1 (GovPurposeId p)))
-> GovRelation f1 -> f2 (GovRelation f1)
govRelationL StrictMaybe (GovPurposeId p)
parent GovPurposeId p
_ ->
    StrictMaybe (GovPurposeId p)
parent StrictMaybe (GovPurposeId p)
-> StrictMaybe (GovPurposeId p) -> Bool
forall a. Eq a => a -> a -> Bool
== GovRelation StrictMaybe
prevGovActionIds GovRelation StrictMaybe
-> Getting
     (StrictMaybe (GovPurposeId p))
     (GovRelation StrictMaybe)
     (StrictMaybe (GovPurposeId p))
-> StrictMaybe (GovPurposeId p)
forall s a. s -> Getting a s a -> a
^. Getting
  (StrictMaybe (GovPurposeId p))
  (GovRelation StrictMaybe)
  (StrictMaybe (GovPurposeId p))
forall (f1 :: * -> *) (f2 :: * -> *).
Functor f2 =>
(f1 (GovPurposeId p) -> f2 (f1 (GovPurposeId p)))
-> GovRelation f1 -> f2 (GovRelation f1)
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)
_ Set (Credential ColdCommitteeRole)
_ Map (Credential ColdCommitteeRole) EpochNo
newMembers UnitInterval
_ -> Map (Credential ColdCommitteeRole) EpochNo -> Bool
withinMaxTermLength Map (Credential ColdCommitteeRole) EpochNo
newMembers
    GovAction era
_ -> Bool
True
  where
    committeeMaxTermLength :: EpochInterval
committeeMaxTermLength = PParams era
pp PParams era
-> Getting EpochInterval (PParams era) EpochInterval
-> EpochInterval
forall s a. s -> Getting a s a -> a
^. Getting EpochInterval (PParams era) EpochInterval
forall era.
ConwayEraPParams era =>
Lens' (PParams era) EpochInterval
Lens' (PParams era) EpochInterval
ppCommitteeMaxTermLengthL
    withinMaxTermLength :: Map (Credential ColdCommitteeRole) EpochNo -> Bool
withinMaxTermLength = (EpochNo -> Bool)
-> Map (Credential ColdCommitteeRole) EpochNo -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (EpochNo -> EpochNo -> Bool
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 = Void -> Void
PredicateFailure (ConwayENACT era)
-> PredicateFailure (ConwayRATIFY era)
forall a. Void -> a
absurd
  wrapEvent :: Event (ConwayENACT era) -> Event (ConwayRATIFY era)
wrapEvent = Void -> Void
Event (ConwayENACT era) -> Event (ConwayRATIFY era)
forall a. Void -> a
absurd