{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ViewPatterns #-}

-- | Peras vote aggregation and certificate forging
--
-- This module implements the core voting logic for the Peras protocol, which
-- aggregates stake-weighted votes on chain blocks and forges certificates when
-- quorum is reached.
--
-- = Overview
--
-- In Peras, validators vote on specific blocks during designated voting rounds.
-- Each vote carries a stake weight, and votes are aggregated by:
--
--   * __Round__: each vote belongs to a specific 'PerasRoundNo'
--   * __Target__: within a round, votes are cast for different block 'Point's
--
-- As votes arrive, the system tracks the total stake backing each candidate
-- block. When one target accumulates enough stake to exceed the configured
-- quorum threshold, a certificate is automatically forged for that block,
-- making it a winner for that round.
--
-- = State Machine
--
-- For every round being voted for, the aggregation follows a state machine:
--
-- 1. __Quorum not reached__: multiple block targets are candidates, each
--    accumulating votes and stake. All targets compete to reach quorum first.
--
-- 2. __Quorum reached__: once a target reaches quorum, it becomes the winner
--    and a certificate is forged. All other targets become losers and continue
--    tracking votes without affecting the outcome.
--
-- = Quorum Threshold and Multiple Winners
--
-- The quorum threshold is parameterized via 'PerasCfg'. Depending on this
-- configuration and the stake distribution, it may be theoretically possible
-- for multiple targets to exceed the threshold within the same round.
--
-- This module treats multiple winners as an error condition and rejects votes
-- that would cause this, raising instead a 'RoundVoteStateLoserAboveQuorum'
-- exception. This indicates that either:
--   * The quorum threshold is misconfigured, or that
--   * We were extremely unlucky when randomly selecting the voting committee.
--
-- With a correct threshold configuration (e.g., > 3/4 of total stake + a small
-- safety margin to account for an unlucky local sortition when selecting
-- non-persistent voters during committee selection), multiple winners should be
-- impossible given honest stake distribution.
--
-- = Key Types
--
--   * 'PerasRoundVoteState': tracks all voting activity for a single round, and
--      its logically split between separate 'NoQuorum' and 'Quorum' types
--      representing the two states (1) and (2) described above, respectively.
--   * 'PerasTargetVoteState': tracks votes for one specific block target
--   * 'PerasTargetVoteTally': raw vote count and stake accumulation
--   * 'PerasTargetVoteStatus': type-level status (Candidate/Winner/Loser)
--   * 'UpdateRoundVoteStateError': errors from invalid state transitions
--
-- = Usage
--
-- The primary entry point is 'updatePerasRoundVoteStates', which adds a new
-- vote to the aggregate state. Pattern synonyms 'VoteGeneratedNewCert' and
-- 'VoteDidntGenerateNewCert' allow clients to observe when certificates are
-- freshly forged (as opposed to voting on an already-won target).
module Ouroboros.Consensus.Peras.Vote.Aggregation
  ( PerasRoundVoteState
  , ptvsTotalStake
  , pattern VoteGeneratedNewCert
  , pattern VoteDidntGenerateNewCert
  , updatePerasRoundVoteStates
  , getPerasRoundVoteStateCertMaybe
  , UpdateRoundVoteStateError (..)
  ) where

import Cardano.Prelude (fromMaybe)
import Control.Exception (assert)
import Data.Functor.Compose (Compose (..))
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Word (Word64)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.BlockchainTime (WithArrivalTime, forgetArrivalTime)

{-------------------------------------------------------------------------------
  Voting state for a given Peras round
-------------------------------------------------------------------------------}

-- | Current vote state for a given round
data PerasRoundVoteState blk = PerasRoundVoteState
  { forall blk. PerasRoundVoteState blk -> PerasRoundNo
prvsRoundNo :: !PerasRoundNo
  , forall blk.
PerasRoundVoteState blk -> Either (NoQuorum blk) (Quorum blk)
prvsState :: !(Either (NoQuorum blk) (Quorum blk))
  }
  deriving stock ((forall x.
 PerasRoundVoteState blk -> Rep (PerasRoundVoteState blk) x)
-> (forall x.
    Rep (PerasRoundVoteState blk) x -> PerasRoundVoteState blk)
-> Generic (PerasRoundVoteState blk)
forall x.
Rep (PerasRoundVoteState blk) x -> PerasRoundVoteState blk
forall x.
PerasRoundVoteState blk -> Rep (PerasRoundVoteState blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x.
Rep (PerasRoundVoteState blk) x -> PerasRoundVoteState blk
forall blk x.
PerasRoundVoteState blk -> Rep (PerasRoundVoteState blk) x
$cfrom :: forall blk x.
PerasRoundVoteState blk -> Rep (PerasRoundVoteState blk) x
from :: forall x.
PerasRoundVoteState blk -> Rep (PerasRoundVoteState blk) x
$cto :: forall blk x.
Rep (PerasRoundVoteState blk) x -> PerasRoundVoteState blk
to :: forall x.
Rep (PerasRoundVoteState blk) x -> PerasRoundVoteState blk
Generic, PerasRoundVoteState blk -> PerasRoundVoteState blk -> Bool
(PerasRoundVoteState blk -> PerasRoundVoteState blk -> Bool)
-> (PerasRoundVoteState blk -> PerasRoundVoteState blk -> Bool)
-> Eq (PerasRoundVoteState blk)
forall blk.
StandardHash blk =>
PerasRoundVoteState blk -> PerasRoundVoteState blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
StandardHash blk =>
PerasRoundVoteState blk -> PerasRoundVoteState blk -> Bool
== :: PerasRoundVoteState blk -> PerasRoundVoteState blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
PerasRoundVoteState blk -> PerasRoundVoteState blk -> Bool
/= :: PerasRoundVoteState blk -> PerasRoundVoteState blk -> Bool
Eq, Int -> PerasRoundVoteState blk -> ShowS
[PerasRoundVoteState blk] -> ShowS
PerasRoundVoteState blk -> String
(Int -> PerasRoundVoteState blk -> ShowS)
-> (PerasRoundVoteState blk -> String)
-> ([PerasRoundVoteState blk] -> ShowS)
-> Show (PerasRoundVoteState blk)
forall blk.
StandardHash blk =>
Int -> PerasRoundVoteState blk -> ShowS
forall blk. StandardHash blk => [PerasRoundVoteState blk] -> ShowS
forall blk. StandardHash blk => PerasRoundVoteState blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk.
StandardHash blk =>
Int -> PerasRoundVoteState blk -> ShowS
showsPrec :: Int -> PerasRoundVoteState blk -> ShowS
$cshow :: forall blk. StandardHash blk => PerasRoundVoteState blk -> String
show :: PerasRoundVoteState blk -> String
$cshowList :: forall blk. StandardHash blk => [PerasRoundVoteState blk] -> ShowS
showList :: [PerasRoundVoteState blk] -> ShowS
Show)
  deriving anyclass Context -> PerasRoundVoteState blk -> IO (Maybe ThunkInfo)
Proxy (PerasRoundVoteState blk) -> String
(Context -> PerasRoundVoteState blk -> IO (Maybe ThunkInfo))
-> (Context -> PerasRoundVoteState blk -> IO (Maybe ThunkInfo))
-> (Proxy (PerasRoundVoteState blk) -> String)
-> NoThunks (PerasRoundVoteState blk)
forall blk.
StandardHash blk =>
Context -> PerasRoundVoteState blk -> IO (Maybe ThunkInfo)
forall blk.
StandardHash blk =>
Proxy (PerasRoundVoteState blk) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall blk.
StandardHash blk =>
Context -> PerasRoundVoteState blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> PerasRoundVoteState blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
StandardHash blk =>
Context -> PerasRoundVoteState blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PerasRoundVoteState blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall blk.
StandardHash blk =>
Proxy (PerasRoundVoteState blk) -> String
showTypeOf :: Proxy (PerasRoundVoteState blk) -> String
NoThunks

instance HasPerasVoteRound (PerasRoundVoteState blk) where
  getPerasVoteRound :: PerasRoundVoteState blk -> PerasRoundNo
getPerasVoteRound = PerasRoundVoteState blk -> PerasRoundNo
forall blk. PerasRoundVoteState blk -> PerasRoundNo
prvsRoundNo

-- | Current vote state when a quorum has not yet been reached
data NoQuorum blk = NoQuorum
  { forall blk.
NoQuorum blk
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates :: !(Map (Point blk) (PerasTargetVoteState blk 'Candidate))
  }
  deriving stock ((forall x. NoQuorum blk -> Rep (NoQuorum blk) x)
-> (forall x. Rep (NoQuorum blk) x -> NoQuorum blk)
-> Generic (NoQuorum blk)
forall x. Rep (NoQuorum blk) x -> NoQuorum blk
forall x. NoQuorum blk -> Rep (NoQuorum blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (NoQuorum blk) x -> NoQuorum blk
forall blk x. NoQuorum blk -> Rep (NoQuorum blk) x
$cfrom :: forall blk x. NoQuorum blk -> Rep (NoQuorum blk) x
from :: forall x. NoQuorum blk -> Rep (NoQuorum blk) x
$cto :: forall blk x. Rep (NoQuorum blk) x -> NoQuorum blk
to :: forall x. Rep (NoQuorum blk) x -> NoQuorum blk
Generic, NoQuorum blk -> NoQuorum blk -> Bool
(NoQuorum blk -> NoQuorum blk -> Bool)
-> (NoQuorum blk -> NoQuorum blk -> Bool) -> Eq (NoQuorum blk)
forall blk.
StandardHash blk =>
NoQuorum blk -> NoQuorum blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
StandardHash blk =>
NoQuorum blk -> NoQuorum blk -> Bool
== :: NoQuorum blk -> NoQuorum blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
NoQuorum blk -> NoQuorum blk -> Bool
/= :: NoQuorum blk -> NoQuorum blk -> Bool
Eq, Int -> NoQuorum blk -> ShowS
[NoQuorum blk] -> ShowS
NoQuorum blk -> String
(Int -> NoQuorum blk -> ShowS)
-> (NoQuorum blk -> String)
-> ([NoQuorum blk] -> ShowS)
-> Show (NoQuorum blk)
forall blk. StandardHash blk => Int -> NoQuorum blk -> ShowS
forall blk. StandardHash blk => [NoQuorum blk] -> ShowS
forall blk. StandardHash blk => NoQuorum blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. StandardHash blk => Int -> NoQuorum blk -> ShowS
showsPrec :: Int -> NoQuorum blk -> ShowS
$cshow :: forall blk. StandardHash blk => NoQuorum blk -> String
show :: NoQuorum blk -> String
$cshowList :: forall blk. StandardHash blk => [NoQuorum blk] -> ShowS
showList :: [NoQuorum blk] -> ShowS
Show)
  deriving anyclass Context -> NoQuorum blk -> IO (Maybe ThunkInfo)
Proxy (NoQuorum blk) -> String
(Context -> NoQuorum blk -> IO (Maybe ThunkInfo))
-> (Context -> NoQuorum blk -> IO (Maybe ThunkInfo))
-> (Proxy (NoQuorum blk) -> String)
-> NoThunks (NoQuorum blk)
forall blk.
StandardHash blk =>
Context -> NoQuorum blk -> IO (Maybe ThunkInfo)
forall blk. StandardHash blk => Proxy (NoQuorum blk) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall blk.
StandardHash blk =>
Context -> NoQuorum blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> NoQuorum blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
StandardHash blk =>
Context -> NoQuorum blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> NoQuorum blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall blk. StandardHash blk => Proxy (NoQuorum blk) -> String
showTypeOf :: Proxy (NoQuorum blk) -> String
NoThunks

-- | Current vote state when a quorum has been reached
data Quorum blk = Quorum
  { forall blk. Quorum blk -> Word64
excessVotes :: !Word64
  , forall blk.
Quorum blk -> Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates :: !(Map (Point blk) (PerasTargetVoteState blk 'Loser))
  , forall blk. Quorum blk -> PerasTargetVoteState blk 'Winner
winnerState :: !(PerasTargetVoteState blk 'Winner)
  }
  deriving stock ((forall x. Quorum blk -> Rep (Quorum blk) x)
-> (forall x. Rep (Quorum blk) x -> Quorum blk)
-> Generic (Quorum blk)
forall x. Rep (Quorum blk) x -> Quorum blk
forall x. Quorum blk -> Rep (Quorum blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (Quorum blk) x -> Quorum blk
forall blk x. Quorum blk -> Rep (Quorum blk) x
$cfrom :: forall blk x. Quorum blk -> Rep (Quorum blk) x
from :: forall x. Quorum blk -> Rep (Quorum blk) x
$cto :: forall blk x. Rep (Quorum blk) x -> Quorum blk
to :: forall x. Rep (Quorum blk) x -> Quorum blk
Generic, Quorum blk -> Quorum blk -> Bool
(Quorum blk -> Quorum blk -> Bool)
-> (Quorum blk -> Quorum blk -> Bool) -> Eq (Quorum blk)
forall blk. StandardHash blk => Quorum blk -> Quorum blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk. StandardHash blk => Quorum blk -> Quorum blk -> Bool
== :: Quorum blk -> Quorum blk -> Bool
$c/= :: forall blk. StandardHash blk => Quorum blk -> Quorum blk -> Bool
/= :: Quorum blk -> Quorum blk -> Bool
Eq, Int -> Quorum blk -> ShowS
[Quorum blk] -> ShowS
Quorum blk -> String
(Int -> Quorum blk -> ShowS)
-> (Quorum blk -> String)
-> ([Quorum blk] -> ShowS)
-> Show (Quorum blk)
forall blk. StandardHash blk => Int -> Quorum blk -> ShowS
forall blk. StandardHash blk => [Quorum blk] -> ShowS
forall blk. StandardHash blk => Quorum blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. StandardHash blk => Int -> Quorum blk -> ShowS
showsPrec :: Int -> Quorum blk -> ShowS
$cshow :: forall blk. StandardHash blk => Quorum blk -> String
show :: Quorum blk -> String
$cshowList :: forall blk. StandardHash blk => [Quorum blk] -> ShowS
showList :: [Quorum blk] -> ShowS
Show)
  deriving anyclass Context -> Quorum blk -> IO (Maybe ThunkInfo)
Proxy (Quorum blk) -> String
(Context -> Quorum blk -> IO (Maybe ThunkInfo))
-> (Context -> Quorum blk -> IO (Maybe ThunkInfo))
-> (Proxy (Quorum blk) -> String)
-> NoThunks (Quorum blk)
forall blk.
StandardHash blk =>
Context -> Quorum blk -> IO (Maybe ThunkInfo)
forall blk. StandardHash blk => Proxy (Quorum blk) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall blk.
StandardHash blk =>
Context -> Quorum blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> Quorum blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
StandardHash blk =>
Context -> Quorum blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Quorum blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall blk. StandardHash blk => Proxy (Quorum blk) -> String
showTypeOf :: Proxy (Quorum blk) -> String
NoThunks

-- | Get the certificate if quorum was reached for the given round
getPerasRoundVoteStateCertMaybe ::
  PerasRoundVoteState blk ->
  Maybe (ValidatedPerasCert blk)
getPerasRoundVoteStateCertMaybe :: forall blk.
PerasRoundVoteState blk -> Maybe (ValidatedPerasCert blk)
getPerasRoundVoteStateCertMaybe = \case
  PerasRoundVoteState
    { prvsState :: forall blk.
PerasRoundVoteState blk -> Either (NoQuorum blk) (Quorum blk)
prvsState =
      Right
        Quorum
          { winnerState :: forall blk. Quorum blk -> PerasTargetVoteState blk 'Winner
winnerState =
            PerasTargetVoteWinner PerasTargetVoteTally blk
_ ValidatedPerasCert blk
cert
          }
    } ->
      ValidatedPerasCert blk -> Maybe (ValidatedPerasCert blk)
forall a. a -> Maybe a
Just ValidatedPerasCert blk
cert
  PerasRoundVoteState blk
_ ->
    Maybe (ValidatedPerasCert blk)
forall a. Maybe a
Nothing

-- | Create a fresh round vote state for the given round number
freshRoundVoteState ::
  PerasRoundNo ->
  PerasRoundVoteState blk
freshRoundVoteState :: forall blk. PerasRoundNo -> PerasRoundVoteState blk
freshRoundVoteState PerasRoundNo
roundNo =
  PerasRoundVoteState
    { prvsRoundNo :: PerasRoundNo
prvsRoundNo = PerasRoundNo
roundNo
    , prvsState :: Either (NoQuorum blk) (Quorum blk)
prvsState =
        NoQuorum blk -> Either (NoQuorum blk) (Quorum blk)
forall a b. a -> Either a b
Left
          NoQuorum
            { candidateStates :: Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates =
                Map (Point blk) (PerasTargetVoteState blk 'Candidate)
forall k a. Map k a
Map.empty
            }
    }

-- | Errors that may occur when updating the round vote state with a new vote
data UpdateRoundVoteStateError blk
  = RoundVoteStateLoserAboveQuorum
      (PerasTargetVoteState blk 'Winner)
      (PerasTargetVoteState blk 'Loser)
  | RoundVoteStateForgingCertError
      (PerasForgeErr blk)

-- | Add a vote to an existing round vote aggregate.
--
-- PRECONDITION: the vote's round must match the aggregate's round.
--
-- May fail if the state transition is invalid (e.g., a loser going above
-- quorum) or if forging the certificate fails.
updatePerasRoundVoteState ::
  forall blk.
  StandardHash blk =>
  WithArrivalTime (ValidatedPerasVote blk) ->
  PerasCfg blk ->
  PerasRoundVoteState blk ->
  Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
updatePerasRoundVoteState :: forall blk.
StandardHash blk =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasCfg blk
-> PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
updatePerasRoundVoteState WithArrivalTime (ValidatedPerasVote blk)
vote PerasCfg blk
cfg PerasRoundVoteState blk
roundState =
  Bool
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (WithArrivalTime (ValidatedPerasVote blk) -> PerasRoundNo
forall vote. HasPerasVoteRound vote => vote -> PerasRoundNo
getPerasVoteRound WithArrivalTime (ValidatedPerasVote blk)
vote PerasRoundNo -> PerasRoundNo -> Bool
forall a. Eq a => a -> a -> Bool
== PerasRoundVoteState blk -> PerasRoundNo
forall vote. HasPerasVoteRound vote => vote -> PerasRoundNo
getPerasVoteRound PerasRoundVoteState blk
roundState) (Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
 -> Either
      (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a b. (a -> b) -> a -> b
$ do
    case PerasRoundVoteState blk
roundState of
      -- Quorum not yet reached
      state :: PerasRoundVoteState blk
state@PerasRoundVoteState
        { prvsState :: forall blk.
PerasRoundVoteState blk -> Either (NoQuorum blk) (Quorum blk)
prvsState =
          Left
            NoQuorum
              { Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates :: forall blk.
NoQuorum blk
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates :: Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates
              }
        } -> do
          let oldCandidateState :: PerasTargetVoteState blk 'Candidate
oldCandidateState =
                PerasTargetVoteState blk 'Candidate
-> Point blk
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
-> PerasTargetVoteState blk 'Candidate
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault
                  (PerasVoteTarget blk -> PerasTargetVoteState blk 'Candidate
forall blk.
PerasVoteTarget blk -> PerasTargetVoteState blk 'Candidate
freshCandidateVoteState (WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteTarget blk
forall vote blk.
HasPerasVoteTarget vote blk =>
vote -> PerasVoteTarget blk
getPerasVoteTarget WithArrivalTime (ValidatedPerasVote blk)
vote))
                  (WithArrivalTime (ValidatedPerasVote blk) -> Point blk
forall vote blk. HasPerasVoteBlock vote blk => vote -> Point blk
getPerasVoteBlock WithArrivalTime (ValidatedPerasVote blk)
vote)
                  Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates
          candidateOrWinnerState <-
            PerasCfg blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Candidate
-> Either (PerasForgeErr blk) (PerasVoteStateCandidateOrWinner blk)
forall blk.
StandardHash blk =>
PerasCfg blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Candidate
-> Either (PerasForgeErr blk) (PerasVoteStateCandidateOrWinner blk)
updateCandidateVoteState PerasCfg blk
cfg WithArrivalTime (ValidatedPerasVote blk)
vote PerasTargetVoteState blk 'Candidate
oldCandidateState
              Either (PerasForgeErr blk) (PerasVoteStateCandidateOrWinner blk)
-> (PerasForgeErr blk -> UpdateRoundVoteStateError blk)
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasVoteStateCandidateOrWinner blk)
forall e a e'. Either e a -> (e -> e') -> Either e' a
`onErr` \PerasForgeErr blk
err ->
                PerasForgeErr blk -> UpdateRoundVoteStateError blk
forall blk. PerasForgeErr blk -> UpdateRoundVoteStateError blk
RoundVoteStateForgingCertError PerasForgeErr blk
err
          case candidateOrWinnerState of
            RemainedCandidate PerasTargetVoteState blk 'Candidate
newCandidateState -> do
              -- Quorum still not reached for this round
              let prvsCandidateStates' :: Map (Point blk) (PerasTargetVoteState blk 'Candidate)
prvsCandidateStates' =
                    Point blk
-> PerasTargetVoteState blk 'Candidate
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert
                      (WithArrivalTime (ValidatedPerasVote blk) -> Point blk
forall vote blk. HasPerasVoteBlock vote blk => vote -> Point blk
getPerasVoteBlock WithArrivalTime (ValidatedPerasVote blk)
vote)
                      PerasTargetVoteState blk 'Candidate
newCandidateState
                      Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates
              PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a. a -> Either (UpdateRoundVoteStateError blk) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PerasRoundVoteState blk
 -> Either
      (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
-> PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a b. (a -> b) -> a -> b
$
                PerasRoundVoteState blk
state
                  { prvsState =
                      Left
                        NoQuorum
                          { candidateStates = prvsCandidateStates'
                          }
                  }
            BecameWinner PerasTargetVoteState blk 'Winner
winnerState -> do
              -- Quorum has been reached for the first time here for this round
              let winnerPoint :: Point blk
winnerPoint =
                    PerasVoteTarget blk -> Point blk
forall blk. PerasVoteTarget blk -> Point blk
pvtBlock (PerasTargetVoteTally blk -> PerasVoteTarget blk
forall blk. PerasTargetVoteTally blk -> PerasVoteTarget blk
ptvtTarget (PerasTargetVoteState blk 'Winner -> PerasTargetVoteTally blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasTargetVoteTally blk
ptvsVoteTally PerasTargetVoteState blk 'Winner
winnerState))
                  loserStates :: Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates =
                    PerasTargetVoteState blk 'Candidate
-> PerasTargetVoteState blk 'Loser
forall blk.
PerasTargetVoteState blk 'Candidate
-> PerasTargetVoteState blk 'Loser
candidateToLoser (PerasTargetVoteState blk 'Candidate
 -> PerasTargetVoteState blk 'Loser)
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
-> Map (Point blk) (PerasTargetVoteState blk 'Loser)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Point blk
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
-> Map (Point blk) (PerasTargetVoteState blk 'Candidate)
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Point blk
winnerPoint Map (Point blk) (PerasTargetVoteState blk 'Candidate)
candidateStates
              PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a. a -> Either (UpdateRoundVoteStateError blk) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PerasRoundVoteState blk
 -> Either
      (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
-> PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a b. (a -> b) -> a -> b
$
                PerasRoundVoteState
                  { prvsRoundNo :: PerasRoundNo
prvsRoundNo =
                      PerasRoundVoteState blk -> PerasRoundNo
forall blk. PerasRoundVoteState blk -> PerasRoundNo
prvsRoundNo PerasRoundVoteState blk
roundState
                  , prvsState :: Either (NoQuorum blk) (Quorum blk)
prvsState =
                      Quorum blk -> Either (NoQuorum blk) (Quorum blk)
forall a b. b -> Either a b
Right
                        Quorum
                          { excessVotes :: Word64
excessVotes = Word64
0
                          , loserStates :: Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates = Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates
                          , winnerState :: PerasTargetVoteState blk 'Winner
winnerState = PerasTargetVoteState blk 'Winner
winnerState
                          }
                  }

      -- Quorum already reached
      state :: PerasRoundVoteState blk
state@PerasRoundVoteState
        { prvsState :: forall blk.
PerasRoundVoteState blk -> Either (NoQuorum blk) (Quorum blk)
prvsState =
          Right
            Quorum
              { Word64
excessVotes :: forall blk. Quorum blk -> Word64
excessVotes :: Word64
excessVotes
              , PerasTargetVoteState blk 'Winner
winnerState :: forall blk. Quorum blk -> PerasTargetVoteState blk 'Winner
winnerState :: PerasTargetVoteState blk 'Winner
winnerState
              , Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates :: forall blk.
Quorum blk -> Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates :: Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates
              }
        } -> do
          let votePoint :: Point blk
votePoint =
                WithArrivalTime (ValidatedPerasVote blk) -> Point blk
forall vote blk. HasPerasVoteBlock vote blk => vote -> Point blk
getPerasVoteBlock WithArrivalTime (ValidatedPerasVote blk)
vote
              winnerPoint :: Point blk
winnerPoint =
                PerasVoteTarget blk -> Point blk
forall blk. PerasVoteTarget blk -> Point blk
pvtBlock (PerasTargetVoteTally blk -> PerasVoteTarget blk
forall blk. PerasTargetVoteTally blk -> PerasVoteTarget blk
ptvtTarget (PerasTargetVoteState blk 'Winner -> PerasTargetVoteTally blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasTargetVoteTally blk
ptvsVoteTally PerasTargetVoteState blk 'Winner
winnerState))
          if Point blk
votePoint Point blk -> Point blk -> Bool
forall a. Eq a => a -> a -> Bool
== Point blk
winnerPoint
            -- The vote ratifies the winner => update winner state
            then do
              let winnerState' :: PerasTargetVoteState blk 'Winner
winnerState' =
                    WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Winner
-> PerasTargetVoteState blk 'Winner
forall blk.
StandardHash blk =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Winner
-> PerasTargetVoteState blk 'Winner
updateWinnerVoteState WithArrivalTime (ValidatedPerasVote blk)
vote PerasTargetVoteState blk 'Winner
winnerState
              PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a. a -> Either (UpdateRoundVoteStateError blk) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PerasRoundVoteState blk
 -> Either
      (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk))
-> PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall a b. (a -> b) -> a -> b
$
                PerasRoundVoteState blk
state
                  { prvsState =
                      Right
                        Quorum
                          { excessVotes = excessVotes + 1
                          , winnerState = winnerState'
                          , loserStates = loserStates
                          }
                  }

            -- The vote is for a loser => update loser state
            else do
              let existingOrFreshLoserVoteState :: Maybe (PerasTargetVoteState blk 'Loser)
-> PerasTargetVoteState blk 'Loser
existingOrFreshLoserVoteState =
                    PerasTargetVoteState blk 'Loser
-> Maybe (PerasTargetVoteState blk 'Loser)
-> PerasTargetVoteState blk 'Loser
forall a. a -> Maybe a -> a
fromMaybe (PerasVoteTarget blk -> PerasTargetVoteState blk 'Loser
forall blk. PerasVoteTarget blk -> PerasTargetVoteState blk 'Loser
freshLoserVoteState (WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteTarget blk
forall vote blk.
HasPerasVoteTarget vote blk =>
vote -> PerasVoteTarget blk
getPerasVoteTarget WithArrivalTime (ValidatedPerasVote blk)
vote))
                  updateMaybeLoserVoteState :: Maybe (PerasTargetVoteState blk 'Loser)
-> Either
     (UpdateRoundVoteStateError blk)
     (Maybe (PerasTargetVoteState blk 'Loser))
updateMaybeLoserVoteState Maybe (PerasTargetVoteState blk 'Loser)
mState =
                    (PerasTargetVoteState blk 'Loser
 -> Maybe (PerasTargetVoteState blk 'Loser))
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
-> Either
     (UpdateRoundVoteStateError blk)
     (Maybe (PerasTargetVoteState blk 'Loser))
forall a b.
(a -> b)
-> Either (UpdateRoundVoteStateError blk) a
-> Either (UpdateRoundVoteStateError blk) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PerasTargetVoteState blk 'Loser
-> Maybe (PerasTargetVoteState blk 'Loser)
forall a. a -> Maybe a
Just (Either
   (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
 -> Either
      (UpdateRoundVoteStateError blk)
      (Maybe (PerasTargetVoteState blk 'Loser)))
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
-> Either
     (UpdateRoundVoteStateError blk)
     (Maybe (PerasTargetVoteState blk 'Loser))
forall a b. (a -> b) -> a -> b
$
                      PerasCfg blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Loser
-> Either
     (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser)
forall blk.
StandardHash blk =>
PerasCfg blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Loser
-> Either
     (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser)
updateLoserVoteState PerasCfg blk
cfg WithArrivalTime (ValidatedPerasVote blk)
vote (Maybe (PerasTargetVoteState blk 'Loser)
-> PerasTargetVoteState blk 'Loser
existingOrFreshLoserVoteState Maybe (PerasTargetVoteState blk 'Loser)
mState)
                        Either
  (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser)
-> (PerasTargetVoteState blk 'Loser
    -> UpdateRoundVoteStateError blk)
-> Either
     (UpdateRoundVoteStateError blk) (PerasTargetVoteState blk 'Loser)
forall e a e'. Either e a -> (e -> e') -> Either e' a
`onErr` \PerasTargetVoteState blk 'Loser
err ->
                          PerasTargetVoteState blk 'Winner
-> PerasTargetVoteState blk 'Loser -> UpdateRoundVoteStateError blk
forall blk.
PerasTargetVoteState blk 'Winner
-> PerasTargetVoteState blk 'Loser -> UpdateRoundVoteStateError blk
RoundVoteStateLoserAboveQuorum PerasTargetVoteState blk 'Winner
winnerState PerasTargetVoteState blk 'Loser
err
              loserStates' <- (Maybe (PerasTargetVoteState blk 'Loser)
 -> Either
      (UpdateRoundVoteStateError blk)
      (Maybe (PerasTargetVoteState blk 'Loser)))
-> Point blk
-> Map (Point blk) (PerasTargetVoteState blk 'Loser)
-> Either
     (UpdateRoundVoteStateError blk)
     (Map (Point blk) (PerasTargetVoteState blk 'Loser))
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF Maybe (PerasTargetVoteState blk 'Loser)
-> Either
     (UpdateRoundVoteStateError blk)
     (Maybe (PerasTargetVoteState blk 'Loser))
updateMaybeLoserVoteState Point blk
votePoint Map (Point blk) (PerasTargetVoteState blk 'Loser)
loserStates
              pure $
                state
                  { prvsState =
                      Right
                        Quorum
                          { excessVotes = excessVotes + 1
                          , winnerState = winnerState
                          , loserStates = loserStates'
                          }
                  }

-- | Updates the round vote states map with the given vote.
--
-- A new entry is created if necessary (i.e., if there is no existing state for
-- the vote's round).
--
-- May fail if the state transition is invalid (e.g., a loser going above
-- quorum) or if forging the certificate fails.
updatePerasRoundVoteStates ::
  forall blk.
  StandardHash blk =>
  WithArrivalTime (ValidatedPerasVote blk) ->
  PerasCfg blk ->
  Map PerasRoundNo (PerasRoundVoteState blk) ->
  Either
    (UpdateRoundVoteStateError blk)
    (PerasRoundVoteState blk, Map PerasRoundNo (PerasRoundVoteState blk))
updatePerasRoundVoteStates :: forall blk.
StandardHash blk =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasCfg blk
-> Map PerasRoundNo (PerasRoundVoteState blk)
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasRoundVoteState blk,
      Map PerasRoundNo (PerasRoundVoteState blk))
updatePerasRoundVoteStates WithArrivalTime (ValidatedPerasVote blk)
vote PerasCfg blk
cfg =
  (Maybe (PerasRoundVoteState blk)
 -> Either
      (UpdateRoundVoteStateError blk)
      (PerasRoundVoteState blk, PerasRoundVoteState blk))
-> PerasRoundNo
-> Map PerasRoundNo (PerasRoundVoteState blk)
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasRoundVoteState blk,
      Map PerasRoundNo (PerasRoundVoteState blk))
forall k a e.
Ord k =>
(Maybe a -> Either e (a, a))
-> k -> Map k a -> Either e (a, Map k a)
alterMapAndReturnUpdatedValue
    Maybe (PerasRoundVoteState blk)
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasRoundVoteState blk, PerasRoundVoteState blk)
updateMaybePerasRoundVoteState
    (WithArrivalTime (ValidatedPerasVote blk) -> PerasRoundNo
forall vote. HasPerasVoteRound vote => vote -> PerasRoundNo
getPerasVoteRound WithArrivalTime (ValidatedPerasVote blk)
vote)
 where
  -- We use the Functor instance of `Compose (Either e) ((,) s)` ≅
  -- `λt. Either e (s, t)` in `Map.alterF`. That way, we can return both the
  -- updated map and the updated leaf in one pass, and still handle errors.
  alterMapAndReturnUpdatedValue ::
    Ord k =>
    (Maybe a -> Either e (a, a)) ->
    k ->
    Map k a ->
    Either e (a, Map k a)
  alterMapAndReturnUpdatedValue :: forall k a e.
Ord k =>
(Maybe a -> Either e (a, a))
-> k -> Map k a -> Either e (a, Map k a)
alterMapAndReturnUpdatedValue Maybe a -> Either e (a, a)
f k
k =
    Compose (Either e) ((,) a) (Map k a) -> Either e (a, Map k a)
forall {k1} {k2} (f :: k1 -> *) (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose (Either e) ((,) a) (Map k a) -> Either e (a, Map k a))
-> (Map k a -> Compose (Either e) ((,) a) (Map k a))
-> Map k a
-> Either e (a, Map k a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe a -> Compose (Either e) ((,) a) (Maybe a))
-> k -> Map k a -> Compose (Either e) ((,) a) (Map k a)
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
Map.alterF ((a -> Maybe a)
-> Compose (Either e) ((,) a) a
-> Compose (Either e) ((,) a) (Maybe a)
forall a b.
(a -> b)
-> Compose (Either e) ((,) a) a -> Compose (Either e) ((,) a) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Compose (Either e) ((,) a) a
 -> Compose (Either e) ((,) a) (Maybe a))
-> (Maybe a -> Compose (Either e) ((,) a) a)
-> Maybe a
-> Compose (Either e) ((,) a) (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either e (a, a) -> Compose (Either e) ((,) a) a
forall {k} {k1} (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Either e (a, a) -> Compose (Either e) ((,) a) a)
-> (Maybe a -> Either e (a, a))
-> Maybe a
-> Compose (Either e) ((,) a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> Either e (a, a)
f)) k
k

  -- If there is no existing state for the vote's round, create a fresh one.
  existingOrFreshRoundVoteState ::
    Maybe (PerasRoundVoteState blk) ->
    PerasRoundVoteState blk
  existingOrFreshRoundVoteState :: Maybe (PerasRoundVoteState blk) -> PerasRoundVoteState blk
existingOrFreshRoundVoteState =
    PerasRoundVoteState blk
-> Maybe (PerasRoundVoteState blk) -> PerasRoundVoteState blk
forall a. a -> Maybe a -> a
fromMaybe (PerasRoundNo -> PerasRoundVoteState blk
forall blk. PerasRoundNo -> PerasRoundVoteState blk
freshRoundVoteState (WithArrivalTime (ValidatedPerasVote blk) -> PerasRoundNo
forall vote. HasPerasVoteRound vote => vote -> PerasRoundNo
getPerasVoteRound WithArrivalTime (ValidatedPerasVote blk)
vote))

  -- Update the round state, creating a fresh one if necessary, and returning
  -- the updated state.
  updateMaybePerasRoundVoteState ::
    Maybe (PerasRoundVoteState blk) ->
    Either
      (UpdateRoundVoteStateError blk)
      (PerasRoundVoteState blk, PerasRoundVoteState blk)
  updateMaybePerasRoundVoteState :: Maybe (PerasRoundVoteState blk)
-> Either
     (UpdateRoundVoteStateError blk)
     (PerasRoundVoteState blk, PerasRoundVoteState blk)
updateMaybePerasRoundVoteState Maybe (PerasRoundVoteState blk)
mRoundState = do
    let roundState :: PerasRoundVoteState blk
roundState = Maybe (PerasRoundVoteState blk) -> PerasRoundVoteState blk
existingOrFreshRoundVoteState Maybe (PerasRoundVoteState blk)
mRoundState
    newRoundState <- WithArrivalTime (ValidatedPerasVote blk)
-> PerasCfg blk
-> PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
forall blk.
StandardHash blk =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasCfg blk
-> PerasRoundVoteState blk
-> Either (UpdateRoundVoteStateError blk) (PerasRoundVoteState blk)
updatePerasRoundVoteState WithArrivalTime (ValidatedPerasVote blk)
vote PerasCfg blk
cfg PerasRoundVoteState blk
roundState
    pure (newRoundState, newRoundState)

{-------------------------------------------------------------------------------
  Peras round vote state pattern synonyms
-------------------------------------------------------------------------------}

-- These pattern synonyms hide internal details of the round vote state, while
-- allowing the client to observe when a certificate has just been forged.

-- | Matches a round vote state where a certificate has just been forged
pattern VoteGeneratedNewCert ::
  ValidatedPerasCert blk ->
  PerasRoundVoteState blk
pattern $mVoteGeneratedNewCert :: forall {r} {blk}.
PerasRoundVoteState blk
-> (ValidatedPerasCert blk -> r) -> ((# #) -> r) -> r
VoteGeneratedNewCert cert <-
  (voteGeneratedCert -> Just cert)

-- | Matches a round vote state where a certificate has either not yet been
-- forged, or was forged by a previous vote
pattern VoteDidntGenerateNewCert ::
  PerasRoundVoteState blk
pattern $mVoteDidntGenerateNewCert :: forall {r} {blk}.
PerasRoundVoteState blk -> ((# #) -> r) -> ((# #) -> r) -> r
VoteDidntGenerateNewCert <-
  (voteGeneratedCert -> Nothing)

{-# COMPLETE VoteGeneratedNewCert, VoteDidntGenerateNewCert #-}

-- | Helper for the above pattern synonyms
voteGeneratedCert :: PerasRoundVoteState blk -> Maybe (ValidatedPerasCert blk)
voteGeneratedCert :: forall blk.
PerasRoundVoteState blk -> Maybe (ValidatedPerasCert blk)
voteGeneratedCert = \case
  PerasRoundVoteState
    { prvsState :: forall blk.
PerasRoundVoteState blk -> Either (NoQuorum blk) (Quorum blk)
prvsState =
      Right
        Quorum
          { excessVotes :: forall blk. Quorum blk -> Word64
excessVotes = Word64
0 -- just reached quorum
          , winnerState :: forall blk. Quorum blk -> PerasTargetVoteState blk 'Winner
winnerState = PerasTargetVoteWinner PerasTargetVoteTally blk
_ ValidatedPerasCert blk
cert
          }
    } ->
      ValidatedPerasCert blk -> Maybe (ValidatedPerasCert blk)
forall a. a -> Maybe a
Just ValidatedPerasCert blk
cert
  PerasRoundVoteState blk
_ ->
    Maybe (ValidatedPerasCert blk)
forall a. Maybe a
Nothing

{-------------------------------------------------------------------------------
  Peras target vote tally
-------------------------------------------------------------------------------}

-- | Tally of votes for a given target (round number and block point)
data PerasTargetVoteTally blk = PerasTargetVoteTally
  { forall blk. PerasTargetVoteTally blk -> PerasVoteTarget blk
ptvtTarget :: !(PerasVoteTarget blk)
  -- ^ What we are tallying votes for
  , forall blk.
PerasTargetVoteTally blk
-> Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
ptvtVotes :: !(Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk)))
  -- ^ Votes received for this target, indexed by vote ID
  , forall blk. PerasTargetVoteTally blk -> PerasVoteStake
ptvtTotalStake :: !PerasVoteStake
  -- ^ Total stake of the votes received for this target
  }
  deriving stock ((forall x.
 PerasTargetVoteTally blk -> Rep (PerasTargetVoteTally blk) x)
-> (forall x.
    Rep (PerasTargetVoteTally blk) x -> PerasTargetVoteTally blk)
-> Generic (PerasTargetVoteTally blk)
forall x.
Rep (PerasTargetVoteTally blk) x -> PerasTargetVoteTally blk
forall x.
PerasTargetVoteTally blk -> Rep (PerasTargetVoteTally blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x.
Rep (PerasTargetVoteTally blk) x -> PerasTargetVoteTally blk
forall blk x.
PerasTargetVoteTally blk -> Rep (PerasTargetVoteTally blk) x
$cfrom :: forall blk x.
PerasTargetVoteTally blk -> Rep (PerasTargetVoteTally blk) x
from :: forall x.
PerasTargetVoteTally blk -> Rep (PerasTargetVoteTally blk) x
$cto :: forall blk x.
Rep (PerasTargetVoteTally blk) x -> PerasTargetVoteTally blk
to :: forall x.
Rep (PerasTargetVoteTally blk) x -> PerasTargetVoteTally blk
Generic, PerasTargetVoteTally blk -> PerasTargetVoteTally blk -> Bool
(PerasTargetVoteTally blk -> PerasTargetVoteTally blk -> Bool)
-> (PerasTargetVoteTally blk -> PerasTargetVoteTally blk -> Bool)
-> Eq (PerasTargetVoteTally blk)
forall blk.
StandardHash blk =>
PerasTargetVoteTally blk -> PerasTargetVoteTally blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
StandardHash blk =>
PerasTargetVoteTally blk -> PerasTargetVoteTally blk -> Bool
== :: PerasTargetVoteTally blk -> PerasTargetVoteTally blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
PerasTargetVoteTally blk -> PerasTargetVoteTally blk -> Bool
/= :: PerasTargetVoteTally blk -> PerasTargetVoteTally blk -> Bool
Eq, Int -> PerasTargetVoteTally blk -> ShowS
[PerasTargetVoteTally blk] -> ShowS
PerasTargetVoteTally blk -> String
(Int -> PerasTargetVoteTally blk -> ShowS)
-> (PerasTargetVoteTally blk -> String)
-> ([PerasTargetVoteTally blk] -> ShowS)
-> Show (PerasTargetVoteTally blk)
forall blk.
StandardHash blk =>
Int -> PerasTargetVoteTally blk -> ShowS
forall blk. StandardHash blk => [PerasTargetVoteTally blk] -> ShowS
forall blk. StandardHash blk => PerasTargetVoteTally blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk.
StandardHash blk =>
Int -> PerasTargetVoteTally blk -> ShowS
showsPrec :: Int -> PerasTargetVoteTally blk -> ShowS
$cshow :: forall blk. StandardHash blk => PerasTargetVoteTally blk -> String
show :: PerasTargetVoteTally blk -> String
$cshowList :: forall blk. StandardHash blk => [PerasTargetVoteTally blk] -> ShowS
showList :: [PerasTargetVoteTally blk] -> ShowS
Show)
  deriving anyclass Context -> PerasTargetVoteTally blk -> IO (Maybe ThunkInfo)
Proxy (PerasTargetVoteTally blk) -> String
(Context -> PerasTargetVoteTally blk -> IO (Maybe ThunkInfo))
-> (Context -> PerasTargetVoteTally blk -> IO (Maybe ThunkInfo))
-> (Proxy (PerasTargetVoteTally blk) -> String)
-> NoThunks (PerasTargetVoteTally blk)
forall blk.
StandardHash blk =>
Context -> PerasTargetVoteTally blk -> IO (Maybe ThunkInfo)
forall blk.
StandardHash blk =>
Proxy (PerasTargetVoteTally blk) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall blk.
StandardHash blk =>
Context -> PerasTargetVoteTally blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> PerasTargetVoteTally blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
StandardHash blk =>
Context -> PerasTargetVoteTally blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PerasTargetVoteTally blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall blk.
StandardHash blk =>
Proxy (PerasTargetVoteTally blk) -> String
showTypeOf :: Proxy (PerasTargetVoteTally blk) -> String
NoThunks

freshTargetVoteTally :: PerasVoteTarget blk -> PerasTargetVoteTally blk
freshTargetVoteTally :: forall blk. PerasVoteTarget blk -> PerasTargetVoteTally blk
freshTargetVoteTally PerasVoteTarget blk
target =
  PerasTargetVoteTally
    { ptvtTarget :: PerasVoteTarget blk
ptvtTarget = PerasVoteTarget blk
target
    , ptvtVotes :: Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
ptvtVotes = Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
forall k a. Map k a
Map.empty
    , ptvtTotalStake :: PerasVoteStake
ptvtTotalStake = Rational -> PerasVoteStake
PerasVoteStake Rational
0
    }

-- | Add a vote to an existing target tally if it isn't already present,
-- and update the stake accordingly.
--
-- PRECONDITION: the vote's target must match the tally's target.
updateTargetVoteTally ::
  StandardHash blk =>
  WithArrivalTime (ValidatedPerasVote blk) ->
  PerasTargetVoteTally blk ->
  PerasTargetVoteTally blk
updateTargetVoteTally :: forall blk.
StandardHash blk =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteTally blk -> PerasTargetVoteTally blk
updateTargetVoteTally
  WithArrivalTime (ValidatedPerasVote blk)
vote
  ptvt :: PerasTargetVoteTally blk
ptvt@PerasTargetVoteTally
    { Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
ptvtVotes :: forall blk.
PerasTargetVoteTally blk
-> Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
ptvtVotes :: Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
ptvtVotes
    , PerasVoteTarget blk
ptvtTarget :: forall blk. PerasTargetVoteTally blk -> PerasVoteTarget blk
ptvtTarget :: PerasVoteTarget blk
ptvtTarget
    , PerasVoteStake
ptvtTotalStake :: forall blk. PerasTargetVoteTally blk -> PerasVoteStake
ptvtTotalStake :: PerasVoteStake
ptvtTotalStake
    } =
    Bool -> PerasTargetVoteTally blk -> PerasTargetVoteTally blk
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteTarget blk
forall vote blk.
HasPerasVoteTarget vote blk =>
vote -> PerasVoteTarget blk
getPerasVoteTarget WithArrivalTime (ValidatedPerasVote blk)
vote PerasVoteTarget blk -> PerasVoteTarget blk -> Bool
forall a. Eq a => a -> a -> Bool
== PerasVoteTarget blk
ptvtTarget) (PerasTargetVoteTally blk -> PerasTargetVoteTally blk)
-> PerasTargetVoteTally blk -> PerasTargetVoteTally blk
forall a b. (a -> b) -> a -> b
$ do
      PerasTargetVoteTally blk
ptvt
        { ptvtVotes = pvaVotes'
        , ptvtTotalStake = pvaTotalStake'
        }
   where
    swapVote :: WithArrivalTime (ValidatedPerasVote blk)
-> Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
-> (Maybe (WithArrivalTime (ValidatedPerasVote blk)),
    Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk)))
swapVote =
      (PerasVoteId blk
 -> WithArrivalTime (ValidatedPerasVote blk)
 -> WithArrivalTime (ValidatedPerasVote blk)
 -> WithArrivalTime (ValidatedPerasVote blk))
-> PerasVoteId blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
-> (Maybe (WithArrivalTime (ValidatedPerasVote blk)),
    Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk)))
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
Map.insertLookupWithKey
        (\PerasVoteId blk
_k WithArrivalTime (ValidatedPerasVote blk)
old WithArrivalTime (ValidatedPerasVote blk)
_new -> WithArrivalTime (ValidatedPerasVote blk)
old)
        (WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteId blk
forall vote blk. HasPerasVoteId vote blk => vote -> PerasVoteId blk
getPerasVoteId WithArrivalTime (ValidatedPerasVote blk)
vote)

    (Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
pvaVotes', PerasVoteStake
pvaTotalStake')
      -- key WAS NOT present → vote inserted and stake updated
      | (Maybe (WithArrivalTime (ValidatedPerasVote blk))
Nothing, Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
votes') <- WithArrivalTime (ValidatedPerasVote blk)
-> Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
-> (Maybe (WithArrivalTime (ValidatedPerasVote blk)),
    Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk)))
swapVote WithArrivalTime (ValidatedPerasVote blk)
vote Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
ptvtVotes =
          (Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
votes', PerasVoteStake
ptvtTotalStake PerasVoteStake -> PerasVoteStake -> PerasVoteStake
forall a. Num a => a -> a -> a
+ ValidatedPerasVote blk -> PerasVoteStake
forall blk. ValidatedPerasVote blk -> PerasVoteStake
vpvVoteStake (WithArrivalTime (ValidatedPerasVote blk) -> ValidatedPerasVote blk
forall a. WithArrivalTime a -> a
forgetArrivalTime WithArrivalTime (ValidatedPerasVote blk)
vote))
      -- key WAS already present → votes and stake unchanged
      | Bool
otherwise =
          (Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
ptvtVotes, PerasVoteStake
ptvtTotalStake)

{-------------------------------------------------------------------------------
  Peras target vote status
-------------------------------------------------------------------------------}

-- | Indicate the current status of the target w.r.t the voting process
data PerasTargetVoteStatus
  = Candidate
  | Winner
  | Loser
  deriving stock (PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
(PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool)
-> (PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool)
-> Eq PerasTargetVoteStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
== :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
$c/= :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
/= :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
Eq, Eq PerasTargetVoteStatus
Eq PerasTargetVoteStatus =>
(PerasTargetVoteStatus -> PerasTargetVoteStatus -> Ordering)
-> (PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool)
-> (PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool)
-> (PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool)
-> (PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool)
-> (PerasTargetVoteStatus
    -> PerasTargetVoteStatus -> PerasTargetVoteStatus)
-> (PerasTargetVoteStatus
    -> PerasTargetVoteStatus -> PerasTargetVoteStatus)
-> Ord PerasTargetVoteStatus
PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
PerasTargetVoteStatus -> PerasTargetVoteStatus -> Ordering
PerasTargetVoteStatus
-> PerasTargetVoteStatus -> PerasTargetVoteStatus
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Ordering
compare :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Ordering
$c< :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
< :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
$c<= :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
<= :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
$c> :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
> :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
$c>= :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
>= :: PerasTargetVoteStatus -> PerasTargetVoteStatus -> Bool
$cmax :: PerasTargetVoteStatus
-> PerasTargetVoteStatus -> PerasTargetVoteStatus
max :: PerasTargetVoteStatus
-> PerasTargetVoteStatus -> PerasTargetVoteStatus
$cmin :: PerasTargetVoteStatus
-> PerasTargetVoteStatus -> PerasTargetVoteStatus
min :: PerasTargetVoteStatus
-> PerasTargetVoteStatus -> PerasTargetVoteStatus
Ord, Int -> PerasTargetVoteStatus -> ShowS
[PerasTargetVoteStatus] -> ShowS
PerasTargetVoteStatus -> String
(Int -> PerasTargetVoteStatus -> ShowS)
-> (PerasTargetVoteStatus -> String)
-> ([PerasTargetVoteStatus] -> ShowS)
-> Show PerasTargetVoteStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PerasTargetVoteStatus -> ShowS
showsPrec :: Int -> PerasTargetVoteStatus -> ShowS
$cshow :: PerasTargetVoteStatus -> String
show :: PerasTargetVoteStatus -> String
$cshowList :: [PerasTargetVoteStatus] -> ShowS
showList :: [PerasTargetVoteStatus] -> ShowS
Show, (forall x. PerasTargetVoteStatus -> Rep PerasTargetVoteStatus x)
-> (forall x. Rep PerasTargetVoteStatus x -> PerasTargetVoteStatus)
-> Generic PerasTargetVoteStatus
forall x. Rep PerasTargetVoteStatus x -> PerasTargetVoteStatus
forall x. PerasTargetVoteStatus -> Rep PerasTargetVoteStatus x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PerasTargetVoteStatus -> Rep PerasTargetVoteStatus x
from :: forall x. PerasTargetVoteStatus -> Rep PerasTargetVoteStatus x
$cto :: forall x. Rep PerasTargetVoteStatus x -> PerasTargetVoteStatus
to :: forall x. Rep PerasTargetVoteStatus x -> PerasTargetVoteStatus
Generic)
  deriving anyclass Context -> PerasTargetVoteStatus -> IO (Maybe ThunkInfo)
Proxy PerasTargetVoteStatus -> String
(Context -> PerasTargetVoteStatus -> IO (Maybe ThunkInfo))
-> (Context -> PerasTargetVoteStatus -> IO (Maybe ThunkInfo))
-> (Proxy PerasTargetVoteStatus -> String)
-> NoThunks PerasTargetVoteStatus
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> PerasTargetVoteStatus -> IO (Maybe ThunkInfo)
noThunks :: Context -> PerasTargetVoteStatus -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PerasTargetVoteStatus -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PerasTargetVoteStatus -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy PerasTargetVoteStatus -> String
showTypeOf :: Proxy PerasTargetVoteStatus -> String
NoThunks

-- | Voting state for a given target.
--
-- We indicate at type level the status of the target w.r.t the voting process.
data PerasTargetVoteState blk (status :: PerasTargetVoteStatus) where
  PerasTargetVoteCandidate ::
    !(PerasTargetVoteTally blk) ->
    PerasTargetVoteState blk 'Candidate
  PerasTargetVoteLoser ::
    !(PerasTargetVoteTally blk) ->
    PerasTargetVoteState blk 'Loser
  PerasTargetVoteWinner ::
    !(PerasTargetVoteTally blk) ->
    !(ValidatedPerasCert blk) ->
    PerasTargetVoteState blk 'Winner

deriving stock instance
  ( Eq (PerasTargetVoteTally blk)
  , Eq (ValidatedPerasCert blk)
  ) =>
  Eq (PerasTargetVoteState blk status)

deriving stock instance
  ( Ord (PerasTargetVoteTally blk)
  , Ord (ValidatedPerasCert blk)
  ) =>
  Ord (PerasTargetVoteState blk status)

deriving stock instance
  ( Show (PerasTargetVoteTally blk)
  , Show (ValidatedPerasCert blk)
  ) =>
  Show (PerasTargetVoteState blk status)

instance
  ( NoThunks (PerasTargetVoteTally blk)
  , NoThunks (ValidatedPerasCert blk)
  ) =>
  NoThunks (PerasTargetVoteState blk status)
  where
  -- avoid the Generic-based default
  showTypeOf :: Proxy (PerasTargetVoteState blk status) -> String
showTypeOf Proxy (PerasTargetVoteState blk status)
_ = String
"PerasTargetVoteState"

  -- we can just delegate wNoThunks to our custom noThunks
  wNoThunks :: Context -> PerasTargetVoteState blk status -> IO (Maybe ThunkInfo)
wNoThunks = Context -> PerasTargetVoteState blk status -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks

  noThunks :: Context -> PerasTargetVoteState blk status -> IO (Maybe ThunkInfo)
noThunks Context
ctx (PerasTargetVoteCandidate PerasTargetVoteTally blk
tally) =
    Context -> PerasTargetVoteTally blk -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx PerasTargetVoteTally blk
tally
  noThunks Context
ctx (PerasTargetVoteLoser PerasTargetVoteTally blk
tally) =
    Context -> PerasTargetVoteTally blk -> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx PerasTargetVoteTally blk
tally
  noThunks Context
ctx (PerasTargetVoteWinner PerasTargetVoteTally blk
tally ValidatedPerasCert blk
cert) =
    Context
-> (PerasTargetVoteTally blk, ValidatedPerasCert blk)
-> IO (Maybe ThunkInfo)
forall a. NoThunks a => Context -> a -> IO (Maybe ThunkInfo)
noThunks Context
ctx (PerasTargetVoteTally blk
tally, ValidatedPerasCert blk
cert)

instance HasPerasVoteRound (PerasTargetVoteState blk status) where
  getPerasVoteRound :: PerasTargetVoteState blk status -> PerasRoundNo
getPerasVoteRound = PerasVoteTarget blk -> PerasRoundNo
forall blk. PerasVoteTarget blk -> PerasRoundNo
pvtRoundNo (PerasVoteTarget blk -> PerasRoundNo)
-> (PerasTargetVoteState blk status -> PerasVoteTarget blk)
-> PerasTargetVoteState blk status
-> PerasRoundNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasTargetVoteTally blk -> PerasVoteTarget blk
forall blk. PerasTargetVoteTally blk -> PerasVoteTarget blk
ptvtTarget (PerasTargetVoteTally blk -> PerasVoteTarget blk)
-> (PerasTargetVoteState blk status -> PerasTargetVoteTally blk)
-> PerasTargetVoteState blk status
-> PerasVoteTarget blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasTargetVoteState blk status -> PerasTargetVoteTally blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasTargetVoteTally blk
ptvsVoteTally

instance HasPerasVoteBlock (PerasTargetVoteState blk status) blk where
  getPerasVoteBlock :: PerasTargetVoteState blk status -> Point blk
getPerasVoteBlock = PerasVoteTarget blk -> Point blk
forall blk. PerasVoteTarget blk -> Point blk
pvtBlock (PerasVoteTarget blk -> Point blk)
-> (PerasTargetVoteState blk status -> PerasVoteTarget blk)
-> PerasTargetVoteState blk status
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasTargetVoteTally blk -> PerasVoteTarget blk
forall blk. PerasTargetVoteTally blk -> PerasVoteTarget blk
ptvtTarget (PerasTargetVoteTally blk -> PerasVoteTarget blk)
-> (PerasTargetVoteState blk status -> PerasTargetVoteTally blk)
-> PerasTargetVoteState blk status
-> PerasVoteTarget blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasTargetVoteState blk status -> PerasTargetVoteTally blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasTargetVoteTally blk
ptvsVoteTally

-- | Extract the underlying vote tally from a target vote state
ptvsVoteTally :: PerasTargetVoteState blk status -> PerasTargetVoteTally blk
ptvsVoteTally :: forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasTargetVoteTally blk
ptvsVoteTally = \case
  PerasTargetVoteCandidate PerasTargetVoteTally blk
tally -> PerasTargetVoteTally blk
tally
  PerasTargetVoteLoser PerasTargetVoteTally blk
tally -> PerasTargetVoteTally blk
tally
  PerasTargetVoteWinner PerasTargetVoteTally blk
tally ValidatedPerasCert blk
_ -> PerasTargetVoteTally blk
tally

-- | Extract the total stake from a target vote state
ptvsTotalStake :: PerasTargetVoteState blk status -> PerasVoteStake
ptvsTotalStake :: forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasVoteStake
ptvsTotalStake = PerasTargetVoteTally blk -> PerasVoteStake
forall blk. PerasTargetVoteTally blk -> PerasVoteStake
ptvtTotalStake (PerasTargetVoteTally blk -> PerasVoteStake)
-> (PerasTargetVoteState blk status -> PerasTargetVoteTally blk)
-> PerasTargetVoteState blk status
-> PerasVoteStake
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasTargetVoteState blk status -> PerasTargetVoteTally blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasTargetVoteTally blk
ptvsVoteTally

freshCandidateVoteState :: PerasVoteTarget blk -> PerasTargetVoteState blk 'Candidate
freshCandidateVoteState :: forall blk.
PerasVoteTarget blk -> PerasTargetVoteState blk 'Candidate
freshCandidateVoteState PerasVoteTarget blk
target =
  PerasTargetVoteTally blk -> PerasTargetVoteState blk 'Candidate
forall blk.
PerasTargetVoteTally blk -> PerasTargetVoteState blk 'Candidate
PerasTargetVoteCandidate (PerasVoteTarget blk -> PerasTargetVoteTally blk
forall blk. PerasVoteTarget blk -> PerasTargetVoteTally blk
freshTargetVoteTally PerasVoteTarget blk
target)

freshLoserVoteState :: PerasVoteTarget blk -> PerasTargetVoteState blk 'Loser
freshLoserVoteState :: forall blk. PerasVoteTarget blk -> PerasTargetVoteState blk 'Loser
freshLoserVoteState PerasVoteTarget blk
target =
  PerasTargetVoteTally blk -> PerasTargetVoteState blk 'Loser
forall blk.
PerasTargetVoteTally blk -> PerasTargetVoteState blk 'Loser
PerasTargetVoteLoser (PerasVoteTarget blk -> PerasTargetVoteTally blk
forall blk. PerasVoteTarget blk -> PerasTargetVoteTally blk
freshTargetVoteTally PerasVoteTarget blk
target)

-- | Convert a 'Candidate' state to a 'Loser' state.
--
-- This function is called on all candidates (except the winner) once a winner
-- is elected.
candidateToLoser ::
  PerasTargetVoteState blk 'Candidate ->
  PerasTargetVoteState blk 'Loser
candidateToLoser :: forall blk.
PerasTargetVoteState blk 'Candidate
-> PerasTargetVoteState blk 'Loser
candidateToLoser (PerasTargetVoteCandidate PerasTargetVoteTally blk
tally) =
  PerasTargetVoteTally blk -> PerasTargetVoteState blk 'Loser
forall blk.
PerasTargetVoteTally blk -> PerasTargetVoteState blk 'Loser
PerasTargetVoteLoser PerasTargetVoteTally blk
tally

-- | Subtype of 'PerasTargetVoteState' to indicate whether the target remains a
-- candidate or has been elected winner
data PerasVoteStateCandidateOrWinner blk
  = RemainedCandidate (PerasTargetVoteState blk 'Candidate)
  | BecameWinner (PerasTargetVoteState blk 'Winner)

-- | Add a vote to an existing target vote state if it isn't already present.
--
-- May fail if the candidate is elected winner but forging the certificate fails.
updateCandidateVoteState ::
  StandardHash blk =>
  PerasCfg blk ->
  WithArrivalTime (ValidatedPerasVote blk) ->
  PerasTargetVoteState blk 'Candidate ->
  Either
    (PerasForgeErr blk)
    (PerasVoteStateCandidateOrWinner blk)
updateCandidateVoteState :: forall blk.
StandardHash blk =>
PerasCfg blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Candidate
-> Either (PerasForgeErr blk) (PerasVoteStateCandidateOrWinner blk)
updateCandidateVoteState PerasCfg blk
cfg WithArrivalTime (ValidatedPerasVote blk)
vote PerasTargetVoteState blk 'Candidate
oldState =
  let
    newVoteTally :: PerasTargetVoteTally blk
newVoteTally = WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteTally blk -> PerasTargetVoteTally blk
forall blk.
StandardHash blk =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteTally blk -> PerasTargetVoteTally blk
updateTargetVoteTally WithArrivalTime (ValidatedPerasVote blk)
vote (PerasTargetVoteState blk 'Candidate -> PerasTargetVoteTally blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasTargetVoteTally blk
ptvsVoteTally PerasTargetVoteState blk 'Candidate
oldState)
    voteList :: [ValidatedPerasVote blk]
voteList = WithArrivalTime (ValidatedPerasVote blk) -> ValidatedPerasVote blk
forall a. WithArrivalTime a -> a
forgetArrivalTime (WithArrivalTime (ValidatedPerasVote blk)
 -> ValidatedPerasVote blk)
-> [WithArrivalTime (ValidatedPerasVote blk)]
-> [ValidatedPerasVote blk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
-> [WithArrivalTime (ValidatedPerasVote blk)]
forall k a. Map k a -> [a]
Map.elems (PerasTargetVoteTally blk
-> Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
forall blk.
PerasTargetVoteTally blk
-> Map (PerasVoteId blk) (WithArrivalTime (ValidatedPerasVote blk))
ptvtVotes PerasTargetVoteTally blk
newVoteTally)
   in
    case PerasCfg blk
-> [ValidatedPerasVote blk]
-> Maybe (ValidatedPerasVotesWithQuorum blk)
forall blk.
StandardHash blk =>
PerasCfg blk
-> [ValidatedPerasVote blk]
-> Maybe (ValidatedPerasVotesWithQuorum blk)
votesReachQuorum PerasCfg blk
cfg [ValidatedPerasVote blk]
voteList of
      Just ValidatedPerasVotesWithQuorum blk
votesWithQuorum -> do
        cert <- PerasCfg blk
-> ValidatedPerasVotesWithQuorum blk
-> Either (PerasForgeErr blk) (ValidatedPerasCert blk)
forall blk.
BlockSupportsPeras blk =>
PerasCfg blk
-> ValidatedPerasVotesWithQuorum blk
-> Either (PerasForgeErr blk) (ValidatedPerasCert blk)
forgePerasCert PerasCfg blk
cfg ValidatedPerasVotesWithQuorum blk
votesWithQuorum
        pure $ BecameWinner (PerasTargetVoteWinner newVoteTally cert)
      Maybe (ValidatedPerasVotesWithQuorum blk)
Nothing -> do
        PerasVoteStateCandidateOrWinner blk
-> Either (PerasForgeErr blk) (PerasVoteStateCandidateOrWinner blk)
forall a. a -> Either (PerasForgeErr blk) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PerasVoteStateCandidateOrWinner blk
 -> Either
      (PerasForgeErr blk) (PerasVoteStateCandidateOrWinner blk))
-> PerasVoteStateCandidateOrWinner blk
-> Either (PerasForgeErr blk) (PerasVoteStateCandidateOrWinner blk)
forall a b. (a -> b) -> a -> b
$ PerasTargetVoteState blk 'Candidate
-> PerasVoteStateCandidateOrWinner blk
forall blk.
PerasTargetVoteState blk 'Candidate
-> PerasVoteStateCandidateOrWinner blk
RemainedCandidate (PerasTargetVoteTally blk -> PerasTargetVoteState blk 'Candidate
forall blk.
PerasTargetVoteTally blk -> PerasTargetVoteState blk 'Candidate
PerasTargetVoteCandidate PerasTargetVoteTally blk
newVoteTally)

-- | Add a vote to an existing target vote state if it isn't already present.
--
-- PRECONDITION: the vote's target must match the underlying tally's target.
--
-- May fail if the loser goes above quorum by adding the vote.
updateLoserVoteState ::
  StandardHash blk =>
  PerasCfg blk ->
  WithArrivalTime (ValidatedPerasVote blk) ->
  PerasTargetVoteState blk 'Loser ->
  Either (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser)
updateLoserVoteState :: forall blk.
StandardHash blk =>
PerasCfg blk
-> WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Loser
-> Either
     (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser)
updateLoserVoteState PerasCfg blk
cfg WithArrivalTime (ValidatedPerasVote blk)
vote PerasTargetVoteState blk 'Loser
oldState =
  Bool
-> Either
     (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser)
-> Either
     (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser)
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteTarget blk
forall vote blk.
HasPerasVoteTarget vote blk =>
vote -> PerasVoteTarget blk
getPerasVoteTarget WithArrivalTime (ValidatedPerasVote blk)
vote PerasVoteTarget blk -> PerasVoteTarget blk -> Bool
forall a. Eq a => a -> a -> Bool
== PerasTargetVoteTally blk -> PerasVoteTarget blk
forall blk. PerasTargetVoteTally blk -> PerasVoteTarget blk
ptvtTarget (PerasTargetVoteState blk 'Loser -> PerasTargetVoteTally blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasTargetVoteTally blk
ptvsVoteTally PerasTargetVoteState blk 'Loser
oldState)) (Either
   (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser)
 -> Either
      (PerasTargetVoteState blk 'Loser)
      (PerasTargetVoteState blk 'Loser))
-> Either
     (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser)
-> Either
     (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser)
forall a b. (a -> b) -> a -> b
$ do
    let newVoteTally :: PerasTargetVoteTally blk
newVoteTally = WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteTally blk -> PerasTargetVoteTally blk
forall blk.
StandardHash blk =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteTally blk -> PerasTargetVoteTally blk
updateTargetVoteTally WithArrivalTime (ValidatedPerasVote blk)
vote (PerasTargetVoteState blk 'Loser -> PerasTargetVoteTally blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasTargetVoteTally blk
ptvsVoteTally PerasTargetVoteState blk 'Loser
oldState)
        aboveQuorum :: Bool
aboveQuorum = PerasParams -> PerasVoteStake -> Bool
stakeAboveThreshold PerasParams
PerasCfg blk
cfg (PerasTargetVoteTally blk -> PerasVoteStake
forall blk. PerasTargetVoteTally blk -> PerasVoteStake
ptvtTotalStake PerasTargetVoteTally blk
newVoteTally)
     in if Bool
aboveQuorum
          then PerasTargetVoteState blk 'Loser
-> Either
     (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser)
forall a b. a -> Either a b
Left (PerasTargetVoteState blk 'Loser
 -> Either
      (PerasTargetVoteState blk 'Loser)
      (PerasTargetVoteState blk 'Loser))
-> PerasTargetVoteState blk 'Loser
-> Either
     (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser)
forall a b. (a -> b) -> a -> b
$ PerasTargetVoteTally blk -> PerasTargetVoteState blk 'Loser
forall blk.
PerasTargetVoteTally blk -> PerasTargetVoteState blk 'Loser
PerasTargetVoteLoser PerasTargetVoteTally blk
newVoteTally
          else PerasTargetVoteState blk 'Loser
-> Either
     (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser)
forall a b. b -> Either a b
Right (PerasTargetVoteState blk 'Loser
 -> Either
      (PerasTargetVoteState blk 'Loser)
      (PerasTargetVoteState blk 'Loser))
-> PerasTargetVoteState blk 'Loser
-> Either
     (PerasTargetVoteState blk 'Loser) (PerasTargetVoteState blk 'Loser)
forall a b. (a -> b) -> a -> b
$ PerasTargetVoteTally blk -> PerasTargetVoteState blk 'Loser
forall blk.
PerasTargetVoteTally blk -> PerasTargetVoteState blk 'Loser
PerasTargetVoteLoser PerasTargetVoteTally blk
newVoteTally

-- | Add a vote to an existing target vote state if it isn't already present.
--
-- PRECONDITION: the vote's target must match the underlying tally's target.
updateWinnerVoteState ::
  StandardHash blk =>
  WithArrivalTime (ValidatedPerasVote blk) ->
  PerasTargetVoteState blk 'Winner ->
  PerasTargetVoteState blk 'Winner
updateWinnerVoteState :: forall blk.
StandardHash blk =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteState blk 'Winner
-> PerasTargetVoteState blk 'Winner
updateWinnerVoteState WithArrivalTime (ValidatedPerasVote blk)
vote PerasTargetVoteState blk 'Winner
oldState =
  Bool
-> PerasTargetVoteState blk 'Winner
-> PerasTargetVoteState blk 'Winner
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteTarget blk
forall vote blk.
HasPerasVoteTarget vote blk =>
vote -> PerasVoteTarget blk
getPerasVoteTarget WithArrivalTime (ValidatedPerasVote blk)
vote PerasVoteTarget blk -> PerasVoteTarget blk -> Bool
forall a. Eq a => a -> a -> Bool
== PerasTargetVoteTally blk -> PerasVoteTarget blk
forall blk. PerasTargetVoteTally blk -> PerasVoteTarget blk
ptvtTarget (PerasTargetVoteState blk 'Winner -> PerasTargetVoteTally blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasTargetVoteTally blk
ptvsVoteTally PerasTargetVoteState blk 'Winner
oldState)) (PerasTargetVoteState blk 'Winner
 -> PerasTargetVoteState blk 'Winner)
-> PerasTargetVoteState blk 'Winner
-> PerasTargetVoteState blk 'Winner
forall a b. (a -> b) -> a -> b
$ do
    let newVoteTally :: PerasTargetVoteTally blk
newVoteTally = WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteTally blk -> PerasTargetVoteTally blk
forall blk.
StandardHash blk =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasTargetVoteTally blk -> PerasTargetVoteTally blk
updateTargetVoteTally WithArrivalTime (ValidatedPerasVote blk)
vote (PerasTargetVoteState blk 'Winner -> PerasTargetVoteTally blk
forall blk (status :: PerasTargetVoteStatus).
PerasTargetVoteState blk status -> PerasTargetVoteTally blk
ptvsVoteTally PerasTargetVoteState blk 'Winner
oldState)
        (PerasTargetVoteWinner PerasTargetVoteTally blk
_ ValidatedPerasCert blk
cert) = PerasTargetVoteState blk 'Winner
oldState
     in PerasTargetVoteTally blk
-> ValidatedPerasCert blk -> PerasTargetVoteState blk 'Winner
forall blk.
PerasTargetVoteTally blk
-> ValidatedPerasCert blk -> PerasTargetVoteState blk 'Winner
PerasTargetVoteWinner PerasTargetVoteTally blk
newVoteTally ValidatedPerasCert blk
cert

{-------------------------------------------------------------------------------
  Helpers
-------------------------------------------------------------------------------}

-- | Apply a function to the error part of an Either
onErr :: Either e a -> (e -> e') -> Either e' a
onErr :: forall e a e'. Either e a -> (e -> e') -> Either e' a
onErr (Left e
err) e -> e'
f = e' -> Either e' a
forall a b. a -> Either a b
Left (e -> e'
f e
err)
onErr (Right a
val) e -> e'
_ = a -> Either e' a
forall a b. b -> Either a b
Right a
val