TOSQUASH isolate HorizonView in SingleEraProtocol

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs

@@ -103,12 +103,16 @@ data instance ConsensusConfig ProtocolA = CfgA {
   deriving NoThunks via OnlyCheckWhnfNamed "CfgA" (ConsensusConfig ProtocolA)
 
 instance SingleEraProtocol ProtocolA where
+  type HorizonView ProtocolA = ()
+
+  projectHorizonView        _ _ = TickedTrivial
   eraTransitionHorizonView _cfg = TickedTrivial
 
+  tickChainDepState_  _ _ _ _   = TickedTrivial
+
 instance ConsensusProtocol ProtocolA where
   type ChainDepState ProtocolA = ()
   type LedgerView    ProtocolA = ()
-  type HorizonView   ProtocolA = ()
   type IsLeader      ProtocolA = ()
   type CanBeLeader   ProtocolA = ()
   type ValidateView  ProtocolA = ()
@@ -121,9 +125,8 @@ instance ConsensusProtocol ProtocolA where
 
   protocolSecurityParam = cfgA_k
 
-  projectHorizonView _ _ = TickedTrivial
+  tickChainDepState = tickChainDepStateDefault
 
-  tickChainDepState_    _ _ _ _   = TickedTrivial
   updateChainDepState   _ _ _ _ _ = return ()
   reupdateChainDepState _ _ _ _ _ = ()
 

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs

@@ -89,12 +89,16 @@ data instance ConsensusConfig ProtocolB = CfgB {
   deriving NoThunks via OnlyCheckWhnfNamed "CfgB" (ConsensusConfig ProtocolB)
 
 instance SingleEraProtocol ProtocolB where
+  type HorizonView ProtocolB = ()
+
+  projectHorizonView        _ _ = TickedTrivial
   eraTransitionHorizonView _cfg = TickedTrivial
 
+  tickChainDepState_  _ _ _ _   = TickedTrivial
+
 instance ConsensusProtocol ProtocolB where
   type ChainDepState ProtocolB = ()
   type LedgerView    ProtocolB = ()
-  type HorizonView   ProtocolB = ()
   type IsLeader      ProtocolB = ()
   type CanBeLeader   ProtocolB = ()
   type ValidateView  ProtocolB = ()
@@ -107,9 +111,8 @@ instance ConsensusProtocol ProtocolB where
 
   protocolSecurityParam = cfgB_k
 
-  projectHorizonView _ _ = TickedTrivial
+  tickChainDepState = tickChainDepStateDefault
 
-  tickChainDepState_    _ _ _ _   = TickedTrivial
   updateChainDepState   _ _ _ _ _ = return ()
   reupdateChainDepState _ _ _ _ _ = ()
 

ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/Praos.hs

@@ -74,8 +74,7 @@ import           GHC.Generics (Generic)
 import           NoThunks.Class (NoThunks)
 import           Numeric.Natural (Natural)
 import           Ouroboros.Consensus.Block (WithOrigin (NotOrigin))
-import           Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock
-                     (SingleEraProtocol (..))
+import qualified Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock as SingleEra
 import qualified Ouroboros.Consensus.HardFork.History as History
 import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey)
@@ -368,16 +367,51 @@ deriving instance PraosCrypto c => NoThunks (PraosValidationErr c)
 
 deriving instance PraosCrypto c => Show (PraosValidationErr c)
 
-instance SingleEraProtocol (Praos c) where
+instance SingleEra.SingleEraProtocol (Praos c) where
+  type HorizonView (Praos c) = ()
+
   eraTransitionHorizonView _cfg = TickedTrivial
 
+  projectHorizonView _cfg _tlv = TickedTrivial
+
+  -- Updating the chain dependent state for Praos.
+  --
+  -- Always sets 'praosStateLastSlot' to the destination slot. If we are in a
+  -- new epoch, we do two more things.
+  --
+  -- - Update the epoch nonce to the combination of the candidate nonce and the
+  --   nonce derived from the last block of the previous epoch.
+  -- - Update the "last block of previous epoch" nonce to the nonce derived from
+  --   the last applied block.
+  tickChainDepState_
+    PraosConfig {praosEpochInfo}
+    TickedTrivial
+    slot
+    st =
+      TickedPraosState st' { praosStateLastSlot = NotOrigin slot }
+      where
+        newEpoch =
+          isNewEpoch
+            (History.toPureEpochInfo praosEpochInfo)
+            (praosStateLastSlot st)
+            slot
+        st' =
+          if newEpoch
+            then
+              st
+                { praosStateEpochNonce =
+                    praosStateCandidateNonce st
+                      ⭒ praosStateLastEpochBlockNonce st,
+                  praosStateLastEpochBlockNonce = praosStateLabNonce st
+                }
+            else st
+
 instance PraosCrypto c => ConsensusProtocol (Praos c) where
   type ChainDepState (Praos c) = PraosState c
   type IsLeader (Praos c) = PraosIsLeader c
   type CanBeLeader (Praos c) = PraosCanBeLeader c
   type SelectView (Praos c) = PraosChainSelectView c
   type LedgerView (Praos c) = Views.LedgerView c
-  type HorizonView (Praos c) = ()
   type ValidationErr (Praos c) = PraosValidationErr c
   type ValidateView (Praos c) = PraosValidateView c
 
@@ -408,39 +442,7 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where
 
         rho = VRF.evalCertified () rho' praosCanBeLeaderSignKeyVRF
 
-  projectHorizonView _cfg _tlv = TickedTrivial
-
-  -- Updating the chain dependent state for Praos.
-  --
-  -- If we are not in a new epoch, then nothing happens. If we are in a new
-  -- epoch, we do three things:
-  -- - Set the last slot to what slot we are ticking to.
-  -- - Update the epoch nonce to the combination of the candidate nonce and the
-  --   nonce derived from the last block of the previous epoch.
-  -- - Update the "last block of previous epoch" nonce to the nonce derived from
-  --   the last applied block.
-  tickChainDepState_
-    PraosConfig {praosEpochInfo}
-    TickedTrivial
-    slot
-    st =
-      TickedPraosState st' { praosStateLastSlot = NotOrigin slot }
-      where
-        newEpoch =
-          isNewEpoch
-            (History.toPureEpochInfo praosEpochInfo)
-            (praosStateLastSlot st)
-            slot
-        st' =
-          if newEpoch
-            then
-              st
-                { praosStateEpochNonce =
-                    praosStateCandidateNonce st
-                      ⭒ praosStateLastEpochBlockNonce st,
-                  praosStateLastEpochBlockNonce = praosStateLabNonce st
-                }
-            else st
+  tickChainDepState = SingleEra.tickChainDepStateDefault
 
   -- Validate and update the chain dependent state as a result of processing a
   -- new header.

ouroboros-consensus-protocol/src/ouroboros-consensus-protocol/Ouroboros/Consensus/Protocol/TPraos.hs

@@ -66,8 +66,7 @@ import           GHC.Generics (Generic)
 import           NoThunks.Class (NoThunks (..))
 import           Numeric.Natural (Natural)
 import           Ouroboros.Consensus.Block
-import           Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock
-                     (SingleEraProtocol (..))
+import qualified Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock as SingleEra
 import qualified Ouroboros.Consensus.HardFork.History as History
 import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.Protocol.Ledger.HotKey (HotKey)
@@ -306,7 +305,14 @@ data instance Ticked (TPraosState c) = TickedChainDepState {
       tickedTPraosStateSlot          :: !SlotNo
     }
 
-instance SingleEraProtocol (TPraos c) where
+instance SingleEra.SingleEraProtocol (TPraos c) where
+  type HorizonView (TPraos c) = TPraosHorizonView
+
+  projectHorizonView _cfg =
+        TickedTPraosHorizonView
+      . SL.lvExtraEntropy
+      . getTickedPraosLedgerView
+
   -- When ticking from a TPraos era into another TPraos era, we always use a
   -- neutral nonce as the extra entropy even if the extra entropy protocol
   -- parameter was set to a non-neutral value either in the epoch just before or
@@ -328,13 +334,44 @@ instance SingleEraProtocol (TPraos c) where
         tickedTPraosHorizonViewExtraEntropy = SL.NeutralNonce
       }
 
