WIP3

IntersectMBO · Feb 11, 2025 · fa8ff29 · fa8ff29
1 parent d4557e7
commit fa8ff29
Show file tree

Hide file tree

Showing 8 changed files with 51 additions and 16 deletions.
diff --git a/...ros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/...ros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs
@@ -68,12 +68,13 @@ import           Data.Functor.These (These1 (..))
 import qualified Data.Map.Strict as Map
 import           Data.SOP.BasicFunctors
 import           Data.SOP.Counting
-import           Data.SOP.Index (Index (..))
+import           Data.SOP.Index (Index (..), projectNP)
 import           Data.SOP.OptNP (NonEmptyOptNP, OptNP (OptSkip))
 import qualified Data.SOP.OptNP as OptNP
 import           Data.SOP.Strict
 import           Data.Word (Word16, Word64)
 import           Lens.Micro ((^.))
+import           Ouroboros.Consensus.HardFork.Combinator.AcrossEras
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Byron.Ledger (ByronBlock)
 import qualified Ouroboros.Consensus.Byron.Ledger as Byron
@@ -89,6 +90,7 @@ import           Ouroboros.Consensus.HardFork.Combinator.Serialisation
 import qualified Ouroboros.Consensus.HardFork.History as History
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Ledger.Extended
+import           Ouroboros.Consensus.Ledger.Basics
 import           Ouroboros.Consensus.Node.NetworkProtocolVersion
 import           Ouroboros.Consensus.Node.ProtocolInfo
 import           Ouroboros.Consensus.Node.Run
@@ -451,6 +453,7 @@ data CardanoProtocolParams c = CardanoProtocolParams {
     -- /intra-era hard fork/ (ie conditionals in the ledger rules).
     --
   , cardanoProtocolVersion        :: ProtVer
+  , cardanoSTS                    :: STSOptions (LedgerState (CardanoBlock c))
   }
 
 -- | Create a 'ProtocolInfo' for 'CardanoBlock'
@@ -497,6 +500,7 @@ protocolInfoCardano paramsCardano
       , cardanoLedgerTransitionConfig
       , cardanoCheckpoints
       , cardanoProtocolVersion
+      , cardanoSTS = sts
       } = paramsCardano
 
     genesisShelley = cardanoLedgerTransitionConfig ^. L.tcShelleyGenesisL
@@ -532,7 +536,7 @@ protocolInfoCardano paramsCardano
           , topLevelConfigBlock    = blockConfigByron
           }
       , pInfoInitLedger = initExtLedgerStateByron
-      } = protocolInfoByron byronProtocolParams undefined
+      } = protocolInfoByron byronProtocolParams $ unwrapSTSOptions $ projectNP IZ $ getPerEraSTSOptions sts
 
     partialConsensusConfigByron :: PartialConsensusConfig (BlockProtocol ByronBlock)
     partialConsensusConfigByron = consensusConfigByron
@@ -772,7 +776,7 @@ protocolInfoCardano paramsCardano
             (Shelley.ShelleyStorageConfig tpraosSlotsPerKESPeriod k)
             (Shelley.ShelleyStorageConfig tpraosSlotsPerKESPeriod k)
       , topLevelConfigCheckpoints = cardanoCheckpoints
-      , topLevelConfigSTS = undefined
+      , topLevelConfigSTS = sts
       }
 
     -- When the initial ledger state is not in the Byron era, register various

diff --git a/...boros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/...boros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -192,13 +193,14 @@ distribLedgerConfig ei cfg =
       (completeLedgerConfig'' ei)
       (getPerEraLedgerConfig $ hardForkLedgerConfigPerEra cfg)
 
-distribTopLevelConfig :: All SingleEraBlock xs
+distribTopLevelConfig :: (STSOptions (LedgerState (HardForkBlock xs))
+                        ~ PerEraSTSOptions xs, All SingleEraBlock xs)
                       => EpochInfo (Except PastHorizonException)
                       -> TopLevelConfig (HardForkBlock xs)
                       -> NP TopLevelConfig xs
 distribTopLevelConfig ei tlc =
     hcpure proxySingle
