consensus: HFC now provides EpochInfo in Except monad

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs

@@ -28,7 +28,7 @@ module Ouroboros.Consensus.Cardano.CanHardFork (
   ) where
 
 import           Control.Monad
-import           Control.Monad.Except (Except, runExcept, throwError)
+import           Control.Monad.Except (runExcept, throwError)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe (listToMaybe, mapMaybe)
 import           Data.Proxy

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

@@ -136,13 +136,17 @@ shelleyEraParamsNeverHardForks genesis = HardFork.EraParams {
 
 mkShelleyLedgerConfig
   :: SL.ShelleyGenesis era
-  -> EpochInfo Identity
+  -> EpochInfo (Except HardFork.PastHorizonException)
   -> MaxMajorProtVer
   -> ShelleyLedgerConfig era
 mkShelleyLedgerConfig genesis epochInfo (MaxMajorProtVer maxMajorPV) =
     ShelleyLedgerConfig {
         shelleyLedgerCompactGenesis = compactGenesis genesis
-      , shelleyLedgerGlobals        = SL.mkShelleyGlobals genesis epochInfo maxMajorPV
+      , shelleyLedgerGlobals        =
+          SL.mkShelleyGlobals
+            genesis
+            (HardFork.toPureEpochInfo epochInfo)
+            maxMajorPV
       }
 
 type instance LedgerCfg (LedgerState (ShelleyBlock era)) = ShelleyLedgerConfig era

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

@@ -40,8 +40,8 @@ module Ouroboros.Consensus.Shelley.Node (
   , validateGenesis
   ) where
 
+import           Control.Monad.Except (Except)
 import           Data.Bifunctor (first)
-import           Data.Functor.Identity (Identity)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import           Data.SOP.Strict
@@ -56,6 +56,7 @@ import           Cardano.Slotting.Time (mkSlotLength)
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.Config.SupportsNode
+import qualified Ouroboros.Consensus.HardFork.History as History
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.Extended
@@ -294,7 +295,7 @@ protocolInfoShelleyBased ProtocolParamsShelleyBased {
     ledgerConfig :: LedgerConfig (ShelleyBlock era)
     ledgerConfig = mkShelleyLedgerConfig genesis epochInfo maxMajorProtVer
 
-    epochInfo :: EpochInfo Identity
+    epochInfo :: EpochInfo (Except History.PastHorizonException)
     epochInfo =
         fixedEpochInfo
           (SL.sgEpochLength genesis)

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

@@ -42,10 +42,9 @@ module Ouroboros.Consensus.Shelley.Protocol (
 
 import qualified Codec.CBOR.Encoding as CBOR
 import           Codec.Serialise (Serialise (..))
-import           Control.Monad.Except (throwError)
+import           Control.Monad.Except (Except, throwError)
 import           Data.Coerce (coerce)
 import           Data.Function (on)
-import           Data.Functor.Identity (Identity)
 import qualified Data.Map.Strict as Map
 import           Data.Ord (Down (..))
 import           Data.Word (Word64)
@@ -59,6 +58,7 @@ import           Cardano.Slotting.EpochInfo
 import           Cardano.Slotting.Time (SystemStart (..))
 
 import           Ouroboros.Consensus.Block
+import qualified Ouroboros.Consensus.HardFork.History as History
 import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.Ticked
 import           Ouroboros.Consensus.Util.Condense
@@ -252,7 +252,7 @@ instance PraosCrypto c => NoThunks (TPraosIsLeader c)
 -- | Static configuration
 data instance ConsensusConfig (TPraos c) = TPraosConfig {
       tpraosParams    :: !TPraosParams
-    , tpraosEpochInfo :: !(EpochInfo Identity)
+    , tpraosEpochInfo :: !(EpochInfo (Except History.PastHorizonException))
 
       -- it's useful for this record to be EpochInfo and one other thing,
       -- because the one other thing can then be used as the
@@ -412,7 +412,10 @@ instance PraosCrypto c => ConsensusProtocol (TPraos c) where
       lv         = getTickedPraosLedgerView $ tickedTPraosStateLedgerView cs
       d          = SL.lvD lv
       asc        = tpraosLeaderF $ tpraosParams cfg
-      firstSlot  = firstSlotOfEpochOfSlot (tpraosEpochInfo cfg) slot
+      firstSlot  =
+          firstSlotOfEpochOfSlot
+            (History.toPureEpochInfo $ tpraosEpochInfo cfg)
+            slot
       gkeys      = Map.keysSet dlgMap
       eta0       = SL.ticknStateEpochNonce $ SL.csTickn chainState
       vkhCold    = SL.hashKey tpraosCanBeLeaderColdVerKey
@@ -436,7 +439,11 @@ instance PraosCrypto c => ConsensusProtocol (TPraos c) where
       st' = SL.tickChainDepState
               shelleyGlobals
               lv
-              (isNewEpoch tpraosEpochInfo lastSlot slot)
+              ( isNewEpoch
+                  (History.toPureEpochInfo tpraosEpochInfo)
+                  lastSlot
+                  slot
+              )
               st
       shelleyGlobals = mkShelleyGlobals cfg
 
@@ -464,7 +471,7 @@ instance PraosCrypto c => ConsensusProtocol (TPraos c) where
 
 mkShelleyGlobals :: ConsensusConfig (TPraos c) -> SL.Globals
 mkShelleyGlobals TPraosConfig{..} = SL.Globals {
-      epochInfo                     = tpraosEpochInfo
+      epochInfo                     = History.toPureEpochInfo tpraosEpochInfo
     , slotsPerKESPeriod             = tpraosSlotsPerKESPeriod
     , stabilityWindow               = SL.computeStabilityWindow               k tpraosLeaderF
     , randomnessStabilisationWindow = SL.computeRandomnessStabilisationWindow k tpraosLeaderF

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

@@ -23,7 +23,7 @@ module Ouroboros.Consensus.Shelley.ShelleyHFC (
   ) where
 
 import           Control.Monad (guard)
-import           Control.Monad.Except (Except, throwError)
+import           Control.Monad.Except (throwError)
 import qualified Data.Map.Strict as Map
 import           Data.Maybe
 import           Data.SOP.Strict
@@ -40,7 +40,8 @@ import           Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common
 import           Ouroboros.Consensus.HardFork.Combinator.State.Types
 import           Ouroboros.Consensus.HardFork.Combinator.Util.InPairs
                      (RequiringBoth (..), ignoringBoth)
-import           Ouroboros.Consensus.HardFork.History (Bound (boundSlot))
+import           Ouroboros.Consensus.HardFork.History (Bound (boundSlot),
+                     toPureEpochInfo)
 import           Ouroboros.Consensus.HardFork.Simple
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Node.NetworkProtocolVersion
@@ -198,7 +199,7 @@ instance ShelleyBasedEra era => HasPartialLedgerConfig (ShelleyBlock era) where
   completeLedgerConfig _ epochInfo (ShelleyPartialLedgerConfig cfg _) =
       cfg {
           shelleyLedgerGlobals = (shelleyLedgerGlobals cfg) {
-              SL.epochInfo = epochInfo
+              SL.epochInfo = toPureEpochInfo epochInfo
             }
         }
 

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

@@ -43,6 +43,7 @@ import           Control.Monad.Except
 import qualified Data.Binary as B
 import           Data.ByteString as Strict
 import qualified Data.ByteString.Lazy as Lazy
+import           Data.Functor.Identity (Identity)
 import           Data.Map (Map)
 import qualified Data.Map as Map
 import           Data.Set (Set)
@@ -244,7 +245,7 @@ instance HasPartialConsensusConfig ProtocolA
 instance HasPartialLedgerConfig BlockA where
   type PartialLedgerConfig BlockA = PartialLedgerConfigA
 
-  completeLedgerConfig _ = (,)
+  completeLedgerConfig _ ei pcfg = (History.toPureEpochInfo ei, pcfg)
 
 data TxPayloadA = InitiateAtoB
   deriving (Show, Eq, Generic, NoThunks, Serialise)

ouroboros-consensus-test/test-consensus/Test/Consensus/HardFork/History.hs

@@ -814,7 +814,7 @@ hardForkEpochInfo ArbitraryChain{..} for =
                                  tickedHardForkLedgerViewTransition
                                  tickedHardForkLedgerViewPerEra
            in (
-             HF.snapshotEpochInfo reconstructed
+             HF.toPureEpochInfo (HF.snapshotEpochInfo reconstructed)
            , show view
            , show reconstructed
            )

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

@@ -3,6 +3,8 @@ module Ouroboros.Consensus.HardFork.Combinator.Abstract.NoHardForks (
   , noHardForksEpochInfo
   ) where
 
+import           Data.Functor.Identity (runIdentity)
+
 import           Cardano.Slotting.EpochInfo
 
 import           Ouroboros.Consensus.Block
@@ -39,12 +41,14 @@ class SingleEraBlock blk => NoHardForks blk where
   toPartialLedgerConfig :: proxy blk
                         -> LedgerConfig blk -> PartialLedgerConfig blk
 
-noHardForksEpochInfo :: NoHardForks blk
-                     => TopLevelConfig blk -> EpochInfo Identity
+noHardForksEpochInfo :: (Monad m, NoHardForks blk)
+                     => TopLevelConfig blk
+                     -> EpochInfo m
 noHardForksEpochInfo cfg =
-    fixedEpochInfo
-      (History.eraEpochSize  params)
-      (History.eraSlotLength params)
+      hoistEpochInfo (pure . runIdentity)
+    $ fixedEpochInfo
+        (History.eraEpochSize  params)
+        (History.eraSlotLength params)
   where
     params :: EraParams
     params = getEraParams cfg

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

@@ -33,10 +33,9 @@ module Ouroboros.Consensus.HardFork.Combinator.Basics (
   , distribTopLevelConfig
     -- ** Convenience re-exports
   , EpochInfo
-  , Identity
+  , Except
   ) where
 
-import           Data.Functor.Identity
 import           Data.Kind (Type)
 import           Data.SOP.Strict
 import           Data.Typeable
@@ -152,7 +151,7 @@ type instance LedgerCfg (LedgerState (HardForkBlock xs)) = HardForkLedgerConfig
 
 completeLedgerConfig' :: forall blk.
                          HasPartialLedgerConfig blk
-                      => EpochInfo Identity
+                      => EpochInfo (Except PastHorizonException)
                       -> WrapPartialLedgerConfig blk
                       -> LedgerConfig blk
 completeLedgerConfig' ei =
@@ -161,7 +160,7 @@ completeLedgerConfig' ei =
 
 completeLedgerConfig'' :: forall blk.
                           HasPartialLedgerConfig blk
-                       => EpochInfo Identity
+                       => EpochInfo (Except PastHorizonException)
                        -> WrapPartialLedgerConfig blk
                        -> WrapLedgerConfig blk
 completeLedgerConfig'' ei =
@@ -171,7 +170,7 @@ completeLedgerConfig'' ei =
 
 completeConsensusConfig' :: forall blk.
                             HasPartialConsensusConfig (BlockProtocol blk)
-                         => EpochInfo Identity
+                         => EpochInfo (Except PastHorizonException)
                          -> WrapPartialConsensusConfig blk
                          -> ConsensusConfig (BlockProtocol blk)
 completeConsensusConfig' ei =
@@ -180,7 +179,7 @@ completeConsensusConfig' ei =
 
 completeConsensusConfig'' :: forall blk.
                              HasPartialConsensusConfig (BlockProtocol blk)
-                          => EpochInfo Identity
+                          => EpochInfo (Except PastHorizonException)
                           -> WrapPartialConsensusConfig blk
                           -> WrapConsensusConfig blk
 completeConsensusConfig'' ei =
@@ -190,7 +189,7 @@ completeConsensusConfig'' ei =
 
 distribLedgerConfig ::
      CanHardFork xs
-  => EpochInfo Identity
+  => EpochInfo (Except PastHorizonException)
   -> LedgerConfig (HardForkBlock xs)
   -> NP WrapLedgerConfig xs
 distribLedgerConfig ei cfg =
@@ -200,7 +199,7 @@ distribLedgerConfig ei cfg =
       (getPerEraLedgerConfig $ hardForkLedgerConfigPerEra cfg)
 
 distribTopLevelConfig :: All SingleEraBlock xs
-                      => EpochInfo Identity
+                      => EpochInfo (Except PastHorizonException)
                       -> TopLevelConfig (HardForkBlock xs)
                       -> NP TopLevelConfig xs
 distribTopLevelConfig ei tlc =

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs

@@ -267,7 +267,7 @@ instance Isomorphic TopLevelConfig where
         (project      $ configCodec     tlc)
         (project      $ configStorage   tlc)
     where
-      ei :: EpochInfo Identity
+      ei :: EpochInfo (Except PastHorizonException)
       ei = noHardForksEpochInfo $ project tlc
 
       auxLedger :: LedgerConfig (HardForkBlock '[blk]) -> LedgerConfig blk
@@ -448,7 +448,7 @@ instance Functor m => Isomorphic (BlockForging m) where
       }
     where
       injTickedChainDepSt ::
-           EpochInfo Identity
+           EpochInfo (Except PastHorizonException)
         -> Ticked (ChainDepState (BlockProtocol blk))
         -> Ticked (ChainDepState (HardForkProtocol '[blk]))
       injTickedChainDepSt ei =

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

@@ -151,7 +151,7 @@ instance CanHardFork xs => IsLedger (LedgerState (HardForkBlock xs)) where
       extended = State.extendToSlot cfg slot st
 
 tickOne :: forall blk. SingleEraBlock blk
-        => EpochInfo Identity
+        => EpochInfo (Except PastHorizonException)
         -> SlotNo
         -> WrapPartialLedgerConfig  blk
         -> LedgerState              blk
@@ -261,7 +261,7 @@ instance CanHardFork xs => ValidateEnvelope (HardForkBlock xs) where
         Right matched ->
           hcollapse $ hcizipWith proxySingle aux cfgs matched
     where
-      ei :: EpochInfo Identity
+      ei :: EpochInfo (Except PastHorizonException)
       ei = State.epochInfoPrecomputedTransitionInfo
              (hardForkLedgerConfigShape $ configLedger tlc)
              transition

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

@@ -13,16 +13,18 @@ module Ouroboros.Consensus.HardFork.Combinator.PartialConfig (
   , WrapPartialLedgerConfig (..)
     -- * Convenience re-exports
   , EpochInfo (..)
-  , Identity (..)
+  , Except
+  , PastHorizonException
   ) where
 
-import           Data.Functor.Identity
+import           Control.Monad.Except (Except)
 import           Data.Kind (Type)
 import           NoThunks.Class (NoThunks)
 
 import           Cardano.Slotting.EpochInfo
 
 import           Ouroboros.Consensus.Block
+import           Ouroboros.Consensus.HardFork.History.Qry (PastHorizonException)
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Protocol.Abstract
 
@@ -38,12 +40,12 @@ class ( ConsensusProtocol p
   -- See comments for 'completeLedgerConfig' for some details about the
   -- 'EpochInfo'.
   completeConsensusConfig :: proxy p
-                          -> EpochInfo Identity
+                          -> EpochInfo (Except PastHorizonException)
                           -> PartialConsensusConfig p -> ConsensusConfig p
 
   default completeConsensusConfig :: (PartialConsensusConfig p ~ ConsensusConfig p)
                                   => proxy p
-                                  -> EpochInfo Identity
+                                  -> EpochInfo (Except PastHorizonException)
                                   -> PartialConsensusConfig p -> ConsensusConfig p
   completeConsensusConfig _ _ = id
 
@@ -61,14 +63,12 @@ class ( UpdateLedger blk
   -- The horizon is determined by the tip of the ledger /state/ (not view)
   -- from which the 'EpochInfo' is derived.
   --
-  -- TODO: This should not be Identity;
-  -- see <https://github.com/input-output-hk/ouroboros-network/issues/2126>
   completeLedgerConfig :: proxy blk
-                       -> EpochInfo Identity
+                       -> EpochInfo (Except PastHorizonException)
                        -> PartialLedgerConfig blk  -> LedgerConfig blk
   default completeLedgerConfig :: (PartialLedgerConfig blk ~ LedgerConfig blk)
                                => proxy blk
-                               -> EpochInfo Identity
+                               -> EpochInfo (Except PastHorizonException)
                                -> PartialLedgerConfig blk  -> LedgerConfig blk
   completeLedgerConfig _ _ = id
 

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

@@ -141,7 +141,8 @@ data instance Ticked (HardForkChainDepState xs) =
              HardForkState (Ticked :.: WrapChainDepState) xs
 
         -- | 'EpochInfo' constructed from the ticked 'LedgerView'
-      , tickedHardForkChainDepStateEpochInfo :: EpochInfo Identity
+      , tickedHardForkChainDepStateEpochInfo ::
+             EpochInfo (Except PastHorizonException)
       }
 
 tick :: CanHardFork xs
@@ -281,7 +282,7 @@ update HardForkConsensusConfig{..}
     cfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra
 
 updateEra :: forall xs blk. SingleEraBlock blk
-          => EpochInfo Identity
+          => EpochInfo (Except PastHorizonException)
           -> SlotNo
           -> Index xs blk
           -> WrapPartialConsensusConfig blk
@@ -322,7 +323,7 @@ reupdate HardForkConsensusConfig{..}
     cfgs = getPerEraConsensusConfig hardForkConsensusConfigPerEra
 
 reupdateEra :: SingleEraBlock blk
-            => EpochInfo Identity
+            => EpochInfo (Except PastHorizonException)
             -> SlotNo
             -> WrapPartialConsensusConfig blk
             -> Product WrapValidateView (Ticked :.: WrapChainDepState) blk
@@ -344,7 +345,7 @@ chainDepStateInfo :: forall blk. SingleEraBlock blk
 chainDepStateInfo _ = singleEraInfo (Proxy @blk)
 
 translateConsensus :: forall xs. CanHardFork xs
-                   => EpochInfo Identity
+                   => EpochInfo (Except PastHorizonException)
                    -> ConsensusConfig (HardForkProtocol xs)
                    -> InPairs (Translate WrapChainDepState) xs
 translateConsensus ei HardForkConsensusConfig{..} =