WIP removing degenerate BlockSupportsPeras instance

Author: agustinmista

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs

@@ -277,8 +277,9 @@ mkHandlers ::
   ( IOLike m
   , MonadTime m
   , MonadTimer m
-  , LedgerSupportsMempool blk
   , HasTxId (GenTx blk)
+  , BlockSupportsPeras blk
+  , LedgerSupportsMempool blk
   , LedgerSupportsProtocol blk
   , Ord addrNTN
   , Hashable addrNTN
@@ -622,6 +623,8 @@ showTracers ::
   , Show (Header blk)
   , Show (GenTx blk)
   , Show (GenTxId blk)
+  , Show (PerasVote blk)
+  , Show (PerasCert blk)
   , HasHeader blk
   , HasNestedContent Header blk
   ) =>
@@ -779,6 +782,8 @@ mkApps ::
   , ShowProxy (Header blk)
   , ShowProxy (TxId (GenTx blk))
   , ShowProxy (GenTx blk)
+  , ShowProxy (PerasVote blk)
+  , ShowProxy (PerasCert blk)
   , Show addrNTN
   , LedgerSupportsMempool blk
   , HasTxId (GenTx blk)

ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/Tracers.hs

@@ -191,6 +191,8 @@ showTracers ::
   , Show (ForgeStateUpdateError blk)
   , Show (CannotForge blk)
   , Show (TxMeasure blk)
+  , Show (PerasVote blk)
+  , Show (PerasCert blk)
   , Show remotePeer
   , LedgerSupportsProtocol blk
   ) =>

ouroboros-consensus.cabal

@@ -158,6 +158,7 @@ library
     Ouroboros.Consensus.HardFork.Combinator.Node.DiffusionPipelining
     Ouroboros.Consensus.HardFork.Combinator.Node.InitStorage
     Ouroboros.Consensus.HardFork.Combinator.Node.Metrics
+    Ouroboros.Consensus.HardFork.Combinator.Node.Peras
     Ouroboros.Consensus.HardFork.Combinator.Node.SanityCheck
     Ouroboros.Consensus.HardFork.Combinator.PartialConfig
     Ouroboros.Consensus.HardFork.Combinator.Protocol

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Block/SupportsPeras.hs

@@ -5,20 +5,15 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
-{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module Ouroboros.Consensus.Block.SupportsPeras
   ( BlockSupportsPeras (..)
-  , PerasCert (..)
-  , PerasVote (..)
-  , IsPerasVote (..)
-  , getPerasVoteId
-  , getPerasVoteTarget
-  , IsPerasCert (..)
+  , PerasValidationErr (..)
+  , PerasForgeErr (..)
   , ValidatedPerasCert (..)
   , ValidatedPerasVote (..)
   , ValidatedPerasVotesWithQuorum
@@ -27,14 +22,14 @@ module Ouroboros.Consensus.Block.SupportsPeras
     , vpvqPerasParams
     )
   , votesReachQuorum
+  , IsPerasVote (..)
+  , getPerasVoteId
+  , getPerasVoteTarget
+  , IsPerasCert (..)
   ) where
 
-import Cardano.Binary (FromCBOR (..), ToCBOR (..))
-import Codec.Serialise (Serialise (..))
-import Codec.Serialise.Decoding (decodeListLenOf)
-import Codec.Serialise.Encoding (encodeListLen)
 import Data.List.NonEmpty (NonEmpty (..))
-import Data.Proxy (Proxy (..))
+import Data.Typeable (Typeable)
 import GHC.Generics (Generic)
 import NoThunks.Class
 import Ouroboros.Consensus.Block.Abstract
@@ -47,38 +42,45 @@ import Ouroboros.Consensus.Peras.Types
   , PerasVoteStakeDistr (..)
   , PerasVoteTarget (..)
   , PerasVoterId (..)
-  , lookupPerasVoteStake
   , stakeAboveThreshold
   )
-import Ouroboros.Consensus.Util (ShowProxy (..))
 
 -- * BlockSupportsPeras class
 
 class
