diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs index 83ca7d2042..52e6ab3dd1 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Node.hs +++ b/ouroboros-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/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs index b152dbf060..285208c808 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Basics.hs +++ b/ouroboros-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/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs index 67c0c81905..90475e4048 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Binary.hs +++ b/ouroboros-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/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs index da145377c2..8605101dca 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs +++ b/ouroboros-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 index 371b005b43..cd453cd66b 100644 --- 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 index af7ea1f510..43c704ba77 100644 --- 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 index a0de07672c..5cd670f3d1 100644 --- 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 index b9e597dd8c..762c04cbdf 100644 --- 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