Don't combine ticked LedgerView and ChainDepState

This was leading to unnecessary `error` calls. Instead, if protocols need the
ticked ledger view, they can include it in the ticked chain dep state.

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol.hs

@@ -373,6 +373,15 @@ newtype instance Ticked (SL.LedgerView c) = TickedPraosLedgerView {
       getTickedPraosLedgerView :: SL.LedgerView c
     }
 
+-- | Ticked ChainDep state
+--
+-- We add the ticked state to the history only when applying a header.
+data instance Ticked (TPraosState c) = TickedPraosState {
+      tickedPraosStateTicked     :: SL.ChainDepState c
+    , tickedPraosStateOrig       :: TPraosState c
+    , tickedPraosStateLedgerView :: Ticked (LedgerView (TPraos c))
+    }
+
 instance TPraosCrypto c => ConsensusProtocol (TPraos c) where
   type ChainDepState (TPraos c) = TPraosState c
   type IsLeader      (TPraos c) = TPraosProof c
@@ -384,7 +393,7 @@ instance TPraosCrypto c => ConsensusProtocol (TPraos c) where
 
   protocolSecurityParam = tpraosSecurityParam . tpraosParams
 
-  checkIsLeader cfg@TPraosConfig{..} icn hk slot (TickedPraosLedgerView lv) cs = do
+  checkIsLeader cfg@TPraosConfig{..} icn hk slot cs = do
       -- First, check whether we're in the overlay schedule
       case Map.lookup slot (SL.lvOverlaySched lv) of
         Nothing
@@ -435,7 +444,8 @@ instance TPraosCrypto c => ConsensusProtocol (TPraos c) where
         , tpraosIsCoreNodeSignKeyVRF
         } = icn
 
-      chainState = State.tickedPraosStateTicked cs
+      chainState = tickedPraosStateTicked cs
+      lv         = getTickedPraosLedgerView (tickedPraosStateLedgerView cs)
       eta0       = tickEta0 $ SL.csTickn chainState
       vkhCold    = SL.hashKey tpraosIsCoreNodeColdVerKey
       rho'       = SL.mkSeed SL.seedEta slot eta0
@@ -452,9 +462,10 @@ instance TPraosCrypto c => ConsensusProtocol (TPraos c) where
           unSlotNo slot `div` tpraosSlotsPerKESPeriod tpraosParams
 
   tickChainDepState TPraosConfig{..} (TickedPraosLedgerView lv) slot cds =