-  ( IsPerasVote (PerasVote blk) blk
+  ( StandardHash blk
+  , Typeable blk
+  , IsPerasVote (PerasVote blk) blk
   , IsPerasCert (PerasCert blk) blk
+  , Show (PerasVote blk)
+  , Show (PerasCert blk)
+  , Show (PerasValidationErr blk)
+  , Show (PerasForgeErr blk)
+  , Eq (PerasVote blk)
+  , Eq (PerasCert blk)
+  , Eq (PerasValidationErr blk)
+  , Eq (PerasForgeErr blk)
+  , NoThunks (PerasVote blk)
+  , NoThunks (PerasCert blk)
+  , NoThunks (PerasValidationErr blk)
+  , NoThunks (PerasForgeErr blk)
   ) =>
   BlockSupportsPeras blk
   where
-  data PerasCert blk
-
   data PerasVote blk
-
-  data PerasValidationErr blk
-
-  data PerasForgeErr blk
-
-  validatePerasCert ::
-    PerasParams ->
-    PerasCert blk ->
-    Either (PerasValidationErr blk) (ValidatedPerasCert blk)
+  data PerasCert blk
 
   validatePerasVote ::
     PerasParams ->
     PerasVoteStakeDistr ->
     PerasVote blk ->
     Either (PerasValidationErr blk) (ValidatedPerasVote blk)
 
+  validatePerasCert ::
+    PerasParams ->
+    PerasCert blk ->
+    Either (PerasValidationErr blk) (ValidatedPerasCert blk)
+
   forgePerasCert ::
     PerasParams ->
     ValidatedPerasVotesWithQuorum blk ->
@@ -92,106 +94,21 @@ class
     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 BlockSupportsPeras blk where
-  data PerasCert blk = PerasCert
-    { pcCertRound :: PerasRoundNo
-    , pcCertBlock :: Point blk
-    }
-    deriving stock (Generic, Eq, Ord, Show)
-    deriving anyclass NoThunks
-
-  data PerasVote blk = PerasVote
-    { pvVoteRound :: PerasRoundNo
-    , pvVoteBlock :: Point blk
-    , pvVoteVoterId :: PerasVoterId
-    }
-    deriving stock (Generic, Eq, Ord, Show)
-    deriving anyclass NoThunks
-
-  -- TODO: enrich with actual error types
-  -- see https://github.com/tweag/cardano-peras/issues/120
-  data PerasValidationErr blk
-    = PerasValidationErr
-    deriving stock (Show, Eq)
-
-  -- TODO: enrich with actual error types
-  -- see https://github.com/tweag/cardano-peras/issues/120
-  data PerasForgeErr blk
-    = PerasForgeErr
-    deriving stock (Show, Eq)
+-- * Error types
 
-  -- TODO: perform actual validation against all
-  -- possible 'PerasValidationErr' variants
-  -- see https://github.com/tweag/cardano-peras/issues/120
-  validatePerasCert params cert =
-    Right
-      ValidatedPerasCert
-        { vpcCert = cert
-        , vpcCertBoost = perasWeight params
-        }
-
-  -- TODO: perform actual validation against all
-  -- possible 'PerasValidationErr' variants
-  -- see https://github.com/tweag/cardano-peras/issues/120
-  validatePerasVote _params stakeDistr vote
-    | Just stake <- lookupPerasVoteStake (getPerasVoteVoterId vote) stakeDistr =
-        Right
-          ValidatedPerasVote
-            { vpvVote = vote
-            , vpvVoteStake = stake
-            }
-    | otherwise =
-        Left PerasValidationErr
-
-  -- TODO: perform actual validation against all
-  -- possible 'PerasForgeErr' variants
-  -- see https://github.com/tweag/cardano-peras/issues/120
-  forgePerasCert params votes =
-    return $
-      ValidatedPerasCert
-        { vpcCert =
-            PerasCert
-              { pcCertRound = pvtRoundNo (vpvqTarget votes)
-              , pcCertBlock = pvtBlock (vpvqTarget votes)
-              }
-        , vpcCertBoost = perasWeight params
-        }
-
-  -- TODO: extract actual Peras certificates from blocks when the HFC plumbing
-  -- is in place.
-  getPerasCertInBlock _ = Nothing
-
-instance ShowProxy blk => ShowProxy (PerasCert blk) where
-  showProxy _ = "PerasCert " <> showProxy (Proxy @blk)
-
-instance ShowProxy blk => ShowProxy (PerasVote blk) where
-  showProxy _ = "PerasVote " <> showProxy (Proxy @blk)
-
-instance Serialise (HeaderHash blk) => Serialise (PerasCert blk) where
-  encode PerasCert{pcCertRound, pcCertBlock} =
-    encodeListLen 2
-      <> encode pcCertRound
-      <> encode pcCertBlock
-  decode = do
-    decodeListLenOf 2
-    pcCertRound <- decode
-    pcCertBlock <- decode
-    pure $ PerasCert{pcCertRound, pcCertBlock}
+-- TODO: enrich with actual error types
+-- see https://github.com/tweag/cardano-peras/issues/120
+data PerasValidationErr blk
+  = PerasValidationErr
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass NoThunks
 
-instance Serialise (HeaderHash blk) => Serialise (PerasVote blk) where
-  encode PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId} =
-    encodeListLen 3
-      <> encode pvVoteRound
-      <> encode pvVoteBlock
-      <> toCBOR (unPerasVoterId pvVoteVoterId)
-  decode = do
-    decodeListLenOf 3
-    pvVoteRound <- decode
-    pvVoteBlock <- decode
-    pvVoteVoterId <- PerasVoterId <$> fromCBOR
-    pure $ PerasVote{pvVoteRound, pvVoteBlock, pvVoteVoterId}
+-- TODO: enrich with actual error types
+-- see https://github.com/tweag/cardano-peras/issues/120
+data PerasForgeErr blk
+  = PerasForgeErr
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass NoThunks
 
 -- * Validated types
 
