[Peras 46] Introduce Void Peras types and helpers

changelog.d/20260731_153846_agustin.mista_void_helpers.md

@@ -0,0 +1,24 @@
+<!--
+A new scriv changelog fragment.
+
+Uncomment the section that is right (remove the HTML comment wrapper).
+For top level release notes, leave all the headers commented out.
+-->
+
+<!--
+### Breaking
+
+- A bullet item for the Breaking category.
+
+-->
+
+### Non-Breaking
+
+- Add Void-based Peras types and associated type class instances (`VoidPerasVote`, `VoidPerasCert`, `VoidPerasError`, `VoidPerasCrypto`, and `VoidPerasVotingCommitteeScheme`).
+
+<!--
+### Patch
+
+- A bullet item for the Patch category.
+
+-->

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

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
 

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

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

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 ()