+  tickChainDepState_ TPraosConfig{..}
+                     (TickedTPraosHorizonView extraEntropy)
+                     slot
+                     (TPraosState lastSlot st) =
+      TickedChainDepState {
+          tickedTPraosStateChainDepState =
+            if newEpoch then stNextEpoch else st
+        , tickedTPraosStateSlot          = slot
+        }
+    where
+      newEpoch = isNewEpoch
+                   (History.toPureEpochInfo tpraosEpochInfo)
+                   lastSlot
+                   slot
+
+      -- We can't use 'SL.tickChainDepState' as it unnecessarily takes the
+      -- entire 'SL.LedgerView' as an argument. Hence, we inline it here; future
+      -- work should include moving the TPraos logic entirely to Consensus.
+      --
+      -- Reference:
+      -- https://github.com/input-output-hk/cardano-ledger/blob/cardano-protocol-tpraos-1.0.3.5/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/API.hs#L453
+      -- https://github.com/input-output-hk/cardano-ledger/blob/cardano-protocol-tpraos-1.0.3.5/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/Rules/Tickn.hs#L96-L97
+      stNextEpoch = st {
+          SL.csTickn = SL.TicknState {
+              SL.ticknStateEpochNonce =
+                     (let SL.PrtclState _ _ x = SL.csProtocol st in x) -- candidateNonce
+                SL.⭒ SL.ticknStatePrevHashNonce (SL.csTickn st)
+                SL.⭒ extraEntropy
+            , SL.ticknStatePrevHashNonce = SL.csLabNonce st
+            }
+          }
+
 instance SL.PraosCrypto c => ConsensusProtocol (TPraos c) where
   type ChainDepState (TPraos c) = TPraosState c
   type IsLeader      (TPraos c) = TPraosIsLeader c
   type CanBeLeader   (TPraos c) = PraosCanBeLeader c
   type SelectView    (TPraos c) = PraosChainSelectView c
   type LedgerView    (TPraos c) = SL.LedgerView c
