diff --git a/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Generators.hs b/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Generators.hs index a9f6027c98d..5cdd0296cf7 100644 --- a/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Generators.hs +++ b/ouroboros-consensus-shelley-test/src/Test/Consensus/Shelley/Generators.hs @@ -182,7 +182,7 @@ instance CanMock proto era=> Arbitrary (ShelleyTip proto era) where instance Arbitrary ShelleyTransition where arbitrary = ShelleyTransitionInfo <$> arbitrary -instance CanMock proto era => Arbitrary (LedgerState (ShelleyBlock proto era)) where +instance CanMock proto era => Arbitrary (LedgerState (ShelleyBlock proto era) Canonical) where arbitrary = ShelleyLedgerState <$> arbitrary <*> arbitrary diff --git a/ouroboros-consensus-shelley-test/src/Test/ThreadNet/TxGen/Shelley.hs b/ouroboros-consensus-shelley-test/src/Test/ThreadNet/TxGen/Shelley.hs index f8d3aa64a9a..50d7714c88c 100644 --- a/ouroboros-consensus-shelley-test/src/Test/ThreadNet/TxGen/Shelley.hs +++ b/ouroboros-consensus-shelley-test/src/Test/ThreadNet/TxGen/Shelley.hs @@ -80,7 +80,7 @@ instance HashAlgorithm h => TxGen (ShelleyBlock (TPraos (MockCrypto h)) (MockShe go :: [GenTx (ShelleyBlock (TPraos (MockCrypto h)) (MockShelley h))] -- ^ Accumulator -> Integer -- ^ Number of txs to still produce - -> TickedLedgerState (ShelleyBlock (TPraos (MockCrypto h)) (MockShelley h)) + -> TickedLedgerState (ShelleyBlock (TPraos (MockCrypto h)) (MockShelley h)) Canonical -> Gen [GenTx (ShelleyBlock (TPraos (MockCrypto h)) (MockShelley h))] go acc 0 _ = return (reverse acc) go acc n st = do @@ -96,7 +96,7 @@ genTx :: forall h. HashAlgorithm h => TopLevelConfig (ShelleyBlock (TPraos (MockCrypto h)) (MockShelley h)) -> SlotNo - -> TickedLedgerState (ShelleyBlock (TPraos (MockCrypto h)) (MockShelley h)) + -> TickedLedgerState (ShelleyBlock (TPraos (MockCrypto h)) (MockShelley h)) Canonical -> Gen.GenEnv (MockShelley h) -> Gen (Maybe (GenTx (ShelleyBlock (TPraos (MockCrypto h)) (MockShelley h)))) genTx _cfg slotNo TickedShelleyLedgerState { tickedShelleyLedgerState } genEnv = diff --git a/ouroboros-consensus-shelley-test/test/Test/ThreadNet/Shelley.hs b/ouroboros-consensus-shelley-test/test/Test/ThreadNet/Shelley.hs index c245f1c428b..56b06478595 100644 --- a/ouroboros-consensus-shelley-test/test/Test/ThreadNet/Shelley.hs +++ b/ouroboros-consensus-shelley-test/test/Test/ThreadNet/Shelley.hs @@ -362,7 +362,7 @@ prop_simple_real_tpraos_convergence TestSetup DoGeneratePPUs -> True DoNotGeneratePPUs -> False - finalLedgers :: [(NodeId, LedgerState (ShelleyBlock Proto Era))] + finalLedgers :: [(NodeId, LedgerState (ShelleyBlock Proto Era) Canonical)] finalLedgers = Map.toList $ nodeOutputFinalLedger <$> testOutputNodes testOutput diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Forge.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Forge.hs index a56f18c656e..6a33980ab40 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Forge.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Forge.hs @@ -48,12 +48,12 @@ forgeShelleyBlock :: => HotKey (EraCrypto era) m -> CanBeLeader proto -> TopLevelConfig (ShelleyBlock proto era) - -> TxLimits.Overrides (ShelleyBlock proto era) -- ^ How to override max tx - -- capacity defined by ledger - -> BlockNo -- ^ Current block number - -> SlotNo -- ^ Current slot number - -> TickedLedgerState (ShelleyBlock proto era) -- ^ Current ledger - -> [Validated (GenTx (ShelleyBlock proto era))] -- ^ Txs to add in the block + -> TxLimits.Overrides (ShelleyBlock proto era) -- ^ How to override max tx + -- capacity defined by ledger + -> BlockNo -- ^ Current block number + -> SlotNo -- ^ Current slot number + -> TickedLedgerState (ShelleyBlock proto era) Canonical -- ^ Current ledger + -> [Validated (GenTx (ShelleyBlock proto era))] -- ^ Txs to add in the block -> IsLeader proto -> m (ShelleyBlock proto era) forgeShelleyBlock diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Inspect.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Inspect.hs index b7ae8117678..5a437b4dc7b 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Inspect.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Inspect.hs @@ -106,7 +106,7 @@ data UpdateState c = UpdateState { protocolUpdates :: forall era proto. ShelleyBasedEra era => SL.ShelleyGenesis era - -> LedgerState (ShelleyBlock proto era) + -> LedgerState (ShelleyBlock proto era) Canonical -> [ProtocolUpdate era] protocolUpdates genesis st = [ ProtocolUpdate { diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs index f7797d4d6e5..27e885cbc22 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Ledger.hs @@ -24,6 +24,7 @@ module Ouroboros.Consensus.Shelley.Ledger.Ledger ( , ShelleyTip (..) , ShelleyTransition (..) , Ticked (..) + , Ticked1 (..) , castShelleyTip , shelleyLedgerTipPoint , shelleyTipToPoint @@ -74,7 +75,7 @@ import Ouroboros.Consensus.HardFork.History.Util import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.CommonProtocolParams -import Ouroboros.Consensus.Ledger.Extended +import Ouroboros.Consensus.Ticked import Ouroboros.Consensus.Util ((..:)) import Ouroboros.Consensus.Util.CBOR (decodeWithOrigin, encodeWithOrigin) @@ -192,16 +193,16 @@ castShelleyTip (ShelleyTip sn bn hh) = ShelleyTip { , shelleyTipHash = coerce hh } -data instance LedgerState (ShelleyBlock proto era) = ShelleyLedgerState { +data instance LedgerState (ShelleyBlock proto era) mk = ShelleyLedgerState { shelleyLedgerTip :: !(WithOrigin (ShelleyTip proto era)) , shelleyLedgerState :: !(SL.NewEpochState era) , shelleyLedgerTransition :: !ShelleyTransition } deriving (Generic) -deriving instance ShelleyBasedEra era => Show (LedgerState (ShelleyBlock proto era)) -deriving instance ShelleyBasedEra era => Eq (LedgerState (ShelleyBlock proto era)) -deriving instance ShelleyBasedEra era => NoThunks (LedgerState (ShelleyBlock proto era)) +deriving instance ShelleyBasedEra era => Show (LedgerState (ShelleyBlock proto era) mk) +deriving instance ShelleyBasedEra era => Eq (LedgerState (ShelleyBlock proto era) mk) +deriving instance ShelleyBasedEra era => NoThunks (LedgerState (ShelleyBlock proto era) mk) -- | Information required to determine the hard fork point from Shelley to the -- next ledger @@ -227,7 +228,7 @@ newtype ShelleyTransition = ShelleyTransitionInfo { deriving stock (Eq, Show, Generic) deriving newtype (NoThunks) -shelleyLedgerTipPoint :: LedgerState (ShelleyBlock proto era) -> Point (ShelleyBlock proto era) +shelleyLedgerTipPoint :: LedgerState (ShelleyBlock proto era) mk -> Point (ShelleyBlock proto era) shelleyLedgerTipPoint = shelleyTipToPoint . shelleyLedgerTip instance ShelleyCompatible proto era => UpdateLedger (ShelleyBlock proto era) @@ -236,18 +237,18 @@ instance ShelleyCompatible proto era => UpdateLedger (ShelleyBlock proto era) GetTip -------------------------------------------------------------------------------} -instance GetTip (LedgerState (ShelleyBlock proto era)) where +instance GetTip (LedgerState (ShelleyBlock proto era) mk) where getTip = castPoint . shelleyLedgerTipPoint -instance GetTip (Ticked (LedgerState (ShelleyBlock proto era))) where - getTip = castPoint . untickedShelleyLedgerTipPoint +instance GetTip (Ticked1 (LedgerState (ShelleyBlock proto era)) mk) where + getTip = castPoint . shelleyTipToPoint . untickedShelleyLedgerTip {------------------------------------------------------------------------------- Ticking -------------------------------------------------------------------------------} -- | Ticking only affects the state itself -data instance Ticked (LedgerState (ShelleyBlock proto era)) = TickedShelleyLedgerState { +data instance Ticked1 (LedgerState (ShelleyBlock proto era)) mk = TickedShelleyLedgerState { untickedShelleyLedgerTip :: !(WithOrigin (ShelleyTip proto era)) -- | We are counting blocks within an epoch, this means: -- @@ -260,12 +261,7 @@ data instance Ticked (LedgerState (ShelleyBlock proto era)) = TickedShelleyLedge deriving (Generic) deriving instance ShelleyBasedEra era - => NoThunks (Ticked (LedgerState (ShelleyBlock proto era))) - -untickedShelleyLedgerTipPoint :: - Ticked (LedgerState (ShelleyBlock proto era)) - -> Point (ShelleyBlock proto era) -untickedShelleyLedgerTipPoint = shelleyTipToPoint . untickedShelleyLedgerTip + => NoThunks (Ticked1 (LedgerState (ShelleyBlock proto era)) mk) instance ShelleyBasedEra era => IsLedger (LedgerState (ShelleyBlock proto era)) where type LedgerErr (LedgerState (ShelleyBlock proto era)) = ShelleyLedgerError era @@ -392,10 +388,10 @@ applyHelper :: ) -> LedgerConfig (ShelleyBlock proto era) -> ShelleyBlock proto era - -> Ticked (LedgerState (ShelleyBlock proto era)) + -> Ticked1 (LedgerState (ShelleyBlock proto era)) mk -> m (LedgerResult (LedgerState (ShelleyBlock proto era)) - (LedgerState (ShelleyBlock proto era))) + (LedgerState (ShelleyBlock proto era) mk)) applyHelper f cfg blk TickedShelleyLedgerState{ tickedShelleyLedgerTransition , tickedShelleyLedgerState @@ -549,7 +545,7 @@ decodeShelleyTransition = do encodeShelleyLedgerState :: ShelleyCompatible proto era - => LedgerState (ShelleyBlock proto era) + => LedgerState (ShelleyBlock proto era) mk -> Encoding encodeShelleyLedgerState ShelleyLedgerState { shelleyLedgerTip @@ -564,13 +560,13 @@ encodeShelleyLedgerState ] decodeShelleyLedgerState :: - forall era proto s. ShelleyCompatible proto era - => Decoder s (LedgerState (ShelleyBlock proto era)) + forall era proto s mk. ShelleyCompatible proto era + => Decoder s (LedgerState (ShelleyBlock proto era) mk) decodeShelleyLedgerState = decodeVersion [ (serialisationFormatVersion2, Decode decodeShelleyLedgerState2) ] where - decodeShelleyLedgerState2 :: Decoder s' (LedgerState (ShelleyBlock proto era)) + decodeShelleyLedgerState2 :: Decoder s' (LedgerState (ShelleyBlock proto era) mk) decodeShelleyLedgerState2 = do enforceSize "LedgerState ShelleyBlock" 3 shelleyLedgerTip <- decodeWithOrigin decodeShelleyTip diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs index 794db55aa27..1badc4ee297 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/Mempool.hs @@ -73,7 +73,7 @@ import Ouroboros.Consensus.Shelley.Eras import Ouroboros.Consensus.Shelley.Ledger.Block import Ouroboros.Consensus.Shelley.Ledger.Ledger (ShelleyLedgerConfig (shelleyLedgerGlobals), - Ticked (TickedShelleyLedgerState, tickedShelleyLedgerState), + Ticked1 (TickedShelleyLedgerState, tickedShelleyLedgerState), getPParams) data instance GenTx (ShelleyBlock proto era) = ShelleyTx !(SL.TxId (EraCrypto era)) !(Tx era) @@ -224,9 +224,9 @@ applyShelleyTx :: forall era proto. -> WhetherToIntervene -> SlotNo -> GenTx (ShelleyBlock proto era) - -> TickedLedgerState (ShelleyBlock proto era) + -> TickedLedgerState (ShelleyBlock proto era) Canonical -> Except (ApplyTxErr (ShelleyBlock proto era)) - ( TickedLedgerState (ShelleyBlock proto era) + ( TickedLedgerState (ShelleyBlock proto era) Canonical , Validated (GenTx (ShelleyBlock proto era)) ) applyShelleyTx cfg wti slot (ShelleyTx _ tx) st = do @@ -249,8 +249,8 @@ reapplyShelleyTx :: => LedgerConfig (ShelleyBlock proto era) -> SlotNo -> Validated (GenTx (ShelleyBlock proto era)) - -> TickedLedgerState (ShelleyBlock proto era) - -> Except (ApplyTxErr (ShelleyBlock proto era)) (TickedLedgerState (ShelleyBlock proto era)) + -> TickedLedgerState (ShelleyBlock proto era) Canonical + -> Except (ApplyTxErr (ShelleyBlock proto era)) (TickedLedgerState (ShelleyBlock proto era) Canonical) reapplyShelleyTx cfg slot vgtx st = do mempoolState' <- SL.reapplyTx @@ -275,8 +275,8 @@ set lens inner outer = theLedgerLens :: Functor f => (SL.LedgerState era -> f (SL.LedgerState era)) - -> TickedLedgerState (ShelleyBlock proto era) - -> f (TickedLedgerState (ShelleyBlock proto era)) + -> TickedLedgerState (ShelleyBlock proto era) Canonical + -> f (TickedLedgerState (ShelleyBlock proto era) Canonical) theLedgerLens f x = (\y -> x{tickedShelleyLedgerState = y}) <$> SL.overNewEpochState f (tickedShelleyLedgerState x) diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs index 100f3e29d22..18554b360e7 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Ledger/SupportsProtocol.hs @@ -113,7 +113,7 @@ instance mapForecast (translateTickedLedgerView @(TPraos crypto) @(Praos crypto)) $ ledgerViewForecastAt @(ShelleyBlock (TPraos crypto) era) cfg st' where - st' :: LedgerState (ShelleyBlock (TPraos crypto) era) + st' :: LedgerState (ShelleyBlock (TPraos crypto) era) Canonical st' = ShelleyLedgerState { shelleyLedgerTip = coerceTip <$> shelleyLedgerTip st, diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs index 0a727be3346..6c577563ca5 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/Serialisation.hs @@ -17,6 +17,7 @@ import Ouroboros.Network.Block (Serialised, unwrapCBORinCBOR, import Ouroboros.Consensus.Block import Ouroboros.Consensus.HeaderValidation +import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.SupportsMempool (GenTxId) import Ouroboros.Consensus.Node.Run import Ouroboros.Consensus.Node.Serialisation @@ -53,9 +54,9 @@ instance ShelleyCompatible proto era => EncodeDisk (ShelleyBlock proto era) (Hea instance ShelleyCompatible proto era => DecodeDisk (ShelleyBlock proto era) (Lazy.ByteString -> Header (ShelleyBlock proto era)) where decodeDisk _ = decodeShelleyHeader -instance ShelleyCompatible proto era => EncodeDisk (ShelleyBlock proto era) (LedgerState (ShelleyBlock proto era)) where +instance ShelleyCompatible proto era => EncodeDisk (ShelleyBlock proto era) (LedgerState (ShelleyBlock proto era) Canonical) where encodeDisk _ = encodeShelleyLedgerState -instance ShelleyCompatible proto era => DecodeDisk (ShelleyBlock proto era) (LedgerState (ShelleyBlock proto era)) where +instance ShelleyCompatible proto era => DecodeDisk (ShelleyBlock proto era) (LedgerState (ShelleyBlock proto era) Canonical) where decodeDisk _ = decodeShelleyLedgerState -- | @'ChainDepState' ('BlockProtocol' ('ShelleyBlock' era))@ diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/TPraos.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/TPraos.hs index 23bad278387..1bfc0eced65 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/TPraos.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/Node/TPraos.hs @@ -322,7 +322,7 @@ protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased { , shelleyStorageConfigSecurityParam = tpraosSecurityParam tpraosParams } - initLedgerState :: LedgerState (ShelleyBlock (TPraos c) era) + initLedgerState :: LedgerState (ShelleyBlock (TPraos c) era) Canonical initLedgerState = ShelleyLedgerState { shelleyLedgerTip = Origin , shelleyLedgerState = @@ -335,7 +335,7 @@ protocolInfoTPraosShelleyBased ProtocolParamsShelleyBased { initChainDepState = TPraosState Origin $ SL.initialChainDepState initialNonce (SL.sgGenDelegs genesis) - initExtLedgerState :: ExtLedgerState (ShelleyBlock (TPraos c) era) + initExtLedgerState :: ExtLedgerState (ShelleyBlock (TPraos c) era) Canonical initExtLedgerState = ExtLedgerState { ledgerState = initLedgerState , headerState = genesisHeaderState initChainDepState diff --git a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyHFC.hs b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyHFC.hs index 1438b1677c8..13d71632b35 100644 --- a/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyHFC.hs +++ b/ouroboros-consensus-shelley/src/Ouroboros/Consensus/Shelley/ShelleyHFC.hs @@ -41,6 +41,7 @@ import Ouroboros.Consensus.Forecast import Ouroboros.Consensus.HardFork.Combinator import Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common import Ouroboros.Consensus.HardFork.Combinator.State.Types +import Ouroboros.Consensus.HardFork.Combinator.Util.Functors import Ouroboros.Consensus.HardFork.Combinator.Util.InPairs (RequiringBoth (..), ignoringBoth) import Ouroboros.Consensus.HardFork.History (Bound (boundSlot)) @@ -134,7 +135,7 @@ shelleyTransition :: forall era proto. ShelleyCompatible proto era => PartialLedgerConfig (ShelleyBlock proto era) -> Word16 -- ^ Next era's major protocol version - -> LedgerState (ShelleyBlock proto era) + -> LedgerState (ShelleyBlock proto era) Canonical -> Maybe EpochNo shelleyTransition ShelleyPartialLedgerConfig{..} transitionMajorVersion @@ -248,7 +249,7 @@ forecastAcrossShelley :: -> ShelleyLedgerConfig eraTo -> Bound -- ^ Transition between the two eras -> SlotNo -- ^ Forecast for this slot - -> LedgerState (ShelleyBlock protoFrom eraFrom) + -> LedgerState (ShelleyBlock protoFrom eraFrom) Canonical -> Except OutsideForecastRange (Ticked (WrapLedgerView (ShelleyBlock protoTo eraTo))) forecastAcrossShelley cfgFrom cfgTo transition forecastFor ledgerStateFrom | forecastFor < maxFor @@ -327,11 +328,11 @@ instance ( ShelleyBasedEra era , SL.TranslateEra era (ShelleyTip proto) , SL.TranslateEra era SL.NewEpochState , SL.TranslationError era SL.NewEpochState ~ Void - ) => SL.TranslateEra era (LedgerState :.: ShelleyBlock proto) where - translateEra ctxt (Comp (ShelleyLedgerState tip state _transition)) = do + ) => SL.TranslateEra era (Flip LedgerState Canonical :.: ShelleyBlock proto) where + translateEra ctxt (Comp (Flip (ShelleyLedgerState tip state _transition))) = do tip' <- mapM (SL.translateEra ctxt) tip state' <- SL.translateEra ctxt state - return $ Comp $ ShelleyLedgerState { + return $ Comp $ Flip $ ShelleyLedgerState { shelleyLedgerTip = tip' , shelleyLedgerState = state' , shelleyLedgerTransition = ShelleyTransitionInfo 0