diff --git a/semantics/executable-spec/src/Control/State/Transition/Extended.hs b/semantics/executable-spec/src/Control/State/Transition/Extended.hs index 2e91c1ba0c1..283008e4a25 100644 --- a/semantics/executable-spec/src/Control/State/Transition/Extended.hs +++ b/semantics/executable-spec/src/Control/State/Transition/Extended.hs @@ -50,6 +50,7 @@ module Control.State.Transition.Extended liftSTS, tellEvent, tellEvents, + EventReturnTypeRep, mapEventReturn, -- * Apply STS @@ -61,6 +62,7 @@ module Control.State.Transition.Extended applySTS, applySTSIndifferently, reapplySTS, + globalAssertionPolicy, -- * Exported to allow running rules independently applySTSInternal, diff --git a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Validation.hs b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Validation.hs index 99857906009..f7942b1e408 100644 --- a/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Validation.hs +++ b/shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Validation.hs @@ -14,6 +14,8 @@ -- API. module Shelley.Spec.Ledger.API.Validation ( ApplyBlock (..), + applyBlock, + applyTick, TickTransitionError (..), BlockTransitionError (..), chainChecks, @@ -71,46 +73,58 @@ class -- -- This handles checks and updates that happen on a slot tick, as well as a -- few header level checks, such as size constraints. - applyTick :: + applyTickOpts :: + ApplySTSOpts ep -> Globals -> NewEpochState era -> SlotNo -> - NewEpochState era - default applyTick :: + EventReturnType ep (Core.EraRule "TICK" era) (NewEpochState era) + default applyTickOpts :: + ApplySTSOpts ep -> Globals -> NewEpochState era -> SlotNo -> - NewEpochState era - applyTick globals state hdr = - either err id . flip runReader globals - . applySTS @(Core.EraRule "TICK" era) + EventReturnType ep (Core.EraRule "TICK" era) (NewEpochState era) + applyTickOpts opts globals state hdr = + either err id + . flip runReader globals + . applySTSOptsEither @(Core.EraRule "TICK" era) opts $ TRC ((), state, hdr) where err :: Show a => a -> b err msg = error $ "Panic! applyTick failed: " <> show msg -- | Apply the block level ledger transition. - applyBlock :: - MonadError (BlockTransitionError era) m => + applyBlockOpts :: + forall ep m. + (EventReturnTypeRep ep, MonadError (BlockTransitionError era) m) => + ApplySTSOpts ep -> Globals -> NewEpochState era -> Block era -> - m (NewEpochState era) - default applyBlock :: - (MonadError (BlockTransitionError era) m) => + m (EventReturnType ep (Core.EraRule "BBODY" era) (NewEpochState era)) + default applyBlockOpts :: + forall ep m. + (EventReturnTypeRep ep, MonadError (BlockTransitionError era) m) => + ApplySTSOpts ep -> Globals -> NewEpochState era -> Block era -> - m (NewEpochState era) - applyBlock globals state blk = + m (EventReturnType ep (Core.EraRule "BBODY" era) (NewEpochState era)) + applyBlockOpts opts globals state blk = liftEither - . right (updateNewEpochState state) . left BlockTransitionError + . right + ( mapEventReturn @ep @(Core.EraRule "BBODY" era) $ + updateNewEpochState state + ) $ res where res = - flip runReader globals . applySTS @(Core.EraRule "BBODY" era) $ - TRC (mkBbodyEnv state, bbs, blk) + flip runReader globals + . applySTSOptsEither @(Core.EraRule "BBODY" era) + opts + $ TRC (mkBbodyEnv state, bbs, blk) bbs = STS.BbodyState (LedgerState.esLState $ LedgerState.nesEs state) @@ -142,6 +156,36 @@ class (LedgerState.esLState $ LedgerState.nesEs state) (LedgerState.nesBcur state) +applyTick :: + ApplyBlock era => + Globals -> + NewEpochState era -> + SlotNo -> + NewEpochState era +applyTick = + applyTickOpts $ + ApplySTSOpts + { asoAssertions = globalAssertionPolicy, + asoValidation = ValidateAll, + asoEvents = EPDiscard + } + +applyBlock :: + ( ApplyBlock era, + MonadError (BlockTransitionError era) m + ) => + Globals -> + NewEpochState era -> + Block era -> + m (NewEpochState era) +applyBlock = + applyBlockOpts $ + ApplySTSOpts + { asoAssertions = globalAssertionPolicy, + asoValidation = ValidateAll, + asoEvents = EPDiscard + } + instance PraosCrypto crypto => ApplyBlock (ShelleyEra crypto) {-------------------------------------------------------------------------------