-  type HorizonView   (TPraos c) = TPraosHorizonView
   type ValidationErr (TPraos c) = SL.ChainTransitionError c
   type ValidateView  (TPraos c) = TPraosValidateView c
 
@@ -394,42 +431,7 @@ instance SL.PraosCrypto c => ConsensusProtocol (TPraos c) where
 
       SL.GenDelegs dlgMap = SL.lvGenDelegs lv
 
-  projectHorizonView _cfg =
-        TickedTPraosHorizonView
-      . SL.lvExtraEntropy
-      . getTickedPraosLedgerView
-
-  tickChainDepState_ TPraosConfig{..}
-                     (TickedTPraosHorizonView extraEntropy)
-                     slot
-                     (TPraosState lastSlot st) =
-      TickedChainDepState {
-          tickedTPraosStateChainDepState =
-            if newEpoch then stNextEpoch else st
-        , tickedTPraosStateSlot          = slot
-        }
-    where
-      newEpoch = isNewEpoch
-                   (History.toPureEpochInfo tpraosEpochInfo)
-                   lastSlot
-                   slot
-
-      -- We can't use 'SL.tickChainDepState' as it unnecessarily takes the
-      -- entire 'SL.LedgerView' as an argument. Hence, we inline it here; future
-      -- work should include moving the TPraos logic entirely to Consensus.
-      --
-      -- Reference:
-      -- https://github.com/input-output-hk/cardano-ledger/blob/cardano-protocol-tpraos-1.0.3.5/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/API.hs#L453
-      -- https://github.com/input-output-hk/cardano-ledger/blob/cardano-protocol-tpraos-1.0.3.5/libs/cardano-protocol-tpraos/src/Cardano/Protocol/TPraos/Rules/Tickn.hs#L96-L97
-      stNextEpoch = st {
-          SL.csTickn = SL.TicknState {
-              SL.ticknStateEpochNonce =
-                     (let SL.PrtclState _ _ x = SL.csProtocol st in x) -- candidateNonce
-                SL.⭒ SL.ticknStatePrevHashNonce (SL.csTickn st)
-                SL.⭒ extraEntropy
-            , SL.ticknStatePrevHashNonce = SL.csLabNonce st
-            }
-          }
+  tickChainDepState = SingleEra.tickChainDepStateDefault
 
   updateChainDepState cfg b tlv _slot cs =
       TPraosState (NotOrigin $ tickedTPraosStateSlot cs) <$>

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
 {-# LANGUAGE TypeApplications     #-}
+{-# LANGUAGE TypeFamilies         #-}
 {-# LANGUAGE TypeOperators        #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -12,6 +13,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock (
   , SingleEraProtocol (..)
   , proxySingle
   , singleEraTransition'
+  , tickChainDepStateDefault
     -- * Era index
   , EraIndex (..)
   , eraIndexEmpty
@@ -24,6 +26,7 @@ module Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock (
 
 import           Codec.Serialise
 import           Data.Either (isRight)
+import           Data.Kind (Type)
 import           Data.Proxy
 import           Data.SOP.BasicFunctors
 import           Data.SOP.Constraint
@@ -57,10 +60,40 @@ import           Ouroboros.Consensus.Util.Condense
 
 -- | Protocols which can be used as part of a 'HardForkProtocol'.
 class SingleEraProtocol p where
+  -- | A projection of 'LedgerView' containing only what is needed for ticking
+  --
+  -- For single-era protocols, there are further constraints on this type, see
+  -- 'Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock.eraTransitionHorizonView'.
+  -- Usually, 'HorizonView' will be a singleton type.
+  --
+  -- For the 'Ouroboros.Consensus.HardFork.Combinator.Basics.HardForkProtocol'
+  -- combinator, this is the same as the 'LedgerView'.
+  type family HorizonView p :: Type
+
+  projectHorizonView :: ConsensusConfig     p
+                     -> Ticked (LedgerView  p)
+                     -> Ticked (HorizonView p)
+
   -- | The horizon view that will be used when ticking across an era boundary.
   -- In all other cases, the HFC logic will use 'projectHorizonView'.
   eraTransitionHorizonView :: ConsensusConfig p -> Ticked (HorizonView p)
 
+  -- | A variant of 'tickChainDepState' that requires only the 'HorizonView'
+  -- instead of 'LedgerView'.
+  tickChainDepState_ :: ConsensusConfig p
+                     -> Ticked (HorizonView p)
+                     -> SlotNo
+                     -> ChainDepState p
+                     -> Ticked (ChainDepState p)
+
+tickChainDepStateDefault :: SingleEraProtocol p
+                         => ConsensusConfig p
+                         -> Ticked (LedgerView p)
+                         -> SlotNo
+                         -> ChainDepState p
+                         -> Ticked (ChainDepState p)
+tickChainDepStateDefault cfg = tickChainDepState_ cfg . projectHorizonView cfg
+
 -- | Blocks from which we can assemble a hard fork
 class ( LedgerSupportsProtocol blk
       , InspectLedger blk

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs

@@ -96,14 +96,13 @@ instance CanHardFork xs => ConsensusProtocol (HardForkProtocol xs) where
   type ValidationErr (HardForkProtocol xs) = HardForkValidationErr xs
   type SelectView    (HardForkProtocol xs) = HardForkSelectView    xs
   type LedgerView    (HardForkProtocol xs) = HardForkLedgerView    xs
-  type HorizonView   (HardForkProtocol xs) = HardForkLedgerView    xs
   type CanBeLeader   (HardForkProtocol xs) = HardForkCanBeLeader   xs
   type IsLeader      (HardForkProtocol xs) = HardForkIsLeader      xs
   type ValidateView  (HardForkProtocol xs) = OneEraValidateView    xs
 
   -- Operations on the state
 
-  tickChainDepState_    = tick
+  tickChainDepState     = tick
   checkIsLeader         = check
   updateChainDepState   = update
   reupdateChainDepState = reupdate
@@ -115,8 +114,6 @@ instance CanHardFork xs => ConsensusProtocol (HardForkProtocol xs) where
   -- Security parameter must be equal across /all/ eras
   protocolSecurityParam = hardForkConsensusConfigK
 
-  projectHorizonView _cfg = id
-
 {-------------------------------------------------------------------------------
   BlockSupportsProtocol
 -------------------------------------------------------------------------------}