diff --git a/changelog.d/20260731_153846_agustin.mista_void_helpers.md b/changelog.d/20260731_153846_agustin.mista_void_helpers.md new file mode 100644 index 0000000000..a8ba3bbbf4 --- /dev/null +++ b/changelog.d/20260731_153846_agustin.mista_void_helpers.md @@ -0,0 +1,24 @@ + + + + +### Non-Breaking + +- Add Void-based Peras types and associated type class instances (`VoidPerasVote`, `VoidPerasCert`, `VoidPerasError`, `VoidPerasCrypto`, and `VoidPerasVotingCommitteeScheme`). + + diff --git a/ouroboros-consensus.cabal b/ouroboros-consensus.cabal index 36eed3ae20..ce9f5dc1f1 100644 --- a/ouroboros-consensus.cabal +++ b/ouroboros-consensus.cabal @@ -243,6 +243,7 @@ library Ouroboros.Consensus.Peras.Params Ouroboros.Consensus.Peras.SelectView Ouroboros.Consensus.Peras.Types + Ouroboros.Consensus.Peras.Void Ouroboros.Consensus.Peras.Vote.Aggregation Ouroboros.Consensus.Peras.Vote.Class Ouroboros.Consensus.Peras.Vote.V1 diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs index 2906758c6d..ef0ea099f9 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs @@ -63,6 +63,7 @@ module Ouroboros.Consensus.Block.SupportsPeras -- * Convenience re-exports , module Ouroboros.Consensus.Peras.Params , module Ouroboros.Consensus.Peras.Types + , module Ouroboros.Consensus.Peras.Void ) where import Cardano.Binary (FromCBOR (..), ToCBOR (..)) @@ -77,7 +78,6 @@ import Data.Map.Strict (Map) import Data.Monoid (Sum (..)) import Data.Proxy (Proxy (..)) import Data.Typeable (Typeable) -import Data.Void (Void) import GHC.Generics (Generic) import NoThunks.Class import Ouroboros.Consensus.Block.Abstract @@ -88,6 +88,7 @@ import Ouroboros.Consensus.Committee.Class ) import Ouroboros.Consensus.Peras.Params import Ouroboros.Consensus.Peras.Types hiding (PerasVoteId (..)) +import Ouroboros.Consensus.Peras.Void import Ouroboros.Consensus.Peras.Voting.Adapter (PerasConversionError) import Ouroboros.Consensus.Util import Quiet (Quiet (..)) @@ -364,9 +365,9 @@ class -- 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 = Void - type PerasVotingCommitteeScheme blk = Void - type PerasError blk = Void + type PerasCrypto blk = VoidPerasCrypto blk + type PerasVotingCommitteeScheme blk = VoidPerasVotingCommitteeScheme + type PerasError blk = VoidPerasError blk type PerasCfg blk = PerasParams blk diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs index cb9d026384..c868bd0c12 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Context.hs @@ -17,6 +17,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +-- TODO: remove this after getting rid of the degenerate 'BlockSupportsPeras' +-- instance that renders some of the constraints here redundant. +{-# OPTIONS_GHC -Wno-redundant-constraints #-} module Ouroboros.Consensus.Peras.Context ( -- * Bounded Peras epoch context diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Void.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Void.hs new file mode 100644 index 0000000000..3c65ecd0ea --- /dev/null +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Peras/Void.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Helpers to derive @BlockSupportsPeras@ for block types without Peras support. +module Ouroboros.Consensus.Peras.Void + ( VoidPerasVote (..) + , VoidPerasCert (..) + , VoidPerasError (..) + , VoidPerasCrypto + , VoidPerasVotingCommitteeScheme + , absurdVoidPerasVotingCommitteeError + , absurdVoidPerasCert + ) where + +import Cardano.Binary (FromCBOR (..), ToCBOR (..)) +import Control.Exception.Base (Exception) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Typeable (Typeable) +import Data.Void (Void, absurd) +import GHC.Generics (Generic) +import NoThunks.Class (NoThunks) +import Ouroboros.Consensus.Block.Abstract (Point) +import Ouroboros.Consensus.Committee.Class + ( CryptoSupportsVotingCommittee (..) + , VotingCommittee + , getRawVotes + ) +import Ouroboros.Consensus.Committee.Crypto + ( CryptoSupportsVoteSigning (..) + , ElectionId + , PrivateKey + , PublicKey + , VoteCandidate + ) +import Ouroboros.Consensus.Peras.Cert.Class +import Ouroboros.Consensus.Peras.Types (BoostedBlock, PerasRoundNo) +import Ouroboros.Consensus.Peras.Vote.Class +import Ouroboros.Consensus.Peras.Voting.Adapter + ( PerasCertCompatibleWithVotingCommittee (..) + , PerasVoteCompatibleWithVotingCommittee (..) + ) +import Ouroboros.Consensus.Util (ShowProxy) + +-- | Imposible Peras vote for @blk@. +-- +-- NOTE: the phantom @blk@ is used to keep the 'PerasVote' type family injective. +newtype VoidPerasVote blk + = VoidPerasVote + { unVoidPerasVote :: Void + } + deriving newtype (Show, Eq, NoThunks, ShowProxy) + +-- | Imposible Peras certificate for @blk@. +-- +-- NOTE: the phantom @blk@ is used to keep the 'PerasCert' type family injective. +newtype VoidPerasCert blk + = VoidPerasCert + { unVoidPerasCert :: Void + } + deriving newtype (Show, Eq, NoThunks, ShowProxy) + +type instance BoostedBlock (VoidPerasVote blk) = Point blk +type instance BoostedBlock (VoidPerasCert blk) = Point blk + +instance IsPerasVote (VoidPerasVote blk) blk where + getPerasVoteRound = absurd . unVoidPerasVote + getPerasVoteBlock = absurd . unVoidPerasVote + getPerasVoteSeatIndex = absurd . unVoidPerasVote + +instance IsPerasCert (VoidPerasCert blk) blk where + getPerasCertRound = absurd . unVoidPerasCert + getPerasCertBlock = absurd . unVoidPerasCert + +-- | Void Peras error for @blk@. +-- +-- NOTE: the phantom @blk@ is used to keep the 'PerasError' type family injective. +newtype VoidPerasError blk + = VoidPerasError + { unVoidPerasError :: Void + } + deriving newtype (Show, Eq, NoThunks, Generic, ShowProxy, Exception) + +-- | Void Peras committee for @blk@. +data VoidPerasVotingCommitteeScheme + deriving (Show, Eq, Generic, NoThunks) + +data VoidPerasCrypto blk + deriving (Show, Eq, Generic, NoThunks) + +type instance ElectionId (VoidPerasCrypto blk) = PerasRoundNo +type instance VoteCandidate (VoidPerasCrypto blk) = Point blk + +type instance PrivateKey (VoidPerasCrypto blk) = () +type instance PublicKey (VoidPerasCrypto blk) = Void + +instance CryptoSupportsVoteSigning (VoidPerasCrypto blk) where + type VoteSigningKey (VoidPerasCrypto blk) = () + type VoteVerificationKey (VoidPerasCrypto blk) = Void + data VoteSignature (VoidPerasCrypto blk) = VoidVoteSignature () + getVoteSigningKey _proxy _privateKey = () + getVoteVerificationKey _proxy publicKey = absurd publicKey + signVote _signingKey _ _ = VoidVoteSignature () + verifyVoteSignature verificationKey _ _ _ = absurd verificationKey + +newtype instance VotingCommittee (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme + = VoidPerasVotingCommittee Void + +instance CryptoSupportsVotingCommittee (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme where + newtype VotingCommitteeError (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme + = VoidPerasVotingCommitteeError Void + newtype VotingCommitteeInput (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme + = VoidPerasVotingCommitteeInput Void + newtype EligibilityWitness (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme + = VoidPerasEligibilityWitness Void + newtype Cert (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme + = VoidPerasCert' {unCommitteeCert :: VoidPerasCert blk} + newtype Vote (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme + = VoidPerasVote' {unCommitteeVote :: VoidPerasVote blk} + + mkVotingCommittee (VoidPerasVotingCommitteeInput void) = absurd void + checkShouldVote (VoidPerasVotingCommittee void) _ _ _ = absurd void + forgeVote (VoidPerasEligibilityWitness void) _ _ _ = absurd void + verifyVote (VoidPerasVotingCommittee void) _ = absurd void + eligiblePartyVoteWeight (VoidPerasVotingCommittee void) _ = absurd void + forgeCert = absurd . telescope + where + telescope = unVoidPerasVote . unCommitteeVote . NonEmpty.head . getRawVotes + verifyCert (VoidPerasVotingCommittee void) _ = absurd void + voteTarget (VoidPerasVote' (VoidPerasVote void)) = absurd void + compareVotesById (VoidPerasVote' (VoidPerasVote void)) _ = absurd void + +-- | Exists solely to silence a 'defined-but-not-used' warning on the +-- 'VoidPerasVotingCommitteeError' constructor. +absurdVoidPerasVotingCommitteeError :: + VotingCommitteeError (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme -> + a +absurdVoidPerasVotingCommitteeError (VoidPerasVotingCommitteeError void) = + absurd void + +-- | Exists solely to silence a 'defined-but-not-used' warning on the +-- 'VoidPerasCert' constructor. +absurdVoidPerasCert :: + Cert (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme -> + a +absurdVoidPerasCert (VoidPerasCert' (VoidPerasCert void)) = + absurd void + +deriving newtype instance + Show (VotingCommittee (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme) +deriving newtype instance + Eq (VotingCommittee (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme) +deriving newtype instance + NoThunks (VotingCommittee (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme) +deriving newtype instance + Generic (VotingCommittee (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme) + +deriving newtype instance + Typeable blk => + FromCBOR (VotingCommittee (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme) +deriving newtype instance + Typeable blk => + ToCBOR (VotingCommittee (VoidPerasCrypto blk) VoidPerasVotingCommitteeScheme) + +instance + PerasVoteCompatibleWithVotingCommittee + (VoidPerasVote blk) + (VoidPerasCrypto blk) + VoidPerasVotingCommitteeScheme + where + toPerasVote = absurd . unVoidPerasVote . unCommitteeVote + fromPerasVote = absurd . unVoidPerasVote + +instance + PerasCertCompatibleWithVotingCommittee + (VoidPerasCert blk) + (VoidPerasCrypto blk) + VoidPerasVotingCommitteeScheme + where + toPerasCert = absurd . unVoidPerasCert . unCommitteeCert + fromPerasCert = absurd . unVoidPerasCert diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs index cb5977fe09..a2e743f0d1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/Orphans.hs @@ -35,6 +35,7 @@ import Data.SOP.BasicFunctors import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import Data.Typeable (Typeable) +import Data.Void (Void) import NoThunks.Class ( InspectHeapNamed (..) , NoThunks (..) @@ -135,3 +136,10 @@ deriving via OnlyCheckWhnfNamed "SomeHasFS" (SomeHasFS m) instance NoThunks (SomeHasFS m) + +{------------------------------------------------------------------------------- + ShowProxy +-------------------------------------------------------------------------------} + +instance ShowProxy Void +instance ShowProxy ()