-      (fn_5 (\cfgConsensus cfgLedger cfgBlock cfgCodec cfgStorage ->
+      (fn_6 (\cfgConsensus cfgLedger cfgBlock cfgCodec cfgStorage sts ->
            mkTopLevelConfig
              (completeConsensusConfig' ei cfgConsensus)
              (completeLedgerConfig'    ei cfgLedger)
@@ -210,7 +212,7 @@ distribTopLevelConfig ei tlc =
              --
              -- The checkpoints of the underlying blocks are not used.
              emptyCheckpointsMap
-             undefined
+             (unwrapSTSOptions sts)
             ))
     `hap`
       (getPerEraConsensusConfig $
@@ -227,3 +229,5 @@ distribTopLevelConfig ei tlc =
     `hap`
       (getPerEraStorageConfig $
          hardForkStorageConfigPerEra (configStorage tlc))
+    `hap`
+      (getPerEraSTSOptions $ topLevelConfigSTS tlc)
diff --git a/...consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs b/...consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs
@@ -17,7 +17,7 @@ import           Ouroboros.Consensus.Config
 import           Ouroboros.Consensus.HardFork.Combinator
 import qualified Ouroboros.Consensus.HardFork.History as History
 import           Ouroboros.Consensus.HeaderValidation
-import           Ouroboros.Consensus.Ledger.Basics (LedgerConfig)
+import           Ouroboros.Consensus.Ledger.Basics (LedgerConfig, STSOptions)
 import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Node.ProtocolInfo
 import           Ouroboros.Consensus.Protocol.Abstract (protocolSecurityParam)
@@ -42,11 +42,14 @@ protocolInfoBinary ::
   -> History.EraParams
   -> (ConsensusConfig (BlockProtocol blk2) -> PartialConsensusConfig (BlockProtocol blk2))
   -> (LedgerConfig blk2 -> PartialLedgerConfig blk2)
+  -> STSOptions (LedgerState (HardForkBlock '[blk1, blk2]))
   -> ( ProtocolInfo (HardForkBlock '[blk1, blk2])
      , m [BlockForging m (HardForkBlock '[blk1, blk2])]
      )
 protocolInfoBinary protocolInfo1 blockForging1 eraParams1 toPartialConsensusConfig1 toPartialLedgerConfig1
-                   protocolInfo2 blockForging2 eraParams2 toPartialConsensusConfig2 toPartialLedgerConfig2 =
+                   protocolInfo2 blockForging2 eraParams2 toPartialConsensusConfig2 toPartialLedgerConfig2
+                   sts
+   =
     ( ProtocolInfo {
         pInfoConfig = TopLevelConfig {
             topLevelConfigProtocol = HardForkConsensusConfig {
@@ -79,7 +82,7 @@ protocolInfoBinary protocolInfo1 blockForging1 eraParams1 toPartialConsensusConf
                 PerEraStorageConfig $
                   (storageConfig1 :* storageConfig2 :* Nil)
           , topLevelConfigCheckpoints = emptyCheckpointsMap
-          , topLevelConfigSTS         = undefined
+          , topLevelConfigSTS         = sts
           }
       , pInfoInitLedger = ExtLedgerState {
             ledgerState =

diff --git a/...-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs b/...-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs
@@ -265,11 +265,18 @@ instance Isomorphic TopLevelConfig where
         (project      $ configCodec     tlc)
         (project      $ configStorage   tlc)
         emptyCheckpointsMap
-        undefined
+        (auxSTS       $ topLevelConfigSTS tlc)
     where
       ei :: EpochInfo (Except PastHorizonException)
       ei = noHardForksEpochInfo $ project tlc
 
+      auxSTS :: STSOptions (LedgerState (HardForkBlock '[blk])) ->
+                STSOptions (LedgerState blk)
+      auxSTS =
+            unwrapSTSOptions
+          . hd
+          . getPerEraSTSOptions
+
       auxLedger :: LedgerConfig (HardForkBlock '[blk]) -> LedgerConfig blk
       auxLedger =
             completeLedgerConfig (Proxy @blk) ei
@@ -297,10 +304,15 @@ instance Isomorphic TopLevelConfig where
         (inject       $ configCodec     tlc)
         (inject       $ configStorage   tlc)
         emptyCheckpointsMap
-        undefined
+        (auxSTS       $ topLevelConfigSTS tlc)
     where
       eraParams = getEraParams tlc
 
+      auxSTS :: STSOptions (LedgerState blk) ->
+                STSOptions (LedgerState (HardForkBlock '[blk]))
+      auxSTS =
+        PerEraSTSOptions . (:* Nil) . WrapSTSOptions
+
       auxLedger :: LedgerConfig blk -> LedgerConfig (HardForkBlock '[blk])
       auxLedger cfg = HardForkLedgerConfig {
             hardForkLedgerConfigShape  = History.singletonShape eraParams

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Dual.hs
@@ -415,7 +415,7 @@ instance Bridge m a => ApplyBlock (LedgerState (DualBlock m a)) (DualBlock m a)
                                     tickedDualLedgerStateBridge
         }
 
-  reapplyResult = undefined
+  reapplyResult = error "Unimplemented as not needed"
 
   reapplyBlockLedgerResult cfg
                            block@DualBlock{..}

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Extended.hs
@@ -167,7 +167,7 @@ instance LedgerSupportsProtocol blk => ApplyBlock (ExtLedgerState blk) blk where
           tickedHeaderState
     pure $ (\l -> ExtLedgerState l hdr) <$> castLedgerResult ledgerResult
 
-  reapplyResult = undefined
+  reapplyResult = error "Unimplemented as not needed"
 
   reapplyBlockLedgerResult cfg blk TickedExtLedgerState{..} =
       (\l -> ExtLedgerState l hdr) <$> castLedgerResult ledgerResult

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/SupportsProtocol.hs
@@ -74,16 +74,17 @@ _lemma_ledgerViewForecastAt_applyChainTick
   :: ( LedgerSupportsProtocol blk
      , Eq (LedgerView (BlockProtocol blk))
      )
-  => LedgerConfig blk
+  => STSOptions (LedgerState blk)
+  -> LedgerConfig blk
   -> LedgerState blk
   -> Forecast (LedgerView (BlockProtocol blk))
   -> SlotNo
   -> Either String ()
-_lemma_ledgerViewForecastAt_applyChainTick cfg st forecast for
+_lemma_ledgerViewForecastAt_applyChainTick sts cfg st forecast for
     | NotOrigin for >= ledgerTipSlot st
     , let lhs = forecastFor forecast for
           rhs = protocolLedgerView cfg
-              . applyChainTick undefined cfg for
+              . applyChainTick sts cfg for
               $ st
     , Right lhs' <- runExcept lhs
     , lhs' /= rhs

diff --git a/strict-sop-core/src/Data/SOP/Strict.hs b/strict-sop-core/src/Data/SOP/Strict.hs
@@ -7,6 +7,7 @@ module Data.SOP.Strict (
   , module Data.SOP.Strict.NS
     -- * fn
   , fn_5
+  , fn_6
     -- * Reexports
   , module Data.SOP.Classes
   ) where
@@ -27,3 +28,13 @@ fn_5 f = Fn $ \x0 ->
          Fn $ \x3 ->
          Fn $ \x4 ->
          f x0 x1 x2 x3 x4
+
+fn_6 :: (f0 a -> f1 a -> f2 a -> f3 a -> f4 a -> f5 a -> f6 a)
+     -> (f0 -.-> f1 -.-> f2 -.-> f3 -.-> f4 -.-> f5 -.-> f6) a
+fn_6 f = Fn $ \x0 ->
+         Fn $ \x1 ->
+         Fn $ \x2 ->
+         Fn $ \x3 ->
+         Fn $ \x4 ->
+         Fn $ \x5 ->
+         f x0 x1 x2 x3 x4 x5