-      State.TickedPraosState {
-          tickedPraosStateTicked = cs'
-        , tickedPraosStateOrig   = cds
+      TickedPraosState {
+          tickedPraosStateTicked     = cs'
+        , tickedPraosStateOrig       = cds
+        , tickedPraosStateLedgerView = TickedPraosLedgerView lv
         }
     where
       cs' = SL.tickChainDepState
@@ -464,19 +475,15 @@ instance TPraosCrypto c => ConsensusProtocol (TPraos c) where
               (State.currentState cds)
       shelleyGlobals = mkShelleyGlobals tpraosEpochInfo tpraosParams
 
-  updateChainDepState TPraosConfig{..}
-                      b
-                      slot
-                      (TickedPraosLedgerView lv)
-                      cs = do
-      newCS <- SL.updateChainDepState shelleyGlobals lv b (State.tickedPraosStateTicked cs)
+  updateChainDepState TPraosConfig{..} b slot cs = do
+      newCS <- SL.updateChainDepState shelleyGlobals lv b (tickedPraosStateTicked cs)
       return
         $ State.prune (fromIntegral k)
-        $ State.append slot newCS (State.tickedPraosStateOrig cs)
+        $ State.append slot newCS (tickedPraosStateOrig cs)
     where
       SecurityParam k = tpraosSecurityParam tpraosParams
       shelleyGlobals = mkShelleyGlobals tpraosEpochInfo tpraosParams
-
+      lv = getTickedPraosLedgerView (tickedPraosStateLedgerView cs)
 
   -- Rewind the chain state
   --

ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Protocol/State.hs

@@ -63,14 +63,6 @@ data TPraosState c = TPraosState {
 
 instance Crypto c => NoUnexpectedThunks (TPraosState c)
 
--- | Ticked ChainDep state
---
--- We add the ticked state to the history only when applying a header.
-data instance Ticked (TPraosState c) = TickedPraosState {
-      tickedPraosStateTicked :: SL.ChainDepState c
-    , tickedPraosStateOrig   :: TPraosState c
-    }
-
 checkInvariants :: TPraosState c -> Either String ()
 checkInvariants TPraosState { anchor, historicalStates }
     -- Don't use 'Map.findMin', as its partial, giving a worse error message.

ouroboros-consensus/ouroboros-consensus-mock/src/Ouroboros/Consensus/Mock/Protocol/Praos.hs

@@ -260,8 +260,11 @@ newtype PraosChainDepState c = PraosChainDepState {
 -- point where the "nonce under construction" is swapped out for the "active"
 -- nonce. However, for the mock implementation, we keep the full history, and
 -- choose the right nonce from that; this means that ticking has no effect.
-newtype instance Ticked (PraosChainDepState c) = TickedPraosChainDepState {
-      getTickedPraosChainDepState :: PraosChainDepState c
+--
+-- We do however need access to the ticked stake distribution.
+data instance Ticked (PraosChainDepState c) = TickedPraosChainDepState {
+      tickedPraosLedgerView      :: Ticked (LedgerView (Praos c))
+    , untickedPraosChainDepState :: PraosChainDepState c
     }
 
 instance PraosCrypto c => ConsensusProtocol (Praos c) where
@@ -275,7 +278,7 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where
   type CanBeLeader   (Praos c) = CoreNodeId
   type CannotLead    (Praos c) = Void
 
-  checkIsLeader cfg@PraosConfig{..} nid _cis slot _u (TickedPraosChainDepState cds) = do
+  checkIsLeader cfg@PraosConfig{..} nid _cis slot (TickedPraosChainDepState _u  cds) = do
       if fromIntegral (getOutputVRFNatural (certifiedOutput y)) < t
       then IsLeader PraosProof {
                praosProofRho  = rho
@@ -290,13 +293,12 @@ instance PraosCrypto c => ConsensusProtocol (Praos c) where
       rho = evalCertified () rho' praosSignKeyVRF
       y   = evalCertified () y'   praosSignKeyVRF
 
-  tickChainDepState _ _ _ = TickedPraosChainDepState
+  tickChainDepState _ lv _ = TickedPraosChainDepState lv
 
   updateChainDepState cfg@PraosConfig{..}
                       (PraosValidateView PraosFields{..} toSign)
                       slot
-                      (TickedStakeDist sd)
-                      (TickedPraosChainDepState cds) = do
+                      (TickedPraosChainDepState (TickedStakeDist sd) cds) = do
     let PraosExtraFields{..} = praosExtraFields
         nid                  = praosCreator
 

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

@@ -229,31 +229,20 @@ instance SingleEraBlock b => ConsensusProtocol (DegenForkProtocol b) where
                 canBeLeader
                 chainIndepState
                 slot
-                tickedLedgerView
                 (TDCSt tickedChainDepState) =
     castLeaderCheck $
       checkIsLeader
         cfg
         canBeLeader
         chainIndepState
         slot
-        tickedLedgerView
         tickedChainDepState
 
   tickChainDepState (DConCfg cfg) view slot (DCSt st) =
       TDCSt $ tickChainDepState cfg view slot st
 
-  updateChainDepState (DConCfg cfg)
-                      valView
-                      slot
-                      tickedLedgerView
-                      (TDCSt chainDepState) =
-      DCSt <$> updateChainDepState
-                 cfg
-                 valView
-                 slot
-                 tickedLedgerView
-                 chainDepState
+  updateChainDepState (DConCfg cfg) valView slot (TDCSt chainDepState) =
+      DCSt <$> updateChainDepState cfg valView slot chainDepState
 
   rewindChainDepState _ secParam pt (DCSt chainDepState) =
       DCSt <$>

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

@@ -44,7 +44,9 @@ instance (CanHardFork xs, All CanForge xs) => CanForge (HardForkBlock xs) where
       -- First establish the 'IsLeader' and the 'LedgerState' are from the
       -- same era. As we have passed the ledger view of the ticked ledger to
       -- obtain the 'IsLeader' value, it __must__ be from the same era.
-      -- TODO: Can we avoid this error?
+      -- Unfortunately, we cannot avoid this 'error' call: the 'IsLeader'
+      -- evidence could conceivably include the ledger /view/, but not the
+      -- ledger /state/.
       case State.match (getOneEraIsLeader isLeader) ledgerState of
         Left _mismatch ->
           error "IsLeader from different era than the TickedLedgerState"

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

@@ -36,7 +36,7 @@ import           Cardano.Prelude (NoUnexpectedThunks)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.TypeFamilyWrappers
-import           Ouroboros.Consensus.Util (pairSnd, (.:))
+import           Ouroboros.Consensus.Util ((.:))
 import           Ouroboros.Consensus.Util.SOP
 
 import           Ouroboros.Consensus.HardFork.Combinator.Abstract
@@ -128,10 +128,13 @@ instance CanHardFork xs => BlockSupportsProtocol (HardForkBlock xs) where
   Ticking the chain dependent state
 -------------------------------------------------------------------------------}
 
-newtype instance Ticked (HardForkChainDepState xs) =
+data instance Ticked (HardForkChainDepState xs) =
     TickedHardForkChainDepState {
         tickedHardForkChainDepStatePerEra ::
              HardForkState_ WrapChainDepState (Ticked :.: WrapChainDepState) xs
+
+        -- 'EpochInfo' constructed from the ticked 'LedgerView'
+      , tickedHardForkChainDepStateEpochInfo :: EpochInfo Identity
       }
 
 tick :: CanHardFork xs
@@ -144,7 +147,8 @@ tick cfg@HardForkConsensusConfig{..}
      (TickedHardForkLedgerView transition ledgerView)
      slot
      chainDepState = TickedHardForkChainDepState {
-       tickedHardForkChainDepStatePerEra =
+      tickedHardForkChainDepStateEpochInfo = ei
+    , tickedHardForkChainDepStatePerEra =
          State.align
            (translateConsensus ei cfg)
            (hcmap proxySingle (fn_2 . tickOne) cfgs)
@@ -197,59 +201,36 @@ check :: forall xs. (CanHardFork xs, HasCallStack)
       -> HardForkCanBeLeader xs
       -> ChainIndepState (HardForkProtocol xs)
       -> SlotNo
-      -> Ticked (HardForkLedgerView xs)
       -> Ticked (ChainDepState (HardForkProtocol xs))
       -> LeaderCheck (HardForkProtocol xs)
 check HardForkConsensusConfig{..}
       canBeLeader
       (PerEraChainIndepState chainIndepState)
       slot
-      (TickedHardForkLedgerView transition ledgerView)
-      (TickedHardForkChainDepState chainDepState) =
-    -- TODO: Could we refactor this to get rid of this error?
-    case Match.matchNS
-           (State.tip chainDepState)
-           (State.tip ledgerView) of
-      Left mismatch ->
-        -- This shouldn't happen: 'checkIsLeader' aligned the two telescopes
-        let mismatch' :: MismatchEraInfo xs
-            mismatch' = MismatchEraInfo $
-                          Match.bihcmap
-                            proxySingle
-                            singleEraInfo
-                            ledgerViewInfo
-                            mismatch
-        in error $ "check: unexpected mismatch: " ++ show mismatch'
-      Right aligned ->
-        distrib $
-            hcpure proxySingle (fn_4 checkOne)
-          `hap`
-            cfgs
-          `hap`
-            fromOptNP canBeLeader
-          `hap`
-            chainIndepState
-          `hap`
-            aligned
+      (TickedHardForkChainDepState chainDepState ei) =
+    distrib $
+        hcpure proxySingle (fn_4 checkOne)
+      `hap`
+        cfgs
+      `hap`
+        fromOptNP canBeLeader
+      `hap`
+        chainIndepState
+      `hap`
+        State.tip chainDepState
   where
     cfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra
-    ei   = State.epochInfoPrecomputedTransitionInfo
-             hardForkConsensusConfigShape
-             transition
-             ledgerView
 
-    checkOne :: SingleEraBlock                      blk
-             => WrapPartialConsensusConfig          blk
-             -> (Maybe :.: WrapCanBeLeader)         blk
-             -> WrapChainIndepState                 blk
-             -> Product (Ticked :.: WrapChainDepState)
-                        (Ticked :.: WrapLedgerView) blk
-             -> WrapLeaderCheck                          blk
+    checkOne :: SingleEraBlock                 blk
+             => WrapPartialConsensusConfig     blk
+             -> (Maybe :.: WrapCanBeLeader)    blk
+             -> WrapChainIndepState            blk
+             -> (Ticked :.: WrapChainDepState) blk
+             -> WrapLeaderCheck                blk
     checkOne cfg'
              (Comp mCanBeLeader)
              chainIndepState'
-             (Pair (Comp chainDepState') (Comp ledgerView'))
-           = WrapLeaderCheck $
+             (Comp chainDepState') = WrapLeaderCheck $
         case mCanBeLeader of
           Nothing ->
             NotLeader
@@ -259,7 +240,6 @@ check HardForkConsensusConfig{..}
               (unwrapCanBeLeader canBeLeader')
               (unwrapChainIndepState chainIndepState')
               slot
-              (unwrapTickedLedgerView ledgerView')
               (unwrapTickedChainDepState chainDepState')
 
     distrib :: NS WrapLeaderCheck xs -> LeaderCheck (HardForkProtocol xs)
@@ -306,54 +286,31 @@ rewind k p =
         WrapChainDepState <$>
           rewindChainDepState (Proxy @(BlockProtocol blk)) k p st
 
-update :: forall xs. (CanHardFork xs, HasCallStack)
+update :: forall xs. CanHardFork xs
        => ConsensusConfig (HardForkProtocol xs)
        -> OneEraValidateView xs
        -> SlotNo
-       -> Ticked (HardForkLedgerView xs)
        -> Ticked (HardForkChainDepState xs)
        -> Except (HardForkValidationErr xs) (HardForkChainDepState xs)
 update HardForkConsensusConfig{..}
        (OneEraValidateView view)
        slot
-       (TickedHardForkLedgerView transition ledgerView)
-       (TickedHardForkChainDepState chainDepState) =
-    case State.match view ledgerView of
+       (TickedHardForkChainDepState chainDepState ei) =
+    case State.match view chainDepState of
       Left mismatch ->
         throwError $ HardForkValidationErrWrongEra . MismatchEraInfo $
           Match.bihcmap
             proxySingle
             singleEraInfo
-            (ledgerViewInfo . State.currentState)
+            (LedgerEraInfo . chainDepStateInfo . State.currentState)
             mismatch
       Right matched ->
            hsequence'
          . State.tickAllPast hardForkConsensusConfigK
          . hczipWith3 proxySingle (updateEra ei slot) cfgs errInjections
-         . (\case
-               Left mismatch ->
-                 -- This shouldn't happen: the 'LedgerView' and
-                 -- 'ChainDepState' were ticked together by 'applyChainTick'
-                 -- (on 'ExtLedgerState', containing both the 'ChainDepState'
-                 -- and the 'LedgerState' from which the 'LedgerView' was
-                 -- produced) and must thus be aligned.
-                 let mismatch' :: MismatchEraInfo xs
-                     mismatch' = MismatchEraInfo $
-                                   Match.bihcmap
-                                     proxySingle
-                                     (chainDepStateInfo . State.currentState)
-                                     (ledgerViewInfo . pairSnd)
-                                     (Match.flip mismatch)
-                 in error $ "update: unexpected mismatch: " ++ show mismatch'
-               Right match -> match)
-         . State.match (State.tip matched)
-         $ chainDepState
+         $ matched
   where
     cfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra
-    ei   = State.epochInfoPrecomputedTransitionInfo
-             hardForkConsensusConfigShape
-             transition
-             ledgerView
 
     errInjections :: NP (Injection WrapValidationErr xs) xs
     errInjections = injections
@@ -363,30 +320,22 @@ updateEra :: forall xs blk. SingleEraBlock blk
           -> SlotNo
           -> WrapPartialConsensusConfig blk
           -> Injection WrapValidationErr xs blk
-          -> Product (Product WrapValidateView
-                              (Ticked :.: WrapLedgerView))
-                     (Ticked :.: WrapChainDepState) blk
+          -> Product WrapValidateView (Ticked :.: WrapChainDepState) blk
           -> (Except (HardForkValidationErr xs) :.: WrapChainDepState) blk
 updateEra ei slot cfg injectErr
-          (Pair (Pair view (Comp ledgerView))
-                (Comp chainDepState)) = Comp $
+          (Pair view (Comp chainDepState)) = Comp $
     withExcept (injectValidationErr injectErr) $
       fmap WrapChainDepState $
         updateChainDepState
           (completeConsensusConfig' ei cfg)
           (unwrapValidateView view)
           slot
-          (unwrapTickedLedgerView ledgerView)
           (unwrapTickedChainDepState chainDepState)
 
 {-------------------------------------------------------------------------------
   Auxiliary
 -------------------------------------------------------------------------------}
 
-ledgerViewInfo :: forall blk. SingleEraBlock blk
-               => (Ticked :.: WrapLedgerView) blk -> LedgerEraInfo blk
-ledgerViewInfo _ = LedgerEraInfo $ singleEraInfo (Proxy @blk)
-
 chainDepStateInfo :: forall blk. SingleEraBlock blk
                   => (Ticked :.: WrapChainDepState) blk -> SingleEraInfo blk
 chainDepStateInfo _ = singleEraInfo (Proxy @blk)

ouroboros-consensus/src/Ouroboros/Consensus/HeaderValidation.hs

@@ -483,7 +483,6 @@ validateHeader cfg ledgerView hdr st = do
         (configConsensus cfg)
         (validateView (configBlock cfg) hdr)
         (blockSlot hdr)
-        ledgerView
         (tickedHeaderStateConsensus st)
     return $
       headerStatePush