{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.Block.SupportsPeras
  ( -- * Voting committee types for Peras
    PerasVotingCommittee
  , PerasVotingCommitteeError
  , PerasVotingCommitteeInput

    -- * Epoch-dependent context for Peras
  , PerasEpochContext (..)

    -- * BlockSupportsPeras class
  , BlockSupportsPeras (..)

    -- * To be removed in favor of using per-blk definitions
  , PerasCert' (..)
  , PerasVote' (..)

    -- * To be removed in favor of using a 'PerasEpochContext' directly
  , PerasVoteStakeDistr (..)

    -- * Validated types
  , ValidatedPerasCert (..)
  , ValidatedPerasVote (..)

    -- * Peras error types
  , IsPerasError (..)

    -- * Types and functions related to Peras vote collection and quorum checking
  , PerasVoteCollection
    ( pvcTarget
    , pvcVotes
    , pvcTotalWeight
    )
  , perasVoteCollectionSingleton
  , perasVoteCollectionAddVote
  , unsafePerasVoteCollection
  , PerasVoteCollectionWithQuorum
    ( forgetQuorum
    )
  , unsafeAssumeQuorum
  , perasVoteCollectionCheckQuorum
  , toUniqueVotesWithSameTarget

    -- * Helpers
  , weightAboveThreshold

    -- * Convenience re-exports
  , module Ouroboros.Consensus.Peras.Cert.Class
  , module Ouroboros.Consensus.Peras.Params
  , module Ouroboros.Consensus.Peras.Types
  , module Ouroboros.Consensus.Peras.Void
  , module Ouroboros.Consensus.Peras.Vote.Class
  ) where

import Cardano.Binary (FromCBOR (..), ToCBOR (..))
import Codec.Serialise (Serialise (..))
import Codec.Serialise.Decoding (decodeListLenOf)
import Codec.Serialise.Encoding (encodeListLen)
import Control.Exception (assert)
import Data.Containers.NonEmpty (HasNonEmpty (..))
import Data.Kind (Type)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.Map.NonEmpty as NEMap
import Data.Map.Strict (Map)
import Data.Proxy (Proxy (..))
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import NoThunks.Class
import Ouroboros.Consensus.Block.Abstract
import Ouroboros.Consensus.BlockchainTime.WallClock.Types (WithArrivalTime (..))
import Ouroboros.Consensus.Committee.Class
  ( CryptoSupportsVotingCommittee (..)
  , UniqueVotesWithSameTarget
  , VotingCommittee
  , unsafeUniqueVotesWithSameTarget
  )
import Ouroboros.Consensus.Committee.Crypto (VoteCandidate)
import Ouroboros.Consensus.Peras.Cert.Class
import Ouroboros.Consensus.Peras.Params
import Ouroboros.Consensus.Peras.Types
import Ouroboros.Consensus.Peras.Void
import Ouroboros.Consensus.Peras.Vote.Class
import Ouroboros.Consensus.Peras.Voting.Adapter
  ( PerasConversionError
  , PerasVoteCompatibleWithVotingCommittee (..)
  )
import Ouroboros.Consensus.Util

-- * Voting committee types for Peras

-- | Voting committee for Peras indexed by block type
type PerasVotingCommittee blk =
  VotingCommittee
    (PerasCrypto blk)
    (PerasVotingCommitteeScheme blk)

-- | Error type for Peras voting committee errors
type PerasVotingCommitteeError blk =
  VotingCommitteeError
    (PerasCrypto blk)
    (PerasVotingCommitteeScheme blk)

-- | Input needed to build a Peras voting committee
type PerasVotingCommitteeInput blk =
  VotingCommitteeInput
    (PerasCrypto blk)
    (PerasVotingCommitteeScheme blk)

-- * Epoch-dependent context for Peras

-- | Epoch-dependent context used for forging and validation of objects.
data PerasEpochContext blk
  = PerasEpochContext
  { forall blk. PerasEpochContext blk -> PerasVotingCommittee blk
pecCommittee :: PerasVotingCommittee blk
  , forall blk. PerasEpochContext blk -> PerasParams blk
pecParams :: PerasParams blk
  }

instance
  ( Typeable blk
  , FromCBOR (PerasVotingCommittee blk)
  ) =>
  FromCBOR (PerasEpochContext blk)
  where
  fromCBOR :: forall s. Decoder s (PerasEpochContext blk)
fromCBOR = do
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
2
    pecCommittee <- Decoder
  s
  (VotingCommittee
     (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme)
forall s.
Decoder
  s
  (VotingCommittee
     (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme)
forall a s. FromCBOR a => Decoder s a
fromCBOR
    pecParams <- fromCBOR
    pure
      PerasEpochContext
        { pecCommittee
        , pecParams
        }

instance
  ( Typeable blk
  , ToCBOR (PerasVotingCommittee blk)
  ) =>
  ToCBOR (PerasEpochContext blk)
  where
  toCBOR :: PerasEpochContext blk -> Encoding
toCBOR
    PerasEpochContext
      { PerasVotingCommittee blk
pecCommittee :: forall blk. PerasEpochContext blk -> PerasVotingCommittee blk
pecCommittee :: PerasVotingCommittee blk
pecCommittee
      , PerasParams blk
pecParams :: forall blk. PerasEpochContext blk -> PerasParams blk
pecParams :: PerasParams blk
pecParams
      } =
      Word -> Encoding
encodeListLen Word
2
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> VotingCommittee
  (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme
-> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR VotingCommittee
  (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme
PerasVotingCommittee blk
pecCommittee
        Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasParams blk -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PerasParams blk
pecParams

deriving instance
  Show (PerasVotingCommittee blk) =>
  Show (PerasEpochContext blk)
deriving instance
  Eq (PerasVotingCommittee blk) =>
  Eq (PerasEpochContext blk)
deriving instance
  NoThunks (PerasVotingCommittee blk) =>
  NoThunks (PerasEpochContext blk)
deriving instance
  Generic (PerasEpochContext blk)

-- * Peras types

-- TODO: to be removed in favor of using a 'PerasEpochContext' directly.
newtype PerasVoteStakeDistr = PerasVoteStakeDistr
  { PerasVoteStakeDistr -> Map PerasSeatIndex VoteWeight
unPerasVoteStakeDistr :: Map PerasSeatIndex VoteWeight
  }
  deriving newtype Context -> PerasVoteStakeDistr -> IO (Maybe ThunkInfo)
Proxy PerasVoteStakeDistr -> String
(Context -> PerasVoteStakeDistr -> IO (Maybe ThunkInfo))
-> (Context -> PerasVoteStakeDistr -> IO (Maybe ThunkInfo))
-> (Proxy PerasVoteStakeDistr -> String)
-> NoThunks PerasVoteStakeDistr
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: Context -> PerasVoteStakeDistr -> IO (Maybe ThunkInfo)
noThunks :: Context -> PerasVoteStakeDistr -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> PerasVoteStakeDistr -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PerasVoteStakeDistr -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy PerasVoteStakeDistr -> String
showTypeOf :: Proxy PerasVoteStakeDistr -> String
NoThunks
  deriving stock (Int -> PerasVoteStakeDistr -> ShowS
[PerasVoteStakeDistr] -> ShowS
PerasVoteStakeDistr -> String
(Int -> PerasVoteStakeDistr -> ShowS)
-> (PerasVoteStakeDistr -> String)
-> ([PerasVoteStakeDistr] -> ShowS)
-> Show PerasVoteStakeDistr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PerasVoteStakeDistr -> ShowS
showsPrec :: Int -> PerasVoteStakeDistr -> ShowS
$cshow :: PerasVoteStakeDistr -> String
show :: PerasVoteStakeDistr -> String
$cshowList :: [PerasVoteStakeDistr] -> ShowS
showList :: [PerasVoteStakeDistr] -> ShowS
Show, PerasVoteStakeDistr -> PerasVoteStakeDistr -> Bool
(PerasVoteStakeDistr -> PerasVoteStakeDistr -> Bool)
-> (PerasVoteStakeDistr -> PerasVoteStakeDistr -> Bool)
-> Eq PerasVoteStakeDistr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PerasVoteStakeDistr -> PerasVoteStakeDistr -> Bool
== :: PerasVoteStakeDistr -> PerasVoteStakeDistr -> Bool
$c/= :: PerasVoteStakeDistr -> PerasVoteStakeDistr -> Bool
/= :: PerasVoteStakeDistr -> PerasVoteStakeDistr -> Bool
Eq, (forall x. PerasVoteStakeDistr -> Rep PerasVoteStakeDistr x)
-> (forall x. Rep PerasVoteStakeDistr x -> PerasVoteStakeDistr)
-> Generic PerasVoteStakeDistr
forall x. Rep PerasVoteStakeDistr x -> PerasVoteStakeDistr
forall x. PerasVoteStakeDistr -> Rep PerasVoteStakeDistr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. PerasVoteStakeDistr -> Rep PerasVoteStakeDistr x
from :: forall x. PerasVoteStakeDistr -> Rep PerasVoteStakeDistr x
$cto :: forall x. Rep PerasVoteStakeDistr x -> PerasVoteStakeDistr
to :: forall x. Rep PerasVoteStakeDistr x -> PerasVoteStakeDistr
Generic)

-- * BlockSupportsPeras class

class
  ( Show (PerasParams blk)
  , NoThunks (PerasCert blk)
  ) =>
  BlockSupportsPeras blk
  where
  -- | The concrete Peras vote type for this block type.
  type PerasVote blk = (vote :: Type) | vote -> blk

  type PerasVote blk = VoidPerasVote blk

  -- | The concrete Peras certificate type for this block type.
  type PerasCert blk = (cert :: Type) | cert -> blk

  type PerasCert blk = VoidPerasCert blk

  -- | The concrete Peras error type for this block type.
  type PerasError blk = (err :: Type) | err -> blk

  type PerasError blk = VoidPerasError blk

  -- | The crypto scheme used for Peras votes and certificates.
  --
  -- Used to dispatch a block type to a its corresponding voting crypto scheme.
  type PerasCrypto blk :: Type

  type PerasCrypto blk = VoidPerasCrypto blk

  -- | The voting committee scheme used for Peras.
  --
  -- Used to dispatch a block type to a its corresponding voting committee scheme.
  type PerasVotingCommitteeScheme blk :: Type

  type PerasVotingCommitteeScheme blk = VoidPerasVotingCommitteeScheme

  validatePerasCert ::
    PerasParams blk ->
    PerasCert blk ->
    Either (PerasError blk) (ValidatedPerasCert blk)

  validatePerasVote ::
    PerasParams blk ->
    PerasVoteStakeDistr ->
    PerasVote blk ->
    Either (PerasError blk) (ValidatedPerasVote blk)

  forgePerasCert ::
    PerasParams blk ->
    PerasVoteCollectionWithQuorum blk ->
    Either (PerasError blk) (ValidatedPerasCert blk)

  -- | Extract a Peras certificate optionally stored in a block.
  --
  -- Returns 'Nothing' if the block does not contain a Peras certificate, or
  -- if the block is from an era that does not support Peras certificates.
  getPerasCertInBlock ::
    blk ->
    Maybe (PerasCert blk)

-- TODO: degenerate instance for all blks to get things to compile
-- see https://github.com/tweag/cardano-peras/issues/73
instance StandardHash blk => BlockSupportsPeras blk where
  type PerasCrypto blk = VoidPerasCrypto blk
  type PerasVotingCommitteeScheme blk = VoidPerasVotingCommitteeScheme
  type PerasError blk = VoidPerasError blk

  type PerasCert blk = PerasCert' blk
  type PerasVote blk = PerasVote' blk

  validatePerasCert :: PerasParams blk
-> PerasCert blk
-> Either (PerasError blk) (ValidatedPerasCert blk)
validatePerasCert PerasParams blk
params PerasCert blk
cert =
    ValidatedPerasCert blk
-> Either (VoidPerasError blk) (ValidatedPerasCert blk)
forall a b. b -> Either a b
Right
      ValidatedPerasCert
        { vpcCert :: PerasCert blk
vpcCert = PerasCert blk
cert
        , vpcCertBoost :: PerasWeight
vpcCertBoost = PerasParams blk -> PerasWeight
forall blk. PerasParams blk -> PerasWeight
perasWeight PerasParams blk
params
        }

  validatePerasVote :: PerasParams blk
-> PerasVoteStakeDistr
-> PerasVote blk
-> Either (PerasError blk) (ValidatedPerasVote blk)
validatePerasVote PerasParams blk
_params PerasVoteStakeDistr
_stakeDistr PerasVote blk
vote =
    ValidatedPerasVote blk
-> Either (VoidPerasError blk) (ValidatedPerasVote blk)
forall a b. b -> Either a b
Right
      ValidatedPerasVote
        { vpvVote :: PerasVote blk
vpvVote = PerasVote blk
vote
        , vpvVoteWeight :: VoteWeight
vpvVoteWeight = Ratio Integer -> VoteWeight
VoteWeight Ratio Integer
0
        }

  forgePerasCert :: PerasParams blk
-> PerasVoteCollectionWithQuorum blk
-> Either (PerasError blk) (ValidatedPerasCert blk)
forgePerasCert PerasParams blk
params PerasVoteCollectionWithQuorum blk
votes =
    ValidatedPerasCert blk
-> Either (PerasError blk) (ValidatedPerasCert blk)
forall a b. b -> Either a b
Right (ValidatedPerasCert blk
 -> Either (PerasError blk) (ValidatedPerasCert blk))
-> ValidatedPerasCert blk
-> Either (PerasError blk) (ValidatedPerasCert blk)
forall a b. (a -> b) -> a -> b
$
      ValidatedPerasCert
        { vpcCert :: PerasCert blk
vpcCert =
            PerasCert
              { pcCertRound :: PerasRoundNo
pcCertRound = PerasVoteTarget blk -> PerasRoundNo
forall blk. PerasVoteTarget blk -> PerasRoundNo
pvtRoundNo (PerasVoteCollection blk -> PerasVoteTarget blk
forall blk. PerasVoteCollection blk -> PerasVoteTarget blk
pvcTarget (PerasVoteCollectionWithQuorum blk -> PerasVoteCollection blk
forall blk.
PerasVoteCollectionWithQuorum blk -> PerasVoteCollection blk
forgetQuorum PerasVoteCollectionWithQuorum blk
votes))
              , pcCertBoostedBlock :: Point blk
pcCertBoostedBlock = PerasVoteTarget blk -> Point blk
forall blk. PerasVoteTarget blk -> Point blk
pvtBlock (PerasVoteCollection blk -> PerasVoteTarget blk
forall blk. PerasVoteCollection blk -> PerasVoteTarget blk
pvcTarget (PerasVoteCollectionWithQuorum blk -> PerasVoteCollection blk
forall blk.
PerasVoteCollectionWithQuorum blk -> PerasVoteCollection blk
forgetQuorum PerasVoteCollectionWithQuorum blk
votes))
              }
        , vpcCertBoost :: PerasWeight
vpcCertBoost = PerasParams blk -> PerasWeight
forall blk. PerasParams blk -> PerasWeight
perasWeight PerasParams blk
params
        }

  getPerasCertInBlock :: blk -> Maybe (PerasCert blk)
getPerasCertInBlock blk
_ = Maybe (PerasCert blk)
Maybe (PerasCert' blk)
forall a. Maybe a
Nothing

-- | NOTE: to be removed in favor of using per-blk definitions.
data PerasCert' blk
  = PerasCert
  { forall blk. PerasCert' blk -> PerasRoundNo
pcCertRound :: PerasRoundNo
  , forall blk. PerasCert' blk -> Point blk
pcCertBoostedBlock :: Point blk
  }
  deriving stock ((forall x. PerasCert' blk -> Rep (PerasCert' blk) x)
-> (forall x. Rep (PerasCert' blk) x -> PerasCert' blk)
-> Generic (PerasCert' blk)
forall x. Rep (PerasCert' blk) x -> PerasCert' blk
forall x. PerasCert' blk -> Rep (PerasCert' blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (PerasCert' blk) x -> PerasCert' blk
forall blk x. PerasCert' blk -> Rep (PerasCert' blk) x
$cfrom :: forall blk x. PerasCert' blk -> Rep (PerasCert' blk) x
from :: forall x. PerasCert' blk -> Rep (PerasCert' blk) x
$cto :: forall blk x. Rep (PerasCert' blk) x -> PerasCert' blk
to :: forall x. Rep (PerasCert' blk) x -> PerasCert' blk
Generic, PerasCert' blk -> PerasCert' blk -> Bool
(PerasCert' blk -> PerasCert' blk -> Bool)
-> (PerasCert' blk -> PerasCert' blk -> Bool)
-> Eq (PerasCert' blk)
forall blk.
StandardHash blk =>
PerasCert' blk -> PerasCert' blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
StandardHash blk =>
PerasCert' blk -> PerasCert' blk -> Bool
== :: PerasCert' blk -> PerasCert' blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
PerasCert' blk -> PerasCert' blk -> Bool
/= :: PerasCert' blk -> PerasCert' blk -> Bool
Eq, Eq (PerasCert' blk)
Eq (PerasCert' blk) =>
(PerasCert' blk -> PerasCert' blk -> Ordering)
-> (PerasCert' blk -> PerasCert' blk -> Bool)
-> (PerasCert' blk -> PerasCert' blk -> Bool)
-> (PerasCert' blk -> PerasCert' blk -> Bool)
-> (PerasCert' blk -> PerasCert' blk -> Bool)
-> (PerasCert' blk -> PerasCert' blk -> PerasCert' blk)
-> (PerasCert' blk -> PerasCert' blk -> PerasCert' blk)
-> Ord (PerasCert' blk)
PerasCert' blk -> PerasCert' blk -> Bool
PerasCert' blk -> PerasCert' blk -> Ordering
PerasCert' blk -> PerasCert' blk -> PerasCert' blk
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
forall blk. StandardHash blk => Eq (PerasCert' blk)
forall blk.
StandardHash blk =>
PerasCert' blk -> PerasCert' blk -> Bool
forall blk.
StandardHash blk =>
PerasCert' blk -> PerasCert' blk -> Ordering
forall blk.
StandardHash blk =>
PerasCert' blk -> PerasCert' blk -> PerasCert' blk
$ccompare :: forall blk.
StandardHash blk =>
PerasCert' blk -> PerasCert' blk -> Ordering
compare :: PerasCert' blk -> PerasCert' blk -> Ordering
$c< :: forall blk.
StandardHash blk =>
PerasCert' blk -> PerasCert' blk -> Bool
< :: PerasCert' blk -> PerasCert' blk -> Bool
$c<= :: forall blk.
StandardHash blk =>
PerasCert' blk -> PerasCert' blk -> Bool
<= :: PerasCert' blk -> PerasCert' blk -> Bool
$c> :: forall blk.
StandardHash blk =>
PerasCert' blk -> PerasCert' blk -> Bool
> :: PerasCert' blk -> PerasCert' blk -> Bool
$c>= :: forall blk.
StandardHash blk =>
PerasCert' blk -> PerasCert' blk -> Bool
>= :: PerasCert' blk -> PerasCert' blk -> Bool
$cmax :: forall blk.
StandardHash blk =>
PerasCert' blk -> PerasCert' blk -> PerasCert' blk
max :: PerasCert' blk -> PerasCert' blk -> PerasCert' blk
$cmin :: forall blk.
StandardHash blk =>
PerasCert' blk -> PerasCert' blk -> PerasCert' blk
min :: PerasCert' blk -> PerasCert' blk -> PerasCert' blk
Ord, Int -> PerasCert' blk -> ShowS
[PerasCert' blk] -> ShowS
PerasCert' blk -> String
(Int -> PerasCert' blk -> ShowS)
-> (PerasCert' blk -> String)
-> ([PerasCert' blk] -> ShowS)
-> Show (PerasCert' blk)
forall blk. StandardHash blk => Int -> PerasCert' blk -> ShowS
forall blk. StandardHash blk => [PerasCert' blk] -> ShowS
forall blk. StandardHash blk => PerasCert' blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. StandardHash blk => Int -> PerasCert' blk -> ShowS
showsPrec :: Int -> PerasCert' blk -> ShowS
$cshow :: forall blk. StandardHash blk => PerasCert' blk -> String
show :: PerasCert' blk -> String
$cshowList :: forall blk. StandardHash blk => [PerasCert' blk] -> ShowS
showList :: [PerasCert' blk] -> ShowS
Show)
  deriving anyclass Context -> PerasCert' blk -> IO (Maybe ThunkInfo)
Proxy (PerasCert' blk) -> String
(Context -> PerasCert' blk -> IO (Maybe ThunkInfo))
-> (Context -> PerasCert' blk -> IO (Maybe ThunkInfo))
-> (Proxy (PerasCert' blk) -> String)
-> NoThunks (PerasCert' blk)
forall blk.
StandardHash blk =>
Context -> PerasCert' blk -> IO (Maybe ThunkInfo)
forall blk. StandardHash blk => Proxy (PerasCert' 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 -> PerasCert' blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> PerasCert' blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
StandardHash blk =>
Context -> PerasCert' blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PerasCert' blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall blk. StandardHash blk => Proxy (PerasCert' blk) -> String
showTypeOf :: Proxy (PerasCert' blk) -> String
NoThunks

-- | NOTE: to be removed in favor of using per-blk definitions.
data PerasVote' blk
  = PerasVote
  { forall blk. PerasVote' blk -> PerasRoundNo
pvVoteRound :: PerasRoundNo
  , forall blk. PerasVote' blk -> Point blk
pvVoteBlock :: Point blk
  , forall blk. PerasVote' blk -> PerasSeatIndex
pvVoteVoterId :: PerasSeatIndex
  }
  deriving stock ((forall x. PerasVote' blk -> Rep (PerasVote' blk) x)
-> (forall x. Rep (PerasVote' blk) x -> PerasVote' blk)
-> Generic (PerasVote' blk)
forall x. Rep (PerasVote' blk) x -> PerasVote' blk
forall x. PerasVote' blk -> Rep (PerasVote' blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall blk x. Rep (PerasVote' blk) x -> PerasVote' blk
forall blk x. PerasVote' blk -> Rep (PerasVote' blk) x
$cfrom :: forall blk x. PerasVote' blk -> Rep (PerasVote' blk) x
from :: forall x. PerasVote' blk -> Rep (PerasVote' blk) x
$cto :: forall blk x. Rep (PerasVote' blk) x -> PerasVote' blk
to :: forall x. Rep (PerasVote' blk) x -> PerasVote' blk
Generic, PerasVote' blk -> PerasVote' blk -> Bool
(PerasVote' blk -> PerasVote' blk -> Bool)
-> (PerasVote' blk -> PerasVote' blk -> Bool)
-> Eq (PerasVote' blk)
forall blk.
StandardHash blk =>
PerasVote' blk -> PerasVote' blk -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall blk.
StandardHash blk =>
PerasVote' blk -> PerasVote' blk -> Bool
== :: PerasVote' blk -> PerasVote' blk -> Bool
$c/= :: forall blk.
StandardHash blk =>
PerasVote' blk -> PerasVote' blk -> Bool
/= :: PerasVote' blk -> PerasVote' blk -> Bool
Eq, Eq (PerasVote' blk)
Eq (PerasVote' blk) =>
(PerasVote' blk -> PerasVote' blk -> Ordering)
-> (PerasVote' blk -> PerasVote' blk -> Bool)
-> (PerasVote' blk -> PerasVote' blk -> Bool)
-> (PerasVote' blk -> PerasVote' blk -> Bool)
-> (PerasVote' blk -> PerasVote' blk -> Bool)
-> (PerasVote' blk -> PerasVote' blk -> PerasVote' blk)
-> (PerasVote' blk -> PerasVote' blk -> PerasVote' blk)
-> Ord (PerasVote' blk)
PerasVote' blk -> PerasVote' blk -> Bool
PerasVote' blk -> PerasVote' blk -> Ordering
PerasVote' blk -> PerasVote' blk -> PerasVote' blk
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
forall blk. StandardHash blk => Eq (PerasVote' blk)
forall blk.
StandardHash blk =>
PerasVote' blk -> PerasVote' blk -> Bool
forall blk.
StandardHash blk =>
PerasVote' blk -> PerasVote' blk -> Ordering
forall blk.
StandardHash blk =>
PerasVote' blk -> PerasVote' blk -> PerasVote' blk
$ccompare :: forall blk.
StandardHash blk =>
PerasVote' blk -> PerasVote' blk -> Ordering
compare :: PerasVote' blk -> PerasVote' blk -> Ordering
$c< :: forall blk.
StandardHash blk =>
PerasVote' blk -> PerasVote' blk -> Bool
< :: PerasVote' blk -> PerasVote' blk -> Bool
$c<= :: forall blk.
StandardHash blk =>
PerasVote' blk -> PerasVote' blk -> Bool
<= :: PerasVote' blk -> PerasVote' blk -> Bool
$c> :: forall blk.
StandardHash blk =>
PerasVote' blk -> PerasVote' blk -> Bool
> :: PerasVote' blk -> PerasVote' blk -> Bool
$c>= :: forall blk.
StandardHash blk =>
PerasVote' blk -> PerasVote' blk -> Bool
>= :: PerasVote' blk -> PerasVote' blk -> Bool
$cmax :: forall blk.
StandardHash blk =>
PerasVote' blk -> PerasVote' blk -> PerasVote' blk
max :: PerasVote' blk -> PerasVote' blk -> PerasVote' blk
$cmin :: forall blk.
StandardHash blk =>
PerasVote' blk -> PerasVote' blk -> PerasVote' blk
min :: PerasVote' blk -> PerasVote' blk -> PerasVote' blk
Ord, Int -> PerasVote' blk -> ShowS
[PerasVote' blk] -> ShowS
PerasVote' blk -> String
(Int -> PerasVote' blk -> ShowS)
-> (PerasVote' blk -> String)
-> ([PerasVote' blk] -> ShowS)
-> Show (PerasVote' blk)
forall blk. StandardHash blk => Int -> PerasVote' blk -> ShowS
forall blk. StandardHash blk => [PerasVote' blk] -> ShowS
forall blk. StandardHash blk => PerasVote' blk -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall blk. StandardHash blk => Int -> PerasVote' blk -> ShowS
showsPrec :: Int -> PerasVote' blk -> ShowS
$cshow :: forall blk. StandardHash blk => PerasVote' blk -> String
show :: PerasVote' blk -> String
$cshowList :: forall blk. StandardHash blk => [PerasVote' blk] -> ShowS
showList :: [PerasVote' blk] -> ShowS
Show)
  deriving anyclass Context -> PerasVote' blk -> IO (Maybe ThunkInfo)
Proxy (PerasVote' blk) -> String
(Context -> PerasVote' blk -> IO (Maybe ThunkInfo))
-> (Context -> PerasVote' blk -> IO (Maybe ThunkInfo))
-> (Proxy (PerasVote' blk) -> String)
-> NoThunks (PerasVote' blk)
forall blk.
StandardHash blk =>
Context -> PerasVote' blk -> IO (Maybe ThunkInfo)
forall blk. StandardHash blk => Proxy (PerasVote' 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 -> PerasVote' blk -> IO (Maybe ThunkInfo)
noThunks :: Context -> PerasVote' blk -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall blk.
StandardHash blk =>
Context -> PerasVote' blk -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> PerasVote' blk -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall blk. StandardHash blk => Proxy (PerasVote' blk) -> String
showTypeOf :: Proxy (PerasVote' blk) -> String
NoThunks

instance ShowProxy blk => ShowProxy (PerasCert' blk) where
  showProxy :: Proxy (PerasCert' blk) -> String
showProxy Proxy (PerasCert' blk)
_ = String
"PerasCert " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Proxy blk -> String
forall {k} (p :: k). ShowProxy p => Proxy p -> String
showProxy (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)

instance ShowProxy blk => ShowProxy (PerasVote' blk) where
  showProxy :: Proxy (PerasVote' blk) -> String
showProxy Proxy (PerasVote' blk)
_ = String
"PerasVote " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Proxy blk -> String
forall {k} (p :: k). ShowProxy p => Proxy p -> String
showProxy (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)

instance Serialise (HeaderHash blk) => Serialise (PerasCert' blk) where
  encode :: PerasCert' blk -> Encoding
encode PerasCert{PerasRoundNo
pcCertRound :: forall blk. PerasCert' blk -> PerasRoundNo
pcCertRound :: PerasRoundNo
pcCertRound, Point blk
pcCertBoostedBlock :: forall blk. PerasCert' blk -> Point blk
pcCertBoostedBlock :: Point blk
pcCertBoostedBlock} =
    Word -> Encoding
encodeListLen Word
2
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasRoundNo -> Encoding
forall a. Serialise a => a -> Encoding
encode PerasRoundNo
pcCertRound
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Point blk -> Encoding
forall a. Serialise a => a -> Encoding
encode Point blk
pcCertBoostedBlock
  decode :: forall s. Decoder s (PerasCert' blk)
decode = do
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
2
    pcCertRound <- Decoder s PerasRoundNo
forall s. Decoder s PerasRoundNo
forall a s. Serialise a => Decoder s a
decode
    pcCertBoostedBlock <- decode
    pure $ PerasCert{pcCertRound, pcCertBoostedBlock}

instance Serialise (HeaderHash blk) => Serialise (PerasVote' blk) where
  encode :: PerasVote' blk -> Encoding
encode PerasVote{PerasRoundNo
pvVoteRound :: forall blk. PerasVote' blk -> PerasRoundNo
pvVoteRound :: PerasRoundNo
pvVoteRound, Point blk
pvVoteBlock :: forall blk. PerasVote' blk -> Point blk
pvVoteBlock :: Point blk
pvVoteBlock, PerasSeatIndex
pvVoteVoterId :: forall blk. PerasVote' blk -> PerasSeatIndex
pvVoteVoterId :: PerasSeatIndex
pvVoteVoterId} =
    Word -> Encoding
encodeListLen Word
3
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasRoundNo -> Encoding
forall a. Serialise a => a -> Encoding
encode PerasRoundNo
pvVoteRound
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Point blk -> Encoding
forall a. Serialise a => a -> Encoding
encode Point blk
pvVoteBlock
      Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> PerasSeatIndex -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR PerasSeatIndex
pvVoteVoterId
  decode :: forall s. Decoder s (PerasVote' blk)
decode = do
    Int -> Decoder s ()
forall s. Int -> Decoder s ()
decodeListLenOf Int
3
    pvVoteRound <- Decoder s PerasRoundNo
forall s. Decoder s PerasRoundNo
forall a s. Serialise a => Decoder s a
decode
    pvVoteBlock <- decode
    pvVoteVoterId <- fromCBOR
    pure $ PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId}

type instance BoostedBlock (PerasCert' blk) = Point blk
type instance BoostedBlock (PerasVote' blk) = Point blk

instance IsPerasCert (PerasCert' blk) blk where
  getPerasCertRound :: PerasCert' blk -> PerasRoundNo
getPerasCertRound = PerasCert' blk -> PerasRoundNo
forall blk. PerasCert' blk -> PerasRoundNo
pcCertRound
  getPerasCertBlock :: PerasCert' blk -> BoostedBlock (PerasCert' blk)
getPerasCertBlock = PerasCert' blk -> Point blk
PerasCert' blk -> BoostedBlock (PerasCert' blk)
forall blk. PerasCert' blk -> Point blk
pcCertBoostedBlock

instance IsPerasVote (PerasVote' blk) blk where
  getPerasVoteRound :: PerasVote' blk -> PerasRoundNo
getPerasVoteRound = PerasVote' blk -> PerasRoundNo
forall blk. PerasVote' blk -> PerasRoundNo
pvVoteRound
  getPerasVoteBlock :: PerasVote' blk -> BoostedBlock (PerasVote' blk)
getPerasVoteBlock = PerasVote' blk -> Point blk
PerasVote' blk -> BoostedBlock (PerasVote' blk)
forall blk. PerasVote' blk -> Point blk
pvVoteBlock
  getPerasVoteSeatIndex :: PerasVote' blk -> PerasSeatIndex
getPerasVoteSeatIndex = PerasVote' blk -> PerasSeatIndex
forall blk. PerasVote' blk -> PerasSeatIndex
pvVoteVoterId

-- * Validated types

data ValidatedPerasVote blk
  = ValidatedPerasVote
  { forall blk. ValidatedPerasVote blk -> PerasVote blk
vpvVote :: !(PerasVote blk)
  , forall blk. ValidatedPerasVote blk -> VoteWeight
vpvVoteWeight :: !VoteWeight
  }

deriving instance Show (PerasVote blk) => Show (ValidatedPerasVote blk)
deriving instance Eq (PerasVote blk) => Eq (ValidatedPerasVote blk)
deriving instance Ord (PerasVote blk) => Ord (ValidatedPerasVote blk)
deriving instance NoThunks (PerasVote blk) => NoThunks (ValidatedPerasVote blk)
deriving instance Generic (ValidatedPerasVote blk)

data ValidatedPerasCert blk
  = ValidatedPerasCert
  { forall blk. ValidatedPerasCert blk -> PerasCert blk
vpcCert :: !(PerasCert blk)
  , forall blk. ValidatedPerasCert blk -> PerasWeight
vpcCertBoost :: !PerasWeight
  }

type instance BoostedBlock (ValidatedPerasVote blk) = BoostedBlock (PerasVote blk)

instance
  ( IsPerasVote (PerasVote blk) blk
  , BoostedBlockCompatibleWithPoint (BoostedBlock (PerasVote blk)) blk
  ) =>
  IsPerasVote (ValidatedPerasVote blk) blk
  where
  getPerasVoteRound :: ValidatedPerasVote blk -> PerasRoundNo
getPerasVoteRound = PerasVote' blk -> PerasRoundNo
forall vote blk. IsPerasVote vote blk => vote -> PerasRoundNo
getPerasVoteRound (PerasVote' blk -> PerasRoundNo)
-> (ValidatedPerasVote blk -> PerasVote' blk)
-> ValidatedPerasVote blk
-> PerasRoundNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatedPerasVote blk -> PerasVote blk
ValidatedPerasVote blk -> PerasVote' blk
forall blk. ValidatedPerasVote blk -> PerasVote blk
vpvVote
  getPerasVoteBlock :: ValidatedPerasVote blk -> BoostedBlock (ValidatedPerasVote blk)
getPerasVoteBlock = PerasVote' blk -> Point blk
PerasVote' blk -> BoostedBlock (PerasVote' blk)
forall vote blk. IsPerasVote vote blk => vote -> BoostedBlock vote
getPerasVoteBlock (PerasVote' blk -> Point blk)
-> (ValidatedPerasVote blk -> PerasVote' blk)
-> ValidatedPerasVote blk
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatedPerasVote blk -> PerasVote blk
ValidatedPerasVote blk -> PerasVote' blk
forall blk. ValidatedPerasVote blk -> PerasVote blk
vpvVote
  getPerasVoteSeatIndex :: ValidatedPerasVote blk -> PerasSeatIndex
getPerasVoteSeatIndex = PerasVote' blk -> PerasSeatIndex
forall vote blk. IsPerasVote vote blk => vote -> PerasSeatIndex
getPerasVoteSeatIndex (PerasVote' blk -> PerasSeatIndex)
-> (ValidatedPerasVote blk -> PerasVote' blk)
-> ValidatedPerasVote blk
-> PerasSeatIndex
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatedPerasVote blk -> PerasVote blk
ValidatedPerasVote blk -> PerasVote' blk
forall blk. ValidatedPerasVote blk -> PerasVote blk
vpvVote

deriving instance Show (PerasCert blk) => Show (ValidatedPerasCert blk)
deriving instance Eq (PerasCert blk) => Eq (ValidatedPerasCert blk)
deriving instance Ord (PerasCert blk) => Ord (ValidatedPerasCert blk)
deriving instance NoThunks (PerasCert blk) => NoThunks (ValidatedPerasCert blk)
deriving instance Generic (ValidatedPerasCert blk)

type instance BoostedBlock (ValidatedPerasCert blk) = BoostedBlock (PerasCert blk)

instance
  ( IsPerasCert (PerasCert blk) blk
  , BoostedBlockCompatibleWithPoint (BoostedBlock (PerasCert blk)) blk
  ) =>
  IsPerasCert (ValidatedPerasCert blk) blk
  where
  getPerasCertRound :: ValidatedPerasCert blk -> PerasRoundNo
getPerasCertRound = PerasCert' blk -> PerasRoundNo
forall cert blk. IsPerasCert cert blk => cert -> PerasRoundNo
getPerasCertRound (PerasCert' blk -> PerasRoundNo)
-> (ValidatedPerasCert blk -> PerasCert' blk)
-> ValidatedPerasCert blk
-> PerasRoundNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatedPerasCert blk -> PerasCert blk
ValidatedPerasCert blk -> PerasCert' blk
forall blk. ValidatedPerasCert blk -> PerasCert blk
vpcCert
  getPerasCertBlock :: ValidatedPerasCert blk -> BoostedBlock (ValidatedPerasCert blk)
getPerasCertBlock = PerasCert' blk -> Point blk
PerasCert' blk -> BoostedBlock (PerasCert' blk)
forall cert blk. IsPerasCert cert blk => cert -> BoostedBlock cert
getPerasCertBlock (PerasCert' blk -> Point blk)
-> (ValidatedPerasCert blk -> PerasCert' blk)
-> ValidatedPerasCert blk
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValidatedPerasCert blk -> PerasCert blk
ValidatedPerasCert blk -> PerasCert' blk
forall blk. ValidatedPerasCert blk -> PerasCert blk
vpcCert

--- * Peras error types

-- | Error types that support injecting certain types of Peras errors
class IsPerasError err blk | err -> blk where
  injectVotingCommitteeError :: PerasVotingCommitteeError blk -> err
  injectConversionError :: PerasConversionError -> err
  injectQuorumNotReachedError :: VoteWeight -> err

instance IsPerasError (VoidPerasError blk) blk where
  injectVotingCommitteeError :: PerasVotingCommitteeError blk -> VoidPerasError blk
injectVotingCommitteeError PerasVotingCommitteeError blk
_ =
    String -> VoidPerasError blk
forall a. HasCallStack => String -> a
error String
"injectVotingCommitteeError: VoidPerasError cannot be inhabited"
  injectConversionError :: PerasConversionError -> VoidPerasError blk
injectConversionError PerasConversionError
_ =
    String -> VoidPerasError blk
forall a. HasCallStack => String -> a
error String
"injectConversionError: VoidPerasError cannot be inhabited"
  injectQuorumNotReachedError :: VoteWeight -> VoidPerasError blk
injectQuorumNotReachedError VoteWeight
_ =
    String -> VoidPerasError blk
forall a. HasCallStack => String -> a
error String
"injectQuorumNotReachedError: VoidPerasError cannot be inhabited"

-- * Types and functions related to Peras vote collection and quorum checking

-- | Collection of Peras votes for a given target.
--
-- NOTE: votes in this collection are uniquely identified by their vote ID.
data PerasVoteCollection blk
  = PerasVoteCollection
  { forall blk. PerasVoteCollection blk -> PerasVoteTarget blk
pvcTarget :: !(PerasVoteTarget blk)
  -- ^ The target of the votes in this collection
  , forall blk.
PerasVoteCollection blk
-> NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
pvcVotes :: !(NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))))
  -- ^ Votes received for this target, indexed by vote ID
  , forall blk. PerasVoteCollection blk -> VoteWeight
pvcTotalWeight :: !VoteWeight
  -- ^ Total weight of the votes received for this target
  }

deriving instance
  ( StandardHash blk
  , Show (PerasVote blk)
  , Show (PerasCert blk)
  ) =>
  Show (PerasVoteCollection blk)
deriving instance
  ( StandardHash blk
  , Eq (PerasVote blk)
  , Eq (PerasCert blk)
  ) =>
  Eq (PerasVoteCollection blk)
deriving instance
  ( StandardHash blk
  , NoThunks (PerasVote blk)
  , NoThunks (PerasCert blk)
  ) =>
  NoThunks (PerasVoteCollection blk)
deriving instance
  Generic (PerasVoteCollection blk)

-- | Construct a 'PerasVoteCollection' with a single vote.
perasVoteCollectionSingleton ::
  IsPerasVote (PerasVote blk) blk =>
  WithArrivalTime (ValidatedPerasVote blk) ->
  PerasVoteCollection blk
perasVoteCollectionSingleton :: forall blk.
IsPerasVote (PerasVote blk) blk =>
WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteCollection blk
perasVoteCollectionSingleton WithArrivalTime (ValidatedPerasVote blk)
vote =
  PerasVoteCollection
    { pvcTarget :: PerasVoteTarget blk
pvcTarget = WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteTarget blk
forall vote blk.
IsPerasVote vote blk =>
vote -> PerasVoteTarget blk
getPerasVoteTarget WithArrivalTime (ValidatedPerasVote blk)
vote
    , pvcVotes :: NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
pvcVotes = PerasVoteId
-> WithArrivalTime (ValidatedPerasVote blk)
-> NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
forall k a. k -> a -> NEMap k a
NEMap.singleton (WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteId
forall vote blk. IsPerasVote vote blk => vote -> PerasVoteId
getPerasVoteId WithArrivalTime (ValidatedPerasVote blk)
vote) WithArrivalTime (ValidatedPerasVote blk)
vote
    , pvcTotalWeight :: VoteWeight
pvcTotalWeight = ValidatedPerasVote blk -> VoteWeight
forall blk. ValidatedPerasVote blk -> VoteWeight
vpvVoteWeight (WithArrivalTime (ValidatedPerasVote blk) -> ValidatedPerasVote blk
forall a. WithArrivalTime a -> a
forgetArrivalTime WithArrivalTime (ValidatedPerasVote blk)
vote)
    }

-- | Add a vote to an existing vote collection if it isn't already present, and
-- update the total weight accordingly.
--
-- PRECONDITION: the vote's target must match the collection's target.
perasVoteCollectionAddVote ::
  ( StandardHash blk
  , IsPerasVote (PerasVote blk) blk
  ) =>
  WithArrivalTime (ValidatedPerasVote blk) ->
  PerasVoteCollection blk ->
  PerasVoteCollection blk
perasVoteCollectionAddVote :: forall blk.
(StandardHash blk, IsPerasVote (PerasVote blk) blk) =>
WithArrivalTime (ValidatedPerasVote blk)
-> PerasVoteCollection blk -> PerasVoteCollection blk
perasVoteCollectionAddVote WithArrivalTime (ValidatedPerasVote blk)
vote PerasVoteCollection blk
pvc =
  Bool -> PerasVoteCollection blk -> PerasVoteCollection blk
forall a. HasCallStack => Bool -> a -> a
assert (WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteTarget blk
forall vote blk.
IsPerasVote vote blk =>
vote -> PerasVoteTarget blk
getPerasVoteTarget WithArrivalTime (ValidatedPerasVote blk)
vote PerasVoteTarget blk -> PerasVoteTarget blk -> Bool
forall a. Eq a => a -> a -> Bool
== PerasVoteCollection blk -> PerasVoteTarget blk
forall blk. PerasVoteCollection blk -> PerasVoteTarget blk
pvcTarget PerasVoteCollection blk
pvc) (PerasVoteCollection blk -> PerasVoteCollection blk)
-> PerasVoteCollection blk -> PerasVoteCollection blk
forall a b. (a -> b) -> a -> b
$
    PerasVoteCollection blk
pvc
      { pvcVotes = pvcVotes'
      , pvcTotalWeight = pvcTotalWeight'
      }
 where
  swapVote :: WithArrivalTime (ValidatedPerasVote blk)
-> NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
-> (Maybe (WithArrivalTime (ValidatedPerasVote blk)),
    NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
swapVote =
    (PerasVoteId
 -> WithArrivalTime (ValidatedPerasVote blk)
 -> WithArrivalTime (ValidatedPerasVote blk)
 -> WithArrivalTime (ValidatedPerasVote blk))
-> PerasVoteId
-> WithArrivalTime (ValidatedPerasVote blk)
-> NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
-> (Maybe (WithArrivalTime (ValidatedPerasVote blk)),
    NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> NEMap k a -> (Maybe a, NEMap k a)
NEMap.insertLookupWithKey
      (\PerasVoteId
_k WithArrivalTime (ValidatedPerasVote blk)
old WithArrivalTime (ValidatedPerasVote blk)
_new -> WithArrivalTime (ValidatedPerasVote blk)
old)
      (WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteId
forall vote blk. IsPerasVote vote blk => vote -> PerasVoteId
getPerasVoteId WithArrivalTime (ValidatedPerasVote blk)
vote)

  (NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
pvcVotes', VoteWeight
pvcTotalWeight')
    -- key WAS NOT present → vote inserted and weight updated
    | (Maybe (WithArrivalTime (ValidatedPerasVote blk))
Nothing, NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
votes') <- WithArrivalTime (ValidatedPerasVote blk)
-> NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
-> (Maybe (WithArrivalTime (ValidatedPerasVote blk)),
    NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
swapVote WithArrivalTime (ValidatedPerasVote blk)
vote (PerasVoteCollection blk
-> NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
forall blk.
PerasVoteCollection blk
-> NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
pvcVotes PerasVoteCollection blk
pvc) =
        ( NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
votes'
        , PerasVoteCollection blk -> VoteWeight
forall blk. PerasVoteCollection blk -> VoteWeight
pvcTotalWeight PerasVoteCollection blk
pvc VoteWeight -> VoteWeight -> VoteWeight
forall a. Num a => a -> a -> a
+ ValidatedPerasVote blk -> VoteWeight
forall blk. ValidatedPerasVote blk -> VoteWeight
vpvVoteWeight (WithArrivalTime (ValidatedPerasVote blk) -> ValidatedPerasVote blk
forall a. WithArrivalTime a -> a
forgetArrivalTime WithArrivalTime (ValidatedPerasVote blk)
vote)
        )
    -- key WAS already present → votes and weight unchanged
    | Bool
otherwise =
        ( PerasVoteCollection blk
-> NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
forall blk.
PerasVoteCollection blk
-> NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
pvcVotes PerasVoteCollection blk
pvc
        , PerasVoteCollection blk -> VoteWeight
forall blk. PerasVoteCollection blk -> VoteWeight
pvcTotalWeight PerasVoteCollection blk
pvc
        )

-- | Unsafe constructor for 'PerasVoteCollection'.
--
-- The only recorded use at the moment is in the HFC implementation, to turn an
-- existing 'PerasVoteCollection' for the HardForkBlock into a
-- 'PerasVoteCollection' of a concrete era.
unsafePerasVoteCollection ::
  ( IsPerasVote (PerasVote blk) blk
  , StandardHash blk
  ) =>
  (NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))) ->
  PerasVoteCollection blk
unsafePerasVoteCollection :: forall blk.
(IsPerasVote (PerasVote blk) blk, StandardHash blk) =>
NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
-> PerasVoteCollection blk
unsafePerasVoteCollection NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
votes =
  -- NOTE: no need to check for ID uniqueness since the votes are stored in a
  -- map keyed by vote ID.
  Bool -> PerasVoteCollection blk -> PerasVoteCollection blk
forall a. HasCallStack => Bool -> a -> a
assert
    ( (WithArrivalTime (ValidatedPerasVote blk) -> Bool)
-> NonEmpty (WithArrivalTime (ValidatedPerasVote blk)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all
        (\WithArrivalTime (ValidatedPerasVote blk)
vote -> WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteTarget blk
forall vote blk.
IsPerasVote vote blk =>
vote -> PerasVoteTarget blk
getPerasVoteTarget WithArrivalTime (ValidatedPerasVote blk)
vote PerasVoteTarget blk -> PerasVoteTarget blk -> Bool
forall a. Eq a => a -> a -> Bool
== PerasVoteTarget blk
firstVoteTarget)
        (NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
-> NonEmpty (WithArrivalTime (ValidatedPerasVote blk))
forall k a. NEMap k a -> NonEmpty a
NEMap.elems NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
votes)
    )
    (PerasVoteCollection blk -> PerasVoteCollection blk)
-> PerasVoteCollection blk -> PerasVoteCollection blk
forall a b. (a -> b) -> a -> b
$ PerasVoteCollection
      { pvcTarget :: PerasVoteTarget blk
pvcTarget = PerasVoteTarget blk
firstVoteTarget
      , pvcVotes :: NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
pvcVotes = NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
votes
      , pvcTotalWeight :: VoteWeight
pvcTotalWeight = VoteWeight
totalWeight
      }
 where
  ((PerasVoteId
_, WithArrivalTime (ValidatedPerasVote blk)
firstVote) :| [(PerasVoteId, WithArrivalTime (ValidatedPerasVote blk))]
_) = NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
-> NonEmpty (PerasVoteId, WithArrivalTime (ValidatedPerasVote blk))
forall k a. NEMap k a -> NonEmpty (k, a)
NEMap.toList NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
votes
  firstVoteTarget :: PerasVoteTarget blk
firstVoteTarget = WithArrivalTime (ValidatedPerasVote blk) -> PerasVoteTarget blk
forall vote blk.
IsPerasVote vote blk =>
vote -> PerasVoteTarget blk
getPerasVoteTarget WithArrivalTime (ValidatedPerasVote blk)
firstVote
  totalWeight :: VoteWeight
totalWeight = NonEmpty VoteWeight -> VoteWeight
forall a. Num a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (ValidatedPerasVote blk -> VoteWeight
forall blk. ValidatedPerasVote blk -> VoteWeight
vpvVoteWeight (ValidatedPerasVote blk -> VoteWeight)
-> (WithArrivalTime (ValidatedPerasVote blk)
    -> ValidatedPerasVote blk)
-> WithArrivalTime (ValidatedPerasVote blk)
-> VoteWeight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithArrivalTime (ValidatedPerasVote blk) -> ValidatedPerasVote blk
forall a. WithArrivalTime a -> a
forgetArrivalTime (WithArrivalTime (ValidatedPerasVote blk) -> VoteWeight)
-> NonEmpty (WithArrivalTime (ValidatedPerasVote blk))
-> NonEmpty VoteWeight
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
-> NonEmpty (WithArrivalTime (ValidatedPerasVote blk))
forall k a. NEMap k a -> NonEmpty a
NEMap.elems NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
votes)

-- | A collection of Peras votes for a given target that has reached quorum
newtype PerasVoteCollectionWithQuorum blk
  = PerasVoteCollectionWithQuorum
  { forall blk.
PerasVoteCollectionWithQuorum blk -> PerasVoteCollection blk
forgetQuorum :: PerasVoteCollection blk
  }

deriving newtype instance
  ( StandardHash blk
  , Show (PerasVote blk)
  , Show (PerasCert blk)
  ) =>
  Show (PerasVoteCollectionWithQuorum blk)
deriving newtype instance
  ( StandardHash blk
  , Eq (PerasVote blk)
  , Eq (PerasCert blk)
  ) =>
  Eq (PerasVoteCollectionWithQuorum blk)
deriving newtype instance
  ( StandardHash blk
  , NoThunks (PerasVote blk)
  , NoThunks (PerasCert blk)
  ) =>
  NoThunks (PerasVoteCollectionWithQuorum blk)
deriving newtype instance
  Generic (PerasVoteCollectionWithQuorum blk)

-- | Transforms a 'PerasVoteCollection' into a 'PerasVoteCollectionWithQuorum'
-- without actually checking the quorum condition.
--
-- NOTE: the only recorded use at the moment is in the HFC implementation, to
-- turn an existing 'PerasVoteCollectionWithQuorum' for the HardForkBlock into
-- a 'PerasVoteCollectionWithQuorum' of a concrete era.
unsafeAssumeQuorum ::
  PerasVoteCollection blk ->
  PerasVoteCollectionWithQuorum blk
unsafeAssumeQuorum :: forall blk.
PerasVoteCollection blk -> PerasVoteCollectionWithQuorum blk
unsafeAssumeQuorum =
  PerasVoteCollection blk -> PerasVoteCollectionWithQuorum blk
forall blk.
PerasVoteCollection blk -> PerasVoteCollectionWithQuorum blk
PerasVoteCollectionWithQuorum

-- | Smart constructor for 'PerasVoteCollectionWithQuorum'
perasVoteCollectionCheckQuorum ::
  PerasParams blk ->
  PerasVoteCollection blk ->
  Maybe (PerasVoteCollectionWithQuorum blk)
perasVoteCollectionCheckQuorum :: forall blk.
PerasParams blk
-> PerasVoteCollection blk
-> Maybe (PerasVoteCollectionWithQuorum blk)
perasVoteCollectionCheckQuorum PerasParams blk
params PerasVoteCollection blk
pvc =
  case PerasParams blk -> VoteWeight -> Bool
forall blk. PerasParams blk -> VoteWeight -> Bool
weightAboveThreshold PerasParams blk
params (PerasVoteCollection blk -> VoteWeight
forall blk. PerasVoteCollection blk -> VoteWeight
pvcTotalWeight PerasVoteCollection blk
pvc) of
    Bool
True -> PerasVoteCollectionWithQuorum blk
-> Maybe (PerasVoteCollectionWithQuorum blk)
forall a. a -> Maybe a
Just (PerasVoteCollection blk -> PerasVoteCollectionWithQuorum blk
forall blk.
PerasVoteCollection blk -> PerasVoteCollectionWithQuorum blk
PerasVoteCollectionWithQuorum PerasVoteCollection blk
pvc)
    Bool
False -> Maybe (PerasVoteCollectionWithQuorum blk)
forall a. Maybe a
Nothing

-- | Convert a collection of Peras votes that has reached quorum into the
-- corresponding abstract representation of votes used by the voting committee
-- to forge certificates.
--
-- 'UniqueVotesWithSameTarget' and 'PerasVoteCollection' enforce the same
-- invariants, which are:
-- - The collection is not empty
-- - All votes have the same target
-- - All votes have a unique vote ID (or unique seat index, which is equivalent
--   assuming they also have the same target, see second point)
-- In addition to that, 'PerasVoteCollectionWithQuorum' guarantees that the
-- total weight of the votes is above the threshold.
toUniqueVotesWithSameTarget ::
  ( vote ~ PerasVote blk
  , crypto ~ PerasCrypto blk
  , committee ~ PerasVotingCommitteeScheme blk
  , PerasVoteCompatibleWithVotingCommittee vote crypto committee
  , Eq (VoteCandidate crypto)
  ) =>
  PerasVoteCollectionWithQuorum blk ->
  Either
    PerasConversionError
    (UniqueVotesWithSameTarget (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
toUniqueVotesWithSameTarget :: forall vote blk crypto committee.
(vote ~ PerasVote blk, crypto ~ PerasCrypto blk,
 committee ~ PerasVotingCommitteeScheme blk,
 PerasVoteCompatibleWithVotingCommittee vote crypto committee,
 Eq (VoteCandidate crypto)) =>
PerasVoteCollectionWithQuorum blk
-> Either
     PerasConversionError
     (UniqueVotesWithSameTarget
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
toUniqueVotesWithSameTarget (PerasVoteCollectionWithQuorum PerasVoteCollection blk
pvc) = do
  (NonEmpty
   (Vote (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme)
 -> UniqueVotesWithSameTarget
      (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme)
-> Either
     PerasConversionError
     (NonEmpty
        (Vote (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme))
-> Either
     PerasConversionError
     (UniqueVotesWithSameTarget
        (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme)
forall a b.
(a -> b)
-> Either PerasConversionError a -> Either PerasConversionError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty
  (Vote (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme)
-> UniqueVotesWithSameTarget
     (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme
NE [Vote (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme]
-> UniqueVotesWithSameTarget
     (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme
forall crypto committee.
(CryptoSupportsVotingCommittee crypto committee,
 Eq (ElectionId crypto), Eq (VoteCandidate crypto)) =>
NE [Vote crypto committee]
-> UniqueVotesWithSameTarget crypto committee
unsafeUniqueVotesWithSameTarget -- Skip redundant checks in production
    (Either
   PerasConversionError
   (NonEmpty
      (Vote (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme))
 -> Either
      PerasConversionError
      (UniqueVotesWithSameTarget
         (PerasCrypto blk) (PerasVotingCommitteeScheme blk)))
-> (PerasVoteCollection blk
    -> Either
         PerasConversionError
         (NonEmpty
            (Vote (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme)))
-> PerasVoteCollection blk
-> Either
     PerasConversionError
     (UniqueVotesWithSameTarget
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PerasVote' blk
 -> Either
      PerasConversionError
      (Vote (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme))
-> NonEmpty (PerasVote' blk)
-> Either
     PerasConversionError
     (NonEmpty
        (Vote (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse PerasVote' blk
-> Either
     PerasConversionError
     (Vote (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme)
forall vote crypto committee.
PerasVoteCompatibleWithVotingCommittee vote crypto committee =>
vote -> Either PerasConversionError (Vote crypto committee)
fromPerasVote
    (NonEmpty (PerasVote' blk)
 -> Either
      PerasConversionError
      (NonEmpty
         (Vote (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme)))
-> (PerasVoteCollection blk -> NonEmpty (PerasVote' blk))
-> PerasVoteCollection blk
-> Either
     PerasConversionError
     (NonEmpty
        (Vote (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WithArrivalTime (ValidatedPerasVote blk) -> PerasVote' blk)
-> NonEmpty (WithArrivalTime (ValidatedPerasVote blk))
-> NonEmpty (PerasVote' blk)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ValidatedPerasVote blk -> PerasVote blk
ValidatedPerasVote blk -> PerasVote' blk
forall blk. ValidatedPerasVote blk -> PerasVote blk
vpvVote (ValidatedPerasVote blk -> PerasVote' blk)
-> (WithArrivalTime (ValidatedPerasVote blk)
    -> ValidatedPerasVote blk)
-> WithArrivalTime (ValidatedPerasVote blk)
-> PerasVote' blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithArrivalTime (ValidatedPerasVote blk) -> ValidatedPerasVote blk
forall a. WithArrivalTime a -> a
forgetArrivalTime)
    (NonEmpty (WithArrivalTime (ValidatedPerasVote blk))
 -> NonEmpty (PerasVote' blk))
-> (PerasVoteCollection blk
    -> NonEmpty (WithArrivalTime (ValidatedPerasVote blk)))
-> PerasVoteCollection blk
-> NonEmpty (PerasVote' blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
-> NonEmpty (WithArrivalTime (ValidatedPerasVote blk))
forall k a. NEMap k a -> NonEmpty a
NEMap.elems
    (NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
 -> NonEmpty (WithArrivalTime (ValidatedPerasVote blk)))
-> (PerasVoteCollection blk
    -> NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
-> PerasVoteCollection blk
-> NonEmpty (WithArrivalTime (ValidatedPerasVote blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PerasVoteCollection blk
-> NEMap PerasVoteId (WithArrivalTime (ValidatedPerasVote blk))
PerasVoteCollection blk
-> NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
forall blk.
PerasVoteCollection blk
-> NE (Map PerasVoteId (WithArrivalTime (ValidatedPerasVote blk)))
pvcVotes
    (PerasVoteCollection blk
 -> Either
      PerasConversionError
      (UniqueVotesWithSameTarget
         (PerasCrypto blk) (PerasVotingCommitteeScheme blk)))
-> PerasVoteCollection blk
-> Either
     PerasConversionError
     (UniqueVotesWithSameTarget
        (PerasCrypto blk) (PerasVotingCommitteeScheme blk))
forall a b. (a -> b) -> a -> b
$ PerasVoteCollection blk
pvc

-- * Helpers

-- | Check whether a given vote weight is above the quorum threshold.
--
-- NOTE: this function assumes that the 'VoteWeight' and the quorum
-- threshold used in 'PerasParams' are expressed in the same units. That is,
-- both are either absolute or relative (normalized) values. Under the current
-- current implementation of 'PerasParams', this function only makes sense when
-- both values are relative (normalized) values.
weightAboveThreshold :: PerasParams blk -> VoteWeight -> Bool
weightAboveThreshold :: forall blk. PerasParams blk -> VoteWeight -> Bool
weightAboveThreshold PerasParams blk
params VoteWeight
voteWeight =
  Ratio Integer
weight Ratio Integer -> Ratio Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Ratio Integer
quorumThreshold Ratio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
+ Ratio Integer
safetyMargin
 where
  weight :: Ratio Integer
weight =
    VoteWeight -> Ratio Integer
unVoteWeight VoteWeight
voteWeight
  quorumThreshold :: Ratio Integer
quorumThreshold =
    PerasQuorumWeightThreshold -> Ratio Integer
unPerasQuorumWeightThreshold
      (PerasParams blk -> PerasQuorumWeightThreshold
forall blk. PerasParams blk -> PerasQuorumWeightThreshold
perasQuorumWeightThreshold PerasParams blk
params)
  safetyMargin :: Ratio Integer
safetyMargin =
    PerasQuorumWeightThresholdSafetyMargin -> Ratio Integer
unPerasQuorumWeightThresholdSafetyMargin
      (PerasParams blk -> PerasQuorumWeightThresholdSafetyMargin
forall blk.
PerasParams blk -> PerasQuorumWeightThresholdSafetyMargin
perasQuorumWeightThresholdSafetyMargin PerasParams blk
params)