@@ -200,16 +117,24 @@ data ValidatedPerasVote blk
   { vpvVote :: !(PerasVote blk)
   , vpvVoteStake :: !PerasVoteStake
   }
-  deriving stock (Show, Eq, Ord, Generic)
-  deriving anyclass NoThunks
+
+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
   { vpcCert :: !(PerasCert blk)
   , vpcCertBoost :: !PerasWeight
   }
-  deriving stock (Show, Eq, Ord, Generic)
-  deriving anyclass NoThunks
+
+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)
 
 -- | A collection of validated Peras votes that:
 -- 1. are all for the same target, and
@@ -223,16 +148,34 @@ data ValidatedPerasVotesWithQuorum blk
   , vpvqPerasParams :: !PerasParams
   -- ^ The Peras parameters used to validate that the votes reach quorum
   }
-  deriving stock (Show, Eq, Generic)
-  deriving anyclass NoThunks
+
+deriving instance
+  ( StandardHash blk
+  , Show (PerasVote blk)
+  ) =>
+  Show (ValidatedPerasVotesWithQuorum blk)
+deriving instance
+  ( StandardHash blk
+  , Eq (PerasVote blk)
+  ) =>
+  Eq (ValidatedPerasVotesWithQuorum blk)
+deriving instance
+  ( StandardHash blk
+  , NoThunks (PerasVote blk)
+  ) =>
+  NoThunks (ValidatedPerasVotesWithQuorum blk)
+deriving instance
+  Generic (ValidatedPerasVotesWithQuorum blk)
 
 -- | Smart constructor for 'ValidatedPerasVotesReachingQuorum'.
 --
 -- This function checks that all votes are for the same target, and that their
 -- total stake is above the quorum threshold defined in the given 'PerasCfg'.
 -- It returns 'Nothing' if either of these conditions is not met.
 votesReachQuorum ::
-  StandardHash blk =>
+  ( StandardHash blk
+  , IsPerasVote (PerasVote blk) blk
+  ) =>
   PerasParams ->
   [ValidatedPerasVote blk] ->
   Maybe (ValidatedPerasVotesWithQuorum blk)
@@ -287,17 +230,18 @@ getPerasVoteTarget vote =
     , pvtBlock = getPerasVoteBlock vote
     }
 
-instance IsPerasVote (PerasVote blk) blk where
-  getPerasVoteRound = pvVoteRound
-  getPerasVoteBlock = pvVoteBlock
-  getPerasVoteVoterId = pvVoteVoterId
-
-instance IsPerasVote (ValidatedPerasVote blk) blk where
+instance
+  IsPerasVote (PerasVote blk) blk =>
+  IsPerasVote (ValidatedPerasVote blk) blk
+  where
   getPerasVoteRound = getPerasVoteRound . vpvVote
   getPerasVoteBlock = getPerasVoteBlock . vpvVote
   getPerasVoteVoterId = getPerasVoteVoterId . vpvVote
 
-instance IsPerasVote vote blk => IsPerasVote (WithArrivalTime vote) blk where
+instance
+  IsPerasVote vote blk =>
+  IsPerasVote (WithArrivalTime vote) blk
+  where
   getPerasVoteRound = getPerasVoteRound . forgetArrivalTime
   getPerasVoteBlock = getPerasVoteBlock . forgetArrivalTime
   getPerasVoteVoterId = getPerasVoteVoterId . forgetArrivalTime
@@ -307,11 +251,10 @@ class IsPerasCert cert blk | cert -> blk where
   getPerasCertRound :: cert -> PerasRoundNo
   getPerasCertBlock :: cert -> Point blk
 
-instance IsPerasCert (PerasCert blk) blk where
-  getPerasCertRound = pcCertRound
-  getPerasCertBlock = pcCertBlock
-
-instance IsPerasCert (ValidatedPerasCert blk) blk where
+instance
+  IsPerasCert (PerasCert blk) blk =>
+  IsPerasCert (ValidatedPerasCert blk) blk
+  where
   getPerasCertRound = getPerasCertRound . vpcCert
   getPerasCertBlock = getPerasCertBlock . vpcCert