{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} module Ouroboros.Consensus.HardFork.Combinator.Ledger ( HardForkEnvelopeErr (..) , HardForkLedgerError (..) , HardForkLedgerUpdate (..) , HardForkLedgerWarning (..) -- * Type family instances , Ticked (..) -- * Low-level API (exported for the benefit of testing) , AnnForecast (..) , mkHardForkForecast ) where import Control.Monad (guard) import Control.Monad.Except (throwError, withExcept) import Data.Functor ((<&>)) import Data.Functor.Product import Data.Proxy import Data.SOP.BasicFunctors import Data.SOP.Constraint import Data.SOP.Counting (getExactly) import Data.SOP.Index import Data.SOP.InPairs (InPairs (..)) import qualified Data.SOP.InPairs as InPairs import qualified Data.SOP.Match as Match import Data.SOP.Strict import Data.SOP.Telescope (Telescope (..)) import qualified Data.SOP.Telescope as Telescope import GHC.Generics (Generic) import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config import Ouroboros.Consensus.Forecast import Ouroboros.Consensus.HardFork.Abstract import Ouroboros.Consensus.HardFork.Combinator.Abstract import Ouroboros.Consensus.HardFork.Combinator.AcrossEras import Ouroboros.Consensus.HardFork.Combinator.Basics import Ouroboros.Consensus.HardFork.Combinator.Block import Ouroboros.Consensus.HardFork.Combinator.Info import Ouroboros.Consensus.HardFork.Combinator.PartialConfig import Ouroboros.Consensus.HardFork.Combinator.Protocol () import Ouroboros.Consensus.HardFork.Combinator.Protocol.LedgerView import qualified Ouroboros.Consensus.HardFork.Combinator.State as State import Ouroboros.Consensus.HardFork.Combinator.State.Types import Ouroboros.Consensus.HardFork.Combinator.Translation import Ouroboros.Consensus.HardFork.History (Bound (..), EraParams, SafeZone (..)) import qualified Ouroboros.Consensus.HardFork.History as History import Ouroboros.Consensus.HeaderValidation import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.TypeFamilyWrappers import Ouroboros.Consensus.Util.Condense {------------------------------------------------------------------------------- Errors -------------------------------------------------------------------------------} data HardForkLedgerError xs = -- | Validation error from one of the eras HardForkLedgerErrorFromEra (OneEraLedgerError xs) -- | We tried to apply a block from the wrong era | HardForkLedgerErrorWrongEra (MismatchEraInfo xs) deriving ((forall x. HardForkLedgerError xs -> Rep (HardForkLedgerError xs) x) -> (forall x. Rep (HardForkLedgerError xs) x -> HardForkLedgerError xs) -> Generic (HardForkLedgerError xs) forall (xs :: [*]) x. Rep (HardForkLedgerError xs) x -> HardForkLedgerError xs forall (xs :: [*]) x. HardForkLedgerError xs -> Rep (HardForkLedgerError xs) x forall x. Rep (HardForkLedgerError xs) x -> HardForkLedgerError xs forall x. HardForkLedgerError xs -> Rep (HardForkLedgerError xs) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cfrom :: forall (xs :: [*]) x. HardForkLedgerError xs -> Rep (HardForkLedgerError xs) x from :: forall x. HardForkLedgerError xs -> Rep (HardForkLedgerError xs) x $cto :: forall (xs :: [*]) x. Rep (HardForkLedgerError xs) x -> HardForkLedgerError xs to :: forall x. Rep (HardForkLedgerError xs) x -> HardForkLedgerError xs Generic, Int -> HardForkLedgerError xs -> ShowS [HardForkLedgerError xs] -> ShowS HardForkLedgerError xs -> String (Int -> HardForkLedgerError xs -> ShowS) -> (HardForkLedgerError xs -> String) -> ([HardForkLedgerError xs] -> ShowS) -> Show (HardForkLedgerError xs) forall (xs :: [*]). CanHardFork xs => Int -> HardForkLedgerError xs -> ShowS forall (xs :: [*]). CanHardFork xs => [HardForkLedgerError xs] -> ShowS forall (xs :: [*]). CanHardFork xs => HardForkLedgerError xs -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: forall (xs :: [*]). CanHardFork xs => Int -> HardForkLedgerError xs -> ShowS showsPrec :: Int -> HardForkLedgerError xs -> ShowS $cshow :: forall (xs :: [*]). CanHardFork xs => HardForkLedgerError xs -> String show :: HardForkLedgerError xs -> String $cshowList :: forall (xs :: [*]). CanHardFork xs => [HardForkLedgerError xs] -> ShowS showList :: [HardForkLedgerError xs] -> ShowS Show, HardForkLedgerError xs -> HardForkLedgerError xs -> Bool (HardForkLedgerError xs -> HardForkLedgerError xs -> Bool) -> (HardForkLedgerError xs -> HardForkLedgerError xs -> Bool) -> Eq (HardForkLedgerError xs) forall (xs :: [*]). CanHardFork xs => HardForkLedgerError xs -> HardForkLedgerError xs -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a $c== :: forall (xs :: [*]). CanHardFork xs => HardForkLedgerError xs -> HardForkLedgerError xs -> Bool == :: HardForkLedgerError xs -> HardForkLedgerError xs -> Bool $c/= :: forall (xs :: [*]). CanHardFork xs => HardForkLedgerError xs -> HardForkLedgerError xs -> Bool /= :: HardForkLedgerError xs -> HardForkLedgerError xs -> Bool Eq, Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo) Proxy (HardForkLedgerError xs) -> String (Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo)) -> (Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo)) -> (Proxy (HardForkLedgerError xs) -> String) -> NoThunks (HardForkLedgerError xs) forall (xs :: [*]). CanHardFork xs => Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo) forall (xs :: [*]). CanHardFork xs => Proxy (HardForkLedgerError xs) -> String forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a $cnoThunks :: forall (xs :: [*]). CanHardFork xs => Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo) noThunks :: Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo) $cwNoThunks :: forall (xs :: [*]). CanHardFork xs => Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo) wNoThunks :: Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo) $cshowTypeOf :: forall (xs :: [*]). CanHardFork xs => Proxy (HardForkLedgerError xs) -> String showTypeOf :: Proxy (HardForkLedgerError xs) -> String NoThunks) {------------------------------------------------------------------------------- GetTip -------------------------------------------------------------------------------} instance CanHardFork xs => GetTip (LedgerState (HardForkBlock xs)) where getTip :: LedgerState (HardForkBlock xs) -> Point (LedgerState (HardForkBlock xs)) getTip = Point (HardForkBlock xs) -> Point (LedgerState (HardForkBlock xs)) forall {k1} {k2} (b :: k1) (b' :: k2). Coercible (HeaderHash b) (HeaderHash b') => Point b -> Point b' castPoint (Point (HardForkBlock xs) -> Point (LedgerState (HardForkBlock xs))) -> (LedgerState (HardForkBlock xs) -> Point (HardForkBlock xs)) -> LedgerState (HardForkBlock xs) -> Point (LedgerState (HardForkBlock xs)) forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall blk. SingleEraBlock blk => LedgerState blk -> Point blk) -> HardForkState LedgerState xs -> Point (HardForkBlock xs) forall (f :: * -> *) (xs :: [*]). CanHardFork xs => (forall blk. SingleEraBlock blk => f blk -> Point blk) -> HardForkState f xs -> Point (HardForkBlock xs) State.getTip (Point (LedgerState blk) -> Point blk forall {k1} {k2} (b :: k1) (b' :: k2). Coercible (HeaderHash b) (HeaderHash b') => Point b -> Point b' castPoint (Point (LedgerState blk) -> Point blk) -> (LedgerState blk -> Point (LedgerState blk)) -> LedgerState blk -> Point blk forall b c a. (b -> c) -> (a -> b) -> a -> c . LedgerState blk -> Point (LedgerState blk) forall l. GetTip l => l -> Point l getTip) (HardForkState LedgerState xs -> Point (HardForkBlock xs)) -> (LedgerState (HardForkBlock xs) -> HardForkState LedgerState xs) -> LedgerState (HardForkBlock xs) -> Point (HardForkBlock xs) forall b c a. (b -> c) -> (a -> b) -> a -> c . LedgerState (HardForkBlock xs) -> HardForkState LedgerState xs forall (xs :: [*]). LedgerState (HardForkBlock xs) -> HardForkState LedgerState xs hardForkLedgerStatePerEra instance CanHardFork xs => GetTip (Ticked (LedgerState (HardForkBlock xs))) where getTip :: Ticked (LedgerState (HardForkBlock xs)) -> Point (Ticked (LedgerState (HardForkBlock xs))) getTip = Point (HardForkBlock xs) -> Point (Ticked (LedgerState (HardForkBlock xs))) forall {k1} {k2} (b :: k1) (b' :: k2). Coercible (HeaderHash b) (HeaderHash b') => Point b -> Point b' castPoint (Point (HardForkBlock xs) -> Point (Ticked (LedgerState (HardForkBlock xs)))) -> (Ticked (LedgerState (HardForkBlock xs)) -> Point (HardForkBlock xs)) -> Ticked (LedgerState (HardForkBlock xs)) -> Point (Ticked (LedgerState (HardForkBlock xs))) forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall blk. SingleEraBlock blk => (:.:) Ticked LedgerState blk -> Point blk) -> HardForkState (Ticked :.: LedgerState) xs -> Point (HardForkBlock xs) forall (f :: * -> *) (xs :: [*]). CanHardFork xs => (forall blk. SingleEraBlock blk => f blk -> Point blk) -> HardForkState f xs -> Point (HardForkBlock xs) State.getTip (Point (Ticked (LedgerState blk)) -> Point blk forall {k1} {k2} (b :: k1) (b' :: k2). Coercible (HeaderHash b) (HeaderHash b') => Point b -> Point b' castPoint (Point (Ticked (LedgerState blk)) -> Point blk) -> ((:.:) Ticked LedgerState blk -> Point (Ticked (LedgerState blk))) -> (:.:) Ticked LedgerState blk -> Point blk forall b c a. (b -> c) -> (a -> b) -> a -> c . Ticked (LedgerState blk) -> Point (Ticked (LedgerState blk)) forall l. GetTip l => l -> Point l getTip (Ticked (LedgerState blk) -> Point (Ticked (LedgerState blk))) -> ((:.:) Ticked LedgerState blk -> Ticked (LedgerState blk)) -> (:.:) Ticked LedgerState blk -> Point (Ticked (LedgerState blk)) forall b c a. (b -> c) -> (a -> b) -> a -> c . (:.:) Ticked LedgerState blk -> Ticked (LedgerState blk) forall {l} {k} (f :: l -> *) (g :: k -> l) (p :: k). (:.:) f g p -> f (g p) unComp) (HardForkState (Ticked :.: LedgerState) xs -> Point (HardForkBlock xs)) -> (Ticked (LedgerState (HardForkBlock xs)) -> HardForkState (Ticked :.: LedgerState) xs) -> Ticked (LedgerState (HardForkBlock xs)) -> Point (HardForkBlock xs) forall b c a. (b -> c) -> (a -> b) -> a -> c . Ticked (LedgerState (HardForkBlock xs)) -> HardForkState (Ticked :.: LedgerState) xs forall (xs :: [*]). Ticked (LedgerState (HardForkBlock xs)) -> HardForkState (Ticked :.: LedgerState) xs tickedHardForkLedgerStatePerEra {------------------------------------------------------------------------------- Ticking -------------------------------------------------------------------------------} data instance Ticked (LedgerState (HardForkBlock xs)) = TickedHardForkLedgerState { forall (xs :: [*]). Ticked (LedgerState (HardForkBlock xs)) -> TransitionInfo tickedHardForkLedgerStateTransition :: !TransitionInfo , forall (xs :: [*]). Ticked (LedgerState (HardForkBlock xs)) -> HardForkState (Ticked :.: LedgerState) xs tickedHardForkLedgerStatePerEra :: !(HardForkState (Ticked :.: LedgerState) xs) } deriving ((forall x. Ticked (LedgerState (HardForkBlock xs)) -> Rep (Ticked (LedgerState (HardForkBlock xs))) x) -> (forall x. Rep (Ticked (LedgerState (HardForkBlock xs))) x -> Ticked (LedgerState (HardForkBlock xs))) -> Generic (Ticked (LedgerState (HardForkBlock xs))) forall (xs :: [*]) x. Rep (Ticked (LedgerState (HardForkBlock xs))) x -> Ticked (LedgerState (HardForkBlock xs)) forall (xs :: [*]) x. Ticked (LedgerState (HardForkBlock xs)) -> Rep (Ticked (LedgerState (HardForkBlock xs))) x forall x. Rep (Ticked (LedgerState (HardForkBlock xs))) x -> Ticked (LedgerState (HardForkBlock xs)) forall x. Ticked (LedgerState (HardForkBlock xs)) -> Rep (Ticked (LedgerState (HardForkBlock xs))) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cfrom :: forall (xs :: [*]) x. Ticked (LedgerState (HardForkBlock xs)) -> Rep (Ticked (LedgerState (HardForkBlock xs))) x from :: forall x. Ticked (LedgerState (HardForkBlock xs)) -> Rep (Ticked (LedgerState (HardForkBlock xs))) x $cto :: forall (xs :: [*]) x. Rep (Ticked (LedgerState (HardForkBlock xs))) x -> Ticked (LedgerState (HardForkBlock xs)) to :: forall x. Rep (Ticked (LedgerState (HardForkBlock xs))) x -> Ticked (LedgerState (HardForkBlock xs)) Generic) deriving anyclass instance CanHardFork xs => NoThunks (Ticked (LedgerState (HardForkBlock xs))) instance CanHardFork xs => IsLedger (LedgerState (HardForkBlock xs)) where type LedgerErr (LedgerState (HardForkBlock xs)) = HardForkLedgerError xs type AuxLedgerEvent (LedgerState (HardForkBlock xs)) = OneEraLedgerEvent xs applyChainTickLedgerResult :: LedgerCfg (LedgerState (HardForkBlock xs)) -> SlotNo -> LedgerState (HardForkBlock xs) -> LedgerResult (LedgerState (HardForkBlock xs)) (Ticked (LedgerState (HardForkBlock xs))) applyChainTickLedgerResult cfg :: LedgerCfg (LedgerState (HardForkBlock xs)) cfg@HardForkLedgerConfig{Shape xs PerEraLedgerConfig xs hardForkLedgerConfigShape :: Shape xs hardForkLedgerConfigPerEra :: PerEraLedgerConfig xs hardForkLedgerConfigShape :: forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs hardForkLedgerConfigPerEra :: forall (xs :: [*]). HardForkLedgerConfig xs -> PerEraLedgerConfig xs ..} SlotNo slot (HardForkLedgerState HardForkState LedgerState xs st) = HardForkState (LedgerResult (LedgerState (HardForkBlock xs)) :.: (Ticked :.: LedgerState)) xs -> LedgerResult (LedgerState (HardForkBlock xs)) (HardForkState (Ticked :.: LedgerState) xs) forall (m :: * -> *) (f :: * -> *) (xs :: [*]). (All Top xs, Functor m) => HardForkState (m :.: f) xs -> m (HardForkState f xs) sequenceHardForkState (Proxy SingleEraBlock -> (forall a. SingleEraBlock a => Index xs a -> WrapPartialLedgerConfig a -> LedgerState a -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) (Ticked :.: LedgerState) a) -> NP WrapPartialLedgerConfig xs -> HardForkState LedgerState xs -> HardForkState (LedgerResult (LedgerState (HardForkBlock xs)) :.: (Ticked :.: LedgerState)) xs forall {k} (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint) (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *) (f2 :: k -> *) (f3 :: k -> *). (HAp h, All c xs, Prod h ~ NP) => proxy c -> (forall (a :: k). c a => Index xs a -> f1 a -> f2 a -> f3 a) -> NP f1 xs -> h f2 xs -> h f3 xs hcizipWith Proxy SingleEraBlock proxySingle (EpochInfo (Except PastHorizonException) -> SlotNo -> Index xs a -> WrapPartialLedgerConfig a -> LedgerState a -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) (Ticked :.: LedgerState) a forall blk (xs :: [*]). SingleEraBlock blk => EpochInfo (Except PastHorizonException) -> SlotNo -> Index xs blk -> WrapPartialLedgerConfig blk -> LedgerState blk -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) (Ticked :.: LedgerState) blk tickOne EpochInfo (Except PastHorizonException) ei SlotNo slot) NP WrapPartialLedgerConfig xs cfgs HardForkState LedgerState xs extended) LedgerResult (LedgerState (HardForkBlock xs)) (HardForkState (Ticked :.: LedgerState) xs) -> (HardForkState (Ticked :.: LedgerState) xs -> Ticked (LedgerState (HardForkBlock xs))) -> LedgerResult (LedgerState (HardForkBlock xs)) (Ticked (LedgerState (HardForkBlock xs))) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b <&> \HardForkState (Ticked :.: LedgerState) xs l' -> TickedHardForkLedgerState { tickedHardForkLedgerStateTransition :: TransitionInfo tickedHardForkLedgerStateTransition = -- We are bundling a 'TransitionInfo' with a /ticked/ ledger state, -- but /derive/ that 'TransitionInfo' from the /unticked/ (albeit -- extended) state. That requires justification. Three cases: -- -- o 'TransitionUnknown'. If the transition is unknown, then it -- cannot become known due to ticking. In this case, we record -- the tip of the ledger, which ticking also does not modify -- (this is an explicit postcondition of 'applyChainTick'). -- o 'TransitionKnown'. If the transition to the next epoch is -- already known, then ticking does not change that information. -- It can't be the case that the 'SlotNo' we're ticking to is -- /in/ that next era, because if was, then 'extendToSlot' would -- have extended the telescope further. -- (This does mean however that it is important to use the -- /extended/ ledger state, not the original, to determine the -- 'TransitionInfo'.) -- o 'TransitionImpossible'. This has two subcases: either we are -- in the final era, in which case ticking certainly won't be able -- to change that, or we're forecasting, which is simply not -- applicable here. HardForkLedgerConfig xs -> HardForkState LedgerState xs -> TransitionInfo forall (xs :: [*]). All SingleEraBlock xs => HardForkLedgerConfig xs -> HardForkState LedgerState xs -> TransitionInfo State.mostRecentTransitionInfo LedgerCfg (LedgerState (HardForkBlock xs)) HardForkLedgerConfig xs cfg HardForkState LedgerState xs extended , tickedHardForkLedgerStatePerEra :: HardForkState (Ticked :.: LedgerState) xs tickedHardForkLedgerStatePerEra = HardForkState (Ticked :.: LedgerState) xs l' } where cfgs :: NP WrapPartialLedgerConfig xs cfgs = PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs forall (xs :: [*]). PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs getPerEraLedgerConfig PerEraLedgerConfig xs hardForkLedgerConfigPerEra ei :: EpochInfo (Except PastHorizonException) ei = HardForkLedgerConfig xs -> HardForkState LedgerState xs -> EpochInfo (Except PastHorizonException) forall (xs :: [*]). All SingleEraBlock xs => HardForkLedgerConfig xs -> HardForkState LedgerState xs -> EpochInfo (Except PastHorizonException) State.epochInfoLedger LedgerCfg (LedgerState (HardForkBlock xs)) HardForkLedgerConfig xs cfg HardForkState LedgerState xs st extended :: HardForkState LedgerState xs extended :: HardForkState LedgerState xs extended = HardForkLedgerConfig xs -> SlotNo -> HardForkState LedgerState xs -> HardForkState LedgerState xs forall (xs :: [*]). CanHardFork xs => HardForkLedgerConfig xs -> SlotNo -> HardForkState LedgerState xs -> HardForkState LedgerState xs State.extendToSlot LedgerCfg (LedgerState (HardForkBlock xs)) HardForkLedgerConfig xs cfg SlotNo slot HardForkState LedgerState xs st tickOne :: SingleEraBlock blk => EpochInfo (Except PastHorizonException) -> SlotNo -> Index xs blk -> WrapPartialLedgerConfig blk -> LedgerState blk -> ( LedgerResult (LedgerState (HardForkBlock xs)) :.: (Ticked :.: LedgerState) ) blk tickOne :: forall blk (xs :: [*]). SingleEraBlock blk => EpochInfo (Except PastHorizonException) -> SlotNo -> Index xs blk -> WrapPartialLedgerConfig blk -> LedgerState blk -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) (Ticked :.: LedgerState) blk tickOne EpochInfo (Except PastHorizonException) ei SlotNo slot Index xs blk index WrapPartialLedgerConfig blk pcfg LedgerState blk st = LedgerResult (LedgerState (HardForkBlock xs)) ((:.:) Ticked LedgerState blk) -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) (Ticked :.: LedgerState) blk forall l k (f :: l -> *) (g :: k -> l) (p :: k). f (g p) -> (:.:) f g p Comp (LedgerResult (LedgerState (HardForkBlock xs)) ((:.:) Ticked LedgerState blk) -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) (Ticked :.: LedgerState) blk) -> LedgerResult (LedgerState (HardForkBlock xs)) ((:.:) Ticked LedgerState blk) -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) (Ticked :.: LedgerState) blk forall a b. (a -> b) -> a -> b $ (Ticked (LedgerState blk) -> (:.:) Ticked LedgerState blk) -> LedgerResult (LedgerState (HardForkBlock xs)) (Ticked (LedgerState blk)) -> LedgerResult (LedgerState (HardForkBlock xs)) ((:.:) Ticked LedgerState blk) forall a b. (a -> b) -> LedgerResult (LedgerState (HardForkBlock xs)) a -> LedgerResult (LedgerState (HardForkBlock xs)) b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap Ticked (LedgerState blk) -> (:.:) Ticked LedgerState blk forall l k (f :: l -> *) (g :: k -> l) (p :: k). f (g p) -> (:.:) f g p Comp (LedgerResult (LedgerState (HardForkBlock xs)) (Ticked (LedgerState blk)) -> LedgerResult (LedgerState (HardForkBlock xs)) ((:.:) Ticked LedgerState blk)) -> LedgerResult (LedgerState (HardForkBlock xs)) (Ticked (LedgerState blk)) -> LedgerResult (LedgerState (HardForkBlock xs)) ((:.:) Ticked LedgerState blk) forall a b. (a -> b) -> a -> b $ (AuxLedgerEvent (LedgerState blk) -> AuxLedgerEvent (LedgerState (HardForkBlock xs))) -> LedgerResult (LedgerState blk) (Ticked (LedgerState blk)) -> LedgerResult (LedgerState (HardForkBlock xs)) (Ticked (LedgerState blk)) forall l l' a. (AuxLedgerEvent l -> AuxLedgerEvent l') -> LedgerResult l a -> LedgerResult l' a embedLedgerResult (Index xs blk -> AuxLedgerEvent (LedgerState blk) -> OneEraLedgerEvent xs forall (xs :: [*]) blk. Index xs blk -> AuxLedgerEvent (LedgerState blk) -> OneEraLedgerEvent xs injectLedgerEvent Index xs blk index) (LedgerResult (LedgerState blk) (Ticked (LedgerState blk)) -> LedgerResult (LedgerState (HardForkBlock xs)) (Ticked (LedgerState blk))) -> LedgerResult (LedgerState blk) (Ticked (LedgerState blk)) -> LedgerResult (LedgerState (HardForkBlock xs)) (Ticked (LedgerState blk)) forall a b. (a -> b) -> a -> b $ LedgerCfg (LedgerState blk) -> SlotNo -> LedgerState blk -> LedgerResult (LedgerState blk) (Ticked (LedgerState blk)) forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> LedgerResult l (Ticked l) applyChainTickLedgerResult (EpochInfo (Except PastHorizonException) -> WrapPartialLedgerConfig blk -> LedgerCfg (LedgerState blk) forall blk. HasPartialLedgerConfig blk => EpochInfo (Except PastHorizonException) -> WrapPartialLedgerConfig blk -> LedgerConfig blk completeLedgerConfig' EpochInfo (Except PastHorizonException) ei WrapPartialLedgerConfig blk pcfg) SlotNo slot LedgerState blk st {------------------------------------------------------------------------------- ApplyBlock -------------------------------------------------------------------------------} instance CanHardFork xs => ApplyBlock (LedgerState (HardForkBlock xs)) (HardForkBlock xs) where applyBlockLedgerResult :: HasCallStack => LedgerCfg (LedgerState (HardForkBlock xs)) -> HardForkBlock xs -> Ticked (LedgerState (HardForkBlock xs)) -> Except (LedgerErr (LedgerState (HardForkBlock xs))) (LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs))) applyBlockLedgerResult LedgerCfg (LedgerState (HardForkBlock xs)) cfg (HardForkBlock (OneEraBlock NS I xs block)) (TickedHardForkLedgerState TransitionInfo transition HardForkState (Ticked :.: LedgerState) xs st) = case NS I xs -> HardForkState (Ticked :.: LedgerState) xs -> Either (Mismatch I (Current (Ticked :.: LedgerState)) xs) (HardForkState (Product I (Ticked :.: LedgerState)) xs) forall (xs :: [*]) (h :: * -> *) (f :: * -> *). SListI xs => NS h xs -> HardForkState f xs -> Either (Mismatch h (Current f) xs) (HardForkState (Product h f) xs) State.match NS I xs block HardForkState (Ticked :.: LedgerState) xs st of Left Mismatch I (Current (Ticked :.: LedgerState)) xs mismatch -> -- Block from the wrong era (note that 'applyChainTick' will already -- have initiated the transition to the next era if appropriate). HardForkLedgerError xs -> Except (LedgerErr (LedgerState (HardForkBlock xs))) (LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs))) forall a. HardForkLedgerError xs -> ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (HardForkLedgerError xs -> Except (LedgerErr (LedgerState (HardForkBlock xs))) (LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs)))) -> HardForkLedgerError xs -> Except (LedgerErr (LedgerState (HardForkBlock xs))) (LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs))) forall a b. (a -> b) -> a -> b $ MismatchEraInfo xs -> HardForkLedgerError xs forall (xs :: [*]). MismatchEraInfo xs -> HardForkLedgerError xs HardForkLedgerErrorWrongEra (MismatchEraInfo xs -> HardForkLedgerError xs) -> (Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs) -> Mismatch SingleEraInfo LedgerEraInfo xs -> HardForkLedgerError xs forall b c a. (b -> c) -> (a -> b) -> a -> c . Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs forall (xs :: [*]). Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs MismatchEraInfo (Mismatch SingleEraInfo LedgerEraInfo xs -> HardForkLedgerError xs) -> Mismatch SingleEraInfo LedgerEraInfo xs -> HardForkLedgerError xs forall a b. (a -> b) -> a -> b $ Proxy SingleEraBlock -> (forall x. SingleEraBlock x => I x -> SingleEraInfo x) -> (forall x. SingleEraBlock x => Current (Ticked :.: LedgerState) x -> LedgerEraInfo x) -> Mismatch I (Current (Ticked :.: LedgerState)) xs -> Mismatch SingleEraInfo LedgerEraInfo xs forall {k} (c :: k -> Constraint) (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f :: k -> *) (f' :: k -> *) (g :: k -> *) (g' :: k -> *). All c xs => proxy c -> (forall (x :: k). c x => f x -> f' x) -> (forall (x :: k). c x => g x -> g' x) -> Mismatch f g xs -> Mismatch f' g' xs Match.bihcmap Proxy SingleEraBlock proxySingle I x -> SingleEraInfo x forall x. SingleEraBlock x => I x -> SingleEraInfo x forall blk (proxy :: * -> *). SingleEraBlock blk => proxy blk -> SingleEraInfo blk forall (proxy :: * -> *). proxy x -> SingleEraInfo x singleEraInfo Current (Ticked :.: LedgerState) x -> LedgerEraInfo x forall x. SingleEraBlock x => Current (Ticked :.: LedgerState) x -> LedgerEraInfo x ledgerInfo Mismatch I (Current (Ticked :.: LedgerState)) xs mismatch Right HardForkState (Product I (Ticked :.: LedgerState)) xs matched -> (HardForkState (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs -> LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs))) -> ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity (HardForkState (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs) -> Except (LedgerErr (LedgerState (HardForkBlock xs))) (LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs))) forall a b. (a -> b) -> ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity a -> ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap ((HardForkState LedgerState xs -> LedgerState (HardForkBlock xs)) -> LedgerResult (LedgerState (HardForkBlock xs)) (HardForkState LedgerState xs) -> LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs)) forall a b. (a -> b) -> LedgerResult (LedgerState (HardForkBlock xs)) a -> LedgerResult (LedgerState (HardForkBlock xs)) b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap HardForkState LedgerState xs -> LedgerState (HardForkBlock xs) forall (xs :: [*]). HardForkState LedgerState xs -> LedgerState (HardForkBlock xs) HardForkLedgerState (LedgerResult (LedgerState (HardForkBlock xs)) (HardForkState LedgerState xs) -> LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs))) -> (HardForkState (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs -> LedgerResult (LedgerState (HardForkBlock xs)) (HardForkState LedgerState xs)) -> HardForkState (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs -> LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs)) forall b c a. (b -> c) -> (a -> b) -> a -> c . HardForkState (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs -> LedgerResult (LedgerState (HardForkBlock xs)) (HardForkState LedgerState xs) forall (m :: * -> *) (f :: * -> *) (xs :: [*]). (All Top xs, Functor m) => HardForkState (m :.: f) xs -> m (HardForkState f xs) sequenceHardForkState) (ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity (HardForkState (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs) -> Except (LedgerErr (LedgerState (HardForkBlock xs))) (LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs)))) -> ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity (HardForkState (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs) -> Except (LedgerErr (LedgerState (HardForkBlock xs))) (LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs))) forall a b. (a -> b) -> a -> b $ HardForkState (ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity :.: (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState)) xs -> ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity (HardForkState (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs) forall (xs :: [*]) (f :: * -> *) (g :: * -> *). (SListIN HardForkState xs, Applicative f) => HardForkState (f :.: g) xs -> f (HardForkState g xs) forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: * -> *) (g :: k -> *). (HSequence h, SListIN h xs, Applicative f) => h (f :.: g) xs -> f (h g xs) hsequence' (HardForkState (ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity :.: (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState)) xs -> ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity (HardForkState (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs)) -> HardForkState (ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity :.: (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState)) xs -> ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity (HardForkState (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs) forall a b. (a -> b) -> a -> b $ Proxy SingleEraBlock -> (forall a. SingleEraBlock a => Index xs a -> WrapLedgerConfig a -> Product I (Ticked :.: LedgerState) a -> (:.:) (ExceptT (HardForkLedgerError xs) Identity) (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) a) -> NP WrapLedgerConfig xs -> HardForkState (Product I (Ticked :.: LedgerState)) xs -> HardForkState (ExceptT (HardForkLedgerError xs) Identity :.: (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState)) xs forall {k} (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint) (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *) (f2 :: k -> *) (f3 :: k -> *). (HAp h, All c xs, Prod h ~ NP) => proxy c -> (forall (a :: k). c a => Index xs a -> f1 a -> f2 a -> f3 a) -> NP f1 xs -> h f2 xs -> h f3 xs hcizipWith Proxy SingleEraBlock proxySingle Index xs a -> WrapLedgerConfig a -> Product I (Ticked :.: LedgerState) a -> (:.:) (ExceptT (HardForkLedgerError xs) Identity) (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) a forall a. SingleEraBlock a => Index xs a -> WrapLedgerConfig a -> Product I (Ticked :.: LedgerState) a -> (:.:) (ExceptT (HardForkLedgerError xs) Identity) (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) a forall blk (xs :: [*]). SingleEraBlock blk => Index xs blk -> WrapLedgerConfig blk -> Product I (Ticked :.: LedgerState) blk -> (:.:) (Except (HardForkLedgerError xs)) (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) blk apply NP WrapLedgerConfig xs cfgs HardForkState (Product I (Ticked :.: LedgerState)) xs matched where cfgs :: NP WrapLedgerConfig xs cfgs = EpochInfo (Except PastHorizonException) -> LedgerCfg (LedgerState (HardForkBlock xs)) -> NP WrapLedgerConfig xs forall (xs :: [*]). CanHardFork xs => EpochInfo (Except PastHorizonException) -> LedgerConfig (HardForkBlock xs) -> NP WrapLedgerConfig xs distribLedgerConfig EpochInfo (Except PastHorizonException) ei LedgerCfg (LedgerState (HardForkBlock xs)) cfg ei :: EpochInfo (Except PastHorizonException) ei = Shape xs -> TransitionInfo -> HardForkState (Ticked :.: LedgerState) xs -> EpochInfo (Except PastHorizonException) forall (xs :: [*]) (f :: * -> *). Shape xs -> TransitionInfo -> HardForkState f xs -> EpochInfo (Except PastHorizonException) State.epochInfoPrecomputedTransitionInfo (HardForkLedgerConfig xs -> Shape xs forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs hardForkLedgerConfigShape LedgerCfg (LedgerState (HardForkBlock xs)) HardForkLedgerConfig xs cfg) TransitionInfo transition HardForkState (Ticked :.: LedgerState) xs st reapplyBlockLedgerResult :: HasCallStack => LedgerCfg (LedgerState (HardForkBlock xs)) -> HardForkBlock xs -> Ticked (LedgerState (HardForkBlock xs)) -> LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs)) reapplyBlockLedgerResult LedgerCfg (LedgerState (HardForkBlock xs)) cfg (HardForkBlock (OneEraBlock NS I xs block)) (TickedHardForkLedgerState TransitionInfo transition HardForkState (Ticked :.: LedgerState) xs st) = case NS I xs -> HardForkState (Ticked :.: LedgerState) xs -> Either (Mismatch I (Current (Ticked :.: LedgerState)) xs) (HardForkState (Product I (Ticked :.: LedgerState)) xs) forall (xs :: [*]) (h :: * -> *) (f :: * -> *). SListI xs => NS h xs -> HardForkState f xs -> Either (Mismatch h (Current f) xs) (HardForkState (Product h f) xs) State.match NS I xs block HardForkState (Ticked :.: LedgerState) xs st of Left Mismatch I (Current (Ticked :.: LedgerState)) xs _mismatch -> -- We already applied this block to this ledger state, -- so it can't be from the wrong era String -> LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs)) forall a. HasCallStack => String -> a error String "reapplyBlockLedgerResult: can't be from other era" Right HardForkState (Product I (Ticked :.: LedgerState)) xs matched -> (HardForkState LedgerState xs -> LedgerState (HardForkBlock xs)) -> LedgerResult (LedgerState (HardForkBlock xs)) (HardForkState LedgerState xs) -> LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs)) forall a b. (a -> b) -> LedgerResult (LedgerState (HardForkBlock xs)) a -> LedgerResult (LedgerState (HardForkBlock xs)) b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap HardForkState LedgerState xs -> LedgerState (HardForkBlock xs) forall (xs :: [*]). HardForkState LedgerState xs -> LedgerState (HardForkBlock xs) HardForkLedgerState (LedgerResult (LedgerState (HardForkBlock xs)) (HardForkState LedgerState xs) -> LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs))) -> LedgerResult (LedgerState (HardForkBlock xs)) (HardForkState LedgerState xs) -> LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs)) forall a b. (a -> b) -> a -> b $ HardForkState (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs -> LedgerResult (LedgerState (HardForkBlock xs)) (HardForkState LedgerState xs) forall (m :: * -> *) (f :: * -> *) (xs :: [*]). (All Top xs, Functor m) => HardForkState (m :.: f) xs -> m (HardForkState f xs) sequenceHardForkState (HardForkState (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs -> LedgerResult (LedgerState (HardForkBlock xs)) (HardForkState LedgerState xs)) -> HardForkState (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs -> LedgerResult (LedgerState (HardForkBlock xs)) (HardForkState LedgerState xs) forall a b. (a -> b) -> a -> b $ Proxy SingleEraBlock -> (forall a. SingleEraBlock a => Index xs a -> WrapLedgerConfig a -> Product I (Ticked :.: LedgerState) a -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState a) -> NP WrapLedgerConfig xs -> HardForkState (Product I (Ticked :.: LedgerState)) xs -> HardForkState (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs forall {k} (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint) (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *) (f2 :: k -> *) (f3 :: k -> *). (HAp h, All c xs, Prod h ~ NP) => proxy c -> (forall (a :: k). c a => Index xs a -> f1 a -> f2 a -> f3 a) -> NP f1 xs -> h f2 xs -> h f3 xs hcizipWith Proxy SingleEraBlock proxySingle Index xs a -> WrapLedgerConfig a -> Product I (Ticked :.: LedgerState) a -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState a forall a. SingleEraBlock a => Index xs a -> WrapLedgerConfig a -> Product I (Ticked :.: LedgerState) a -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState a forall blk (xs :: [*]). SingleEraBlock blk => Index xs blk -> WrapLedgerConfig blk -> Product I (Ticked :.: LedgerState) blk -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk reapply NP WrapLedgerConfig xs cfgs HardForkState (Product I (Ticked :.: LedgerState)) xs matched where cfgs :: NP WrapLedgerConfig xs cfgs = EpochInfo (Except PastHorizonException) -> LedgerCfg (LedgerState (HardForkBlock xs)) -> NP WrapLedgerConfig xs forall (xs :: [*]). CanHardFork xs => EpochInfo (Except PastHorizonException) -> LedgerConfig (HardForkBlock xs) -> NP WrapLedgerConfig xs distribLedgerConfig EpochInfo (Except PastHorizonException) ei LedgerCfg (LedgerState (HardForkBlock xs)) cfg ei :: EpochInfo (Except PastHorizonException) ei = Shape xs -> TransitionInfo -> HardForkState (Ticked :.: LedgerState) xs -> EpochInfo (Except PastHorizonException) forall (xs :: [*]) (f :: * -> *). Shape xs -> TransitionInfo -> HardForkState f xs -> EpochInfo (Except PastHorizonException) State.epochInfoPrecomputedTransitionInfo (HardForkLedgerConfig xs -> Shape xs forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs hardForkLedgerConfigShape LedgerCfg (LedgerState (HardForkBlock xs)) HardForkLedgerConfig xs cfg) TransitionInfo transition HardForkState (Ticked :.: LedgerState) xs st apply :: SingleEraBlock blk => Index xs blk -> WrapLedgerConfig blk -> Product I (Ticked :.: LedgerState) blk -> ( Except (HardForkLedgerError xs) :.: LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState ) blk apply :: forall blk (xs :: [*]). SingleEraBlock blk => Index xs blk -> WrapLedgerConfig blk -> Product I (Ticked :.: LedgerState) blk -> (:.:) (Except (HardForkLedgerError xs)) (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) blk apply Index xs blk index (WrapLedgerConfig LedgerConfig blk cfg) (Pair (I blk block) (Comp Ticked (LedgerState blk) st)) = Except (HardForkLedgerError xs) ((:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk) -> (:.:) (Except (HardForkLedgerError xs)) (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) blk forall l k (f :: l -> *) (g :: k -> l) (p :: k). f (g p) -> (:.:) f g p Comp (Except (HardForkLedgerError xs) ((:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk) -> (:.:) (Except (HardForkLedgerError xs)) (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) blk) -> Except (HardForkLedgerError xs) ((:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk) -> (:.:) (Except (HardForkLedgerError xs)) (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) blk forall a b. (a -> b) -> a -> b $ (LedgerErr (LedgerState blk) -> HardForkLedgerError xs) -> Except (LedgerErr (LedgerState blk)) ((:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk) -> Except (HardForkLedgerError xs) ((:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk) forall e e' a. (e -> e') -> Except e a -> Except e' a withExcept (Index xs blk -> LedgerErr (LedgerState blk) -> HardForkLedgerError xs forall (xs :: [*]) blk. Index xs blk -> LedgerError blk -> HardForkLedgerError xs injectLedgerError Index xs blk index) (Except (LedgerErr (LedgerState blk)) ((:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk) -> Except (HardForkLedgerError xs) ((:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk)) -> Except (LedgerErr (LedgerState blk)) ((:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk) -> Except (HardForkLedgerError xs) ((:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk) forall a b. (a -> b) -> a -> b $ (LedgerResult (LedgerState blk) (LedgerState blk) -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk) -> ExceptT (LedgerErr (LedgerState blk)) Identity (LedgerResult (LedgerState blk) (LedgerState blk)) -> Except (LedgerErr (LedgerState blk)) ((:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk) forall a b. (a -> b) -> ExceptT (LedgerErr (LedgerState blk)) Identity a -> ExceptT (LedgerErr (LedgerState blk)) Identity b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b fmap (LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState blk) -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk forall l k (f :: l -> *) (g :: k -> l) (p :: k). f (g p) -> (:.:) f g p Comp (LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState blk) -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk) -> (LedgerResult (LedgerState blk) (LedgerState blk) -> LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState blk)) -> LedgerResult (LedgerState blk) (LedgerState blk) -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk forall b c a. (b -> c) -> (a -> b) -> a -> c . (AuxLedgerEvent (LedgerState blk) -> AuxLedgerEvent (LedgerState (HardForkBlock xs))) -> LedgerResult (LedgerState blk) (LedgerState blk) -> LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState blk) forall l l' a. (AuxLedgerEvent l -> AuxLedgerEvent l') -> LedgerResult l a -> LedgerResult l' a embedLedgerResult (Index xs blk -> AuxLedgerEvent (LedgerState blk) -> OneEraLedgerEvent xs forall (xs :: [*]) blk. Index xs blk -> AuxLedgerEvent (LedgerState blk) -> OneEraLedgerEvent xs injectLedgerEvent Index xs blk index)) (ExceptT (LedgerErr (LedgerState blk)) Identity (LedgerResult (LedgerState blk) (LedgerState blk)) -> Except (LedgerErr (LedgerState blk)) ((:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk)) -> ExceptT (LedgerErr (LedgerState blk)) Identity (LedgerResult (LedgerState blk) (LedgerState blk)) -> Except (LedgerErr (LedgerState blk)) ((:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk) forall a b. (a -> b) -> a -> b $ LedgerConfig blk -> blk -> Ticked (LedgerState blk) -> ExceptT (LedgerErr (LedgerState blk)) Identity (LedgerResult (LedgerState blk) (LedgerState blk)) forall l blk. (ApplyBlock l blk, HasCallStack) => LedgerCfg l -> blk -> Ticked l -> Except (LedgerErr l) (LedgerResult l l) applyBlockLedgerResult LedgerConfig blk cfg blk block Ticked (LedgerState blk) st reapply :: SingleEraBlock blk => Index xs blk -> WrapLedgerConfig blk -> Product I (Ticked :.: LedgerState) blk -> ( LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState ) blk reapply :: forall blk (xs :: [*]). SingleEraBlock blk => Index xs blk -> WrapLedgerConfig blk -> Product I (Ticked :.: LedgerState) blk -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk reapply Index xs blk index (WrapLedgerConfig LedgerConfig blk cfg) (Pair (I blk block) (Comp Ticked (LedgerState blk) st)) = LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState blk) -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk forall l k (f :: l -> *) (g :: k -> l) (p :: k). f (g p) -> (:.:) f g p Comp (LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState blk) -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk) -> LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState blk) -> (:.:) (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk forall a b. (a -> b) -> a -> b $ (AuxLedgerEvent (LedgerState blk) -> AuxLedgerEvent (LedgerState (HardForkBlock xs))) -> LedgerResult (LedgerState blk) (LedgerState blk) -> LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState blk) forall l l' a. (AuxLedgerEvent l -> AuxLedgerEvent l') -> LedgerResult l a -> LedgerResult l' a embedLedgerResult (Index xs blk -> AuxLedgerEvent (LedgerState blk) -> OneEraLedgerEvent xs forall (xs :: [*]) blk. Index xs blk -> AuxLedgerEvent (LedgerState blk) -> OneEraLedgerEvent xs injectLedgerEvent Index xs blk index) (LedgerResult (LedgerState blk) (LedgerState blk) -> LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState blk)) -> LedgerResult (LedgerState blk) (LedgerState blk) -> LedgerResult (LedgerState (HardForkBlock xs)) (LedgerState blk) forall a b. (a -> b) -> a -> b $ LedgerConfig blk -> blk -> Ticked (LedgerState blk) -> LedgerResult (LedgerState blk) (LedgerState blk) forall l blk. (ApplyBlock l blk, HasCallStack) => LedgerCfg l -> blk -> Ticked l -> LedgerResult l l reapplyBlockLedgerResult LedgerConfig blk cfg blk block Ticked (LedgerState blk) st {------------------------------------------------------------------------------- UpdateLedger -------------------------------------------------------------------------------} instance CanHardFork xs => UpdateLedger (HardForkBlock xs) {------------------------------------------------------------------------------- HasHardForkHistory -------------------------------------------------------------------------------} instance All SingleEraBlock xs => HasHardForkHistory (HardForkBlock xs) where type HardForkIndices (HardForkBlock xs) = xs hardForkSummary :: LedgerConfig (HardForkBlock xs) -> LedgerState (HardForkBlock xs) -> Summary (HardForkIndices (HardForkBlock xs)) hardForkSummary LedgerConfig (HardForkBlock xs) cfg = HardForkLedgerConfig xs -> HardForkState LedgerState xs -> Summary xs forall (xs :: [*]). All SingleEraBlock xs => HardForkLedgerConfig xs -> HardForkState LedgerState xs -> Summary xs State.reconstructSummaryLedger LedgerConfig (HardForkBlock xs) HardForkLedgerConfig xs cfg (HardForkState LedgerState xs -> Summary xs) -> (LedgerState (HardForkBlock xs) -> HardForkState LedgerState xs) -> LedgerState (HardForkBlock xs) -> Summary xs forall b c a. (b -> c) -> (a -> b) -> a -> c . LedgerState (HardForkBlock xs) -> HardForkState LedgerState xs forall (xs :: [*]). LedgerState (HardForkBlock xs) -> HardForkState LedgerState xs hardForkLedgerStatePerEra {------------------------------------------------------------------------------- HeaderValidation -------------------------------------------------------------------------------} data HardForkEnvelopeErr xs = -- | Validation error from one of the eras HardForkEnvelopeErrFromEra (OneEraEnvelopeErr xs) -- | We tried to apply a block from the wrong era | HardForkEnvelopeErrWrongEra (MismatchEraInfo xs) deriving (HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool (HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool) -> (HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool) -> Eq (HardForkEnvelopeErr xs) forall (xs :: [*]). CanHardFork xs => HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a $c== :: forall (xs :: [*]). CanHardFork xs => HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool == :: HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool $c/= :: forall (xs :: [*]). CanHardFork xs => HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool /= :: HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool Eq, Int -> HardForkEnvelopeErr xs -> ShowS [HardForkEnvelopeErr xs] -> ShowS HardForkEnvelopeErr xs -> String (Int -> HardForkEnvelopeErr xs -> ShowS) -> (HardForkEnvelopeErr xs -> String) -> ([HardForkEnvelopeErr xs] -> ShowS) -> Show (HardForkEnvelopeErr xs) forall (xs :: [*]). CanHardFork xs => Int -> HardForkEnvelopeErr xs -> ShowS forall (xs :: [*]). CanHardFork xs => [HardForkEnvelopeErr xs] -> ShowS forall (xs :: [*]). CanHardFork xs => HardForkEnvelopeErr xs -> String forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a $cshowsPrec :: forall (xs :: [*]). CanHardFork xs => Int -> HardForkEnvelopeErr xs -> ShowS showsPrec :: Int -> HardForkEnvelopeErr xs -> ShowS $cshow :: forall (xs :: [*]). CanHardFork xs => HardForkEnvelopeErr xs -> String show :: HardForkEnvelopeErr xs -> String $cshowList :: forall (xs :: [*]). CanHardFork xs => [HardForkEnvelopeErr xs] -> ShowS showList :: [HardForkEnvelopeErr xs] -> ShowS Show, (forall x. HardForkEnvelopeErr xs -> Rep (HardForkEnvelopeErr xs) x) -> (forall x. Rep (HardForkEnvelopeErr xs) x -> HardForkEnvelopeErr xs) -> Generic (HardForkEnvelopeErr xs) forall (xs :: [*]) x. Rep (HardForkEnvelopeErr xs) x -> HardForkEnvelopeErr xs forall (xs :: [*]) x. HardForkEnvelopeErr xs -> Rep (HardForkEnvelopeErr xs) x forall x. Rep (HardForkEnvelopeErr xs) x -> HardForkEnvelopeErr xs forall x. HardForkEnvelopeErr xs -> Rep (HardForkEnvelopeErr xs) x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cfrom :: forall (xs :: [*]) x. HardForkEnvelopeErr xs -> Rep (HardForkEnvelopeErr xs) x from :: forall x. HardForkEnvelopeErr xs -> Rep (HardForkEnvelopeErr xs) x $cto :: forall (xs :: [*]) x. Rep (HardForkEnvelopeErr xs) x -> HardForkEnvelopeErr xs to :: forall x. Rep (HardForkEnvelopeErr xs) x -> HardForkEnvelopeErr xs Generic, Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo) Proxy (HardForkEnvelopeErr xs) -> String (Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo)) -> (Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo)) -> (Proxy (HardForkEnvelopeErr xs) -> String) -> NoThunks (HardForkEnvelopeErr xs) forall (xs :: [*]). CanHardFork xs => Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo) forall (xs :: [*]). CanHardFork xs => Proxy (HardForkEnvelopeErr xs) -> String forall a. (Context -> a -> IO (Maybe ThunkInfo)) -> (Context -> a -> IO (Maybe ThunkInfo)) -> (Proxy a -> String) -> NoThunks a $cnoThunks :: forall (xs :: [*]). CanHardFork xs => Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo) noThunks :: Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo) $cwNoThunks :: forall (xs :: [*]). CanHardFork xs => Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo) wNoThunks :: Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo) $cshowTypeOf :: forall (xs :: [*]). CanHardFork xs => Proxy (HardForkEnvelopeErr xs) -> String showTypeOf :: Proxy (HardForkEnvelopeErr xs) -> String NoThunks) instance CanHardFork xs => ValidateEnvelope (HardForkBlock xs) where type OtherHeaderEnvelopeError (HardForkBlock xs) = HardForkEnvelopeErr xs additionalEnvelopeChecks :: TopLevelConfig (HardForkBlock xs) -> LedgerView (BlockProtocol (HardForkBlock xs)) -> Header (HardForkBlock xs) -> Except (OtherHeaderEnvelopeError (HardForkBlock xs)) () additionalEnvelopeChecks TopLevelConfig (HardForkBlock xs) tlc (HardForkLedgerView TransitionInfo transition HardForkState WrapLedgerView xs hardForkView) = \(HardForkHeader (OneEraHeader NS Header xs hdr)) -> case NS Header xs -> NS WrapLedgerView xs -> Either (Mismatch Header WrapLedgerView xs) (NS (Product Header WrapLedgerView) xs) forall {k} (f :: k -> *) (xs :: [k]) (g :: k -> *). NS f xs -> NS g xs -> Either (Mismatch f g xs) (NS (Product f g) xs) Match.matchNS NS Header xs hdr (HardForkState WrapLedgerView xs -> NS WrapLedgerView xs forall (xs :: [*]) (f :: * -> *). SListI xs => HardForkState f xs -> NS f xs State.tip HardForkState WrapLedgerView xs hardForkView) of Left Mismatch Header WrapLedgerView xs mismatch -> HardForkEnvelopeErr xs -> Except (OtherHeaderEnvelopeError (HardForkBlock xs)) () forall a. HardForkEnvelopeErr xs -> ExceptT (OtherHeaderEnvelopeError (HardForkBlock xs)) Identity a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (HardForkEnvelopeErr xs -> Except (OtherHeaderEnvelopeError (HardForkBlock xs)) ()) -> HardForkEnvelopeErr xs -> Except (OtherHeaderEnvelopeError (HardForkBlock xs)) () forall a b. (a -> b) -> a -> b $ MismatchEraInfo xs -> HardForkEnvelopeErr xs forall (xs :: [*]). MismatchEraInfo xs -> HardForkEnvelopeErr xs HardForkEnvelopeErrWrongEra (MismatchEraInfo xs -> HardForkEnvelopeErr xs) -> (Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs) -> Mismatch SingleEraInfo LedgerEraInfo xs -> HardForkEnvelopeErr xs forall b c a. (b -> c) -> (a -> b) -> a -> c . Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs forall (xs :: [*]). Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs MismatchEraInfo (Mismatch SingleEraInfo LedgerEraInfo xs -> HardForkEnvelopeErr xs) -> Mismatch SingleEraInfo LedgerEraInfo xs -> HardForkEnvelopeErr xs forall a b. (a -> b) -> a -> b $ Proxy SingleEraBlock -> (forall x. SingleEraBlock x => Header x -> SingleEraInfo x) -> (forall x. SingleEraBlock x => WrapLedgerView x -> LedgerEraInfo x) -> Mismatch Header WrapLedgerView xs -> Mismatch SingleEraInfo LedgerEraInfo xs forall {k} (c :: k -> Constraint) (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f :: k -> *) (f' :: k -> *) (g :: k -> *) (g' :: k -> *). All c xs => proxy c -> (forall (x :: k). c x => f x -> f' x) -> (forall (x :: k). c x => g x -> g' x) -> Mismatch f g xs -> Mismatch f' g' xs Match.bihcmap Proxy SingleEraBlock proxySingle Header x -> SingleEraInfo x forall x. SingleEraBlock x => Header x -> SingleEraInfo x forall blk (proxy :: * -> *). SingleEraBlock blk => proxy blk -> SingleEraInfo blk forall (proxy :: * -> *). proxy x -> SingleEraInfo x singleEraInfo WrapLedgerView x -> LedgerEraInfo x forall x. SingleEraBlock x => WrapLedgerView x -> LedgerEraInfo x forall blk (f :: * -> *). SingleEraBlock blk => f blk -> LedgerEraInfo blk ledgerViewInfo Mismatch Header WrapLedgerView xs mismatch Right NS (Product Header WrapLedgerView) xs matched -> NS (K (ExceptT (HardForkEnvelopeErr xs) Identity ())) xs -> CollapseTo NS (ExceptT (HardForkEnvelopeErr xs) Identity ()) forall (xs :: [*]) a. SListIN NS xs => NS (K a) xs -> CollapseTo NS a forall k l (h :: (k -> *) -> l -> *) (xs :: l) a. (HCollapse h, SListIN h xs) => h (K a) xs -> CollapseTo h a hcollapse (NS (K (ExceptT (HardForkEnvelopeErr xs) Identity ())) xs -> CollapseTo NS (ExceptT (HardForkEnvelopeErr xs) Identity ())) -> NS (K (ExceptT (HardForkEnvelopeErr xs) Identity ())) xs -> CollapseTo NS (ExceptT (HardForkEnvelopeErr xs) Identity ()) forall a b. (a -> b) -> a -> b $ Proxy SingleEraBlock -> (forall a. SingleEraBlock a => Index xs a -> TopLevelConfig a -> Product Header WrapLedgerView a -> K (ExceptT (HardForkEnvelopeErr xs) Identity ()) a) -> NP TopLevelConfig xs -> NS (Product Header WrapLedgerView) xs -> NS (K (ExceptT (HardForkEnvelopeErr xs) Identity ())) xs forall {k} (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint) (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *) (f2 :: k -> *) (f3 :: k -> *). (HAp h, All c xs, Prod h ~ NP) => proxy c -> (forall (a :: k). c a => Index xs a -> f1 a -> f2 a -> f3 a) -> NP f1 xs -> h f2 xs -> h f3 xs hcizipWith Proxy SingleEraBlock proxySingle Index xs a -> TopLevelConfig a -> Product Header WrapLedgerView a -> K (ExceptT (HardForkEnvelopeErr xs) Identity ()) a forall a. SingleEraBlock a => Index xs a -> TopLevelConfig a -> Product Header WrapLedgerView a -> K (ExceptT (HardForkEnvelopeErr xs) Identity ()) a aux NP TopLevelConfig xs cfgs NS (Product Header WrapLedgerView) xs matched where ei :: EpochInfo (Except PastHorizonException) ei :: EpochInfo (Except PastHorizonException) ei = Shape xs -> TransitionInfo -> HardForkState WrapLedgerView xs -> EpochInfo (Except PastHorizonException) forall (xs :: [*]) (f :: * -> *). Shape xs -> TransitionInfo -> HardForkState f xs -> EpochInfo (Except PastHorizonException) State.epochInfoPrecomputedTransitionInfo (HardForkLedgerConfig xs -> Shape xs forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs hardForkLedgerConfigShape (HardForkLedgerConfig xs -> Shape xs) -> HardForkLedgerConfig xs -> Shape xs forall a b. (a -> b) -> a -> b $ TopLevelConfig (HardForkBlock xs) -> LedgerConfig (HardForkBlock xs) forall blk. TopLevelConfig blk -> LedgerConfig blk configLedger TopLevelConfig (HardForkBlock xs) tlc) TransitionInfo transition HardForkState WrapLedgerView xs hardForkView cfgs :: NP TopLevelConfig xs cfgs :: NP TopLevelConfig xs cfgs = EpochInfo (Except PastHorizonException) -> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs forall (xs :: [*]). All SingleEraBlock xs => EpochInfo (Except PastHorizonException) -> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs distribTopLevelConfig EpochInfo (Except PastHorizonException) ei TopLevelConfig (HardForkBlock xs) tlc aux :: forall blk. SingleEraBlock blk => Index xs blk -> TopLevelConfig blk -> Product Header WrapLedgerView blk -> K (Except (HardForkEnvelopeErr xs) ()) blk aux :: forall a. SingleEraBlock a => Index xs a -> TopLevelConfig a -> Product Header WrapLedgerView a -> K (ExceptT (HardForkEnvelopeErr xs) Identity ()) a aux Index xs blk index TopLevelConfig blk cfg (Pair Header blk hdr WrapLedgerView blk view) = ExceptT (HardForkEnvelopeErr xs) Identity () -> K (ExceptT (HardForkEnvelopeErr xs) Identity ()) blk forall k a (b :: k). a -> K a b K (ExceptT (HardForkEnvelopeErr xs) Identity () -> K (ExceptT (HardForkEnvelopeErr xs) Identity ()) blk) -> ExceptT (HardForkEnvelopeErr xs) Identity () -> K (ExceptT (HardForkEnvelopeErr xs) Identity ()) blk forall a b. (a -> b) -> a -> b $ (OtherHeaderEnvelopeError blk -> HardForkEnvelopeErr xs) -> Except (OtherHeaderEnvelopeError blk) () -> ExceptT (HardForkEnvelopeErr xs) Identity () forall e e' a. (e -> e') -> Except e a -> Except e' a withExcept OtherHeaderEnvelopeError blk -> HardForkEnvelopeErr xs injErr' (Except (OtherHeaderEnvelopeError blk) () -> ExceptT (HardForkEnvelopeErr xs) Identity ()) -> Except (OtherHeaderEnvelopeError blk) () -> ExceptT (HardForkEnvelopeErr xs) Identity () forall a b. (a -> b) -> a -> b $ TopLevelConfig blk -> LedgerView (BlockProtocol blk) -> Header blk -> Except (OtherHeaderEnvelopeError blk) () forall blk. ValidateEnvelope blk => TopLevelConfig blk -> LedgerView (BlockProtocol blk) -> Header blk -> Except (OtherHeaderEnvelopeError blk) () additionalEnvelopeChecks TopLevelConfig blk cfg (WrapLedgerView blk -> LedgerView (BlockProtocol blk) forall blk. WrapLedgerView blk -> LedgerView (BlockProtocol blk) unwrapLedgerView WrapLedgerView blk view) Header blk hdr where injErr' :: OtherHeaderEnvelopeError blk -> HardForkEnvelopeErr xs injErr' :: OtherHeaderEnvelopeError blk -> HardForkEnvelopeErr xs injErr' = OneEraEnvelopeErr xs -> HardForkEnvelopeErr xs forall (xs :: [*]). OneEraEnvelopeErr xs -> HardForkEnvelopeErr xs HardForkEnvelopeErrFromEra (OneEraEnvelopeErr xs -> HardForkEnvelopeErr xs) -> (OtherHeaderEnvelopeError blk -> OneEraEnvelopeErr xs) -> OtherHeaderEnvelopeError blk -> HardForkEnvelopeErr xs forall b c a. (b -> c) -> (a -> b) -> a -> c . NS WrapEnvelopeErr xs -> OneEraEnvelopeErr xs forall (xs :: [*]). NS WrapEnvelopeErr xs -> OneEraEnvelopeErr xs OneEraEnvelopeErr (NS WrapEnvelopeErr xs -> OneEraEnvelopeErr xs) -> (OtherHeaderEnvelopeError blk -> NS WrapEnvelopeErr xs) -> OtherHeaderEnvelopeError blk -> OneEraEnvelopeErr xs forall b c a. (b -> c) -> (a -> b) -> a -> c . Index xs blk -> WrapEnvelopeErr blk -> NS WrapEnvelopeErr xs forall {k} (f :: k -> *) (x :: k) (xs :: [k]). Index xs x -> f x -> NS f xs injectNS Index xs blk index (WrapEnvelopeErr blk -> NS WrapEnvelopeErr xs) -> (OtherHeaderEnvelopeError blk -> WrapEnvelopeErr blk) -> OtherHeaderEnvelopeError blk -> NS WrapEnvelopeErr xs forall b c a. (b -> c) -> (a -> b) -> a -> c . OtherHeaderEnvelopeError blk -> WrapEnvelopeErr blk forall blk. OtherHeaderEnvelopeError blk -> WrapEnvelopeErr blk WrapEnvelopeErr {------------------------------------------------------------------------------- LedgerSupportsProtocol -------------------------------------------------------------------------------} instance CanHardFork xs => LedgerSupportsProtocol (HardForkBlock xs) where protocolLedgerView :: LedgerConfig (HardForkBlock xs) -> Ticked (LedgerState (HardForkBlock xs)) -> LedgerView (BlockProtocol (HardForkBlock xs)) protocolLedgerView HardForkLedgerConfig{Shape xs PerEraLedgerConfig xs hardForkLedgerConfigShape :: forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs hardForkLedgerConfigPerEra :: forall (xs :: [*]). HardForkLedgerConfig xs -> PerEraLedgerConfig xs hardForkLedgerConfigShape :: Shape xs hardForkLedgerConfigPerEra :: PerEraLedgerConfig xs ..} (TickedHardForkLedgerState TransitionInfo transition HardForkState (Ticked :.: LedgerState) xs ticked) = HardForkLedgerView { hardForkLedgerViewTransition :: TransitionInfo hardForkLedgerViewTransition = TransitionInfo transition , hardForkLedgerViewPerEra :: HardForkState WrapLedgerView xs hardForkLedgerViewPerEra = Proxy SingleEraBlock -> (forall a. SingleEraBlock a => WrapPartialLedgerConfig a -> (:.:) Ticked LedgerState a -> WrapLedgerView a) -> Prod HardForkState WrapPartialLedgerConfig xs -> HardForkState (Ticked :.: LedgerState) xs -> HardForkState WrapLedgerView xs forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint) (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *) (f' :: k -> *) (f'' :: k -> *). (AllN (Prod h) c xs, HAp h, HAp (Prod h)) => proxy c -> (forall (a :: k). c a => f a -> f' a -> f'' a) -> Prod h f xs -> h f' xs -> h f'' xs hczipWith Proxy SingleEraBlock proxySingle WrapPartialLedgerConfig a -> (:.:) Ticked LedgerState a -> WrapLedgerView a forall a. SingleEraBlock a => WrapPartialLedgerConfig a -> (:.:) Ticked LedgerState a -> WrapLedgerView a viewOne Prod HardForkState WrapPartialLedgerConfig xs NP WrapPartialLedgerConfig xs cfgs HardForkState (Ticked :.: LedgerState) xs ticked } where cfgs :: NP WrapPartialLedgerConfig xs cfgs = PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs forall (xs :: [*]). PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs getPerEraLedgerConfig PerEraLedgerConfig xs hardForkLedgerConfigPerEra ei :: EpochInfo (Except PastHorizonException) ei = Shape xs -> TransitionInfo -> HardForkState (Ticked :.: LedgerState) xs -> EpochInfo (Except PastHorizonException) forall (xs :: [*]) (f :: * -> *). Shape xs -> TransitionInfo -> HardForkState f xs -> EpochInfo (Except PastHorizonException) State.epochInfoPrecomputedTransitionInfo Shape xs hardForkLedgerConfigShape TransitionInfo transition HardForkState (Ticked :.: LedgerState) xs ticked viewOne :: SingleEraBlock blk => WrapPartialLedgerConfig blk -> (Ticked :.: LedgerState) blk -> WrapLedgerView blk viewOne :: forall a. SingleEraBlock a => WrapPartialLedgerConfig a -> (:.:) Ticked LedgerState a -> WrapLedgerView a viewOne WrapPartialLedgerConfig blk cfg (Comp Ticked (LedgerState blk) st) = LedgerView (BlockProtocol blk) -> WrapLedgerView blk forall blk. LedgerView (BlockProtocol blk) -> WrapLedgerView blk WrapLedgerView (LedgerView (BlockProtocol blk) -> WrapLedgerView blk) -> LedgerView (BlockProtocol blk) -> WrapLedgerView blk forall a b. (a -> b) -> a -> b $ LedgerConfig blk -> Ticked (LedgerState blk) -> LedgerView (BlockProtocol blk) forall blk. LedgerSupportsProtocol blk => LedgerConfig blk -> Ticked (LedgerState blk) -> LedgerView (BlockProtocol blk) protocolLedgerView (EpochInfo (Except PastHorizonException) -> WrapPartialLedgerConfig blk -> LedgerConfig blk forall blk. HasPartialLedgerConfig blk => EpochInfo (Except PastHorizonException) -> WrapPartialLedgerConfig blk -> LedgerConfig blk completeLedgerConfig' EpochInfo (Except PastHorizonException) ei WrapPartialLedgerConfig blk cfg) Ticked (LedgerState blk) st ledgerViewForecastAt :: HasCallStack => LedgerConfig (HardForkBlock xs) -> LedgerState (HardForkBlock xs) -> Forecast (LedgerView (BlockProtocol (HardForkBlock xs))) ledgerViewForecastAt ledgerCfg :: LedgerConfig (HardForkBlock xs) ledgerCfg@HardForkLedgerConfig{Shape xs PerEraLedgerConfig xs hardForkLedgerConfigShape :: forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs hardForkLedgerConfigPerEra :: forall (xs :: [*]). HardForkLedgerConfig xs -> PerEraLedgerConfig xs hardForkLedgerConfigShape :: Shape xs hardForkLedgerConfigPerEra :: PerEraLedgerConfig xs ..} (HardForkLedgerState HardForkState LedgerState xs ledgerSt) = InPairs (CrossEraForecaster LedgerState WrapLedgerView) xs -> HardForkState (AnnForecast LedgerState WrapLedgerView) xs -> Forecast (HardForkLedgerView_ WrapLedgerView xs) forall (state :: * -> *) (view :: * -> *) (xs :: [*]). SListI xs => InPairs (CrossEraForecaster state view) xs -> HardForkState (AnnForecast state view) xs -> Forecast (HardForkLedgerView_ view xs) mkHardForkForecast (NP WrapLedgerConfig xs -> InPairs (RequiringBoth WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView)) xs -> InPairs (CrossEraForecaster LedgerState WrapLedgerView) xs forall {k} (h :: k -> *) (xs :: [k]) (f :: k -> k -> *). NP h xs -> InPairs (RequiringBoth h f) xs -> InPairs f xs InPairs.requiringBoth NP WrapLedgerConfig xs cfgs (InPairs (RequiringBoth WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView)) xs -> InPairs (CrossEraForecaster LedgerState WrapLedgerView) xs) -> InPairs (RequiringBoth WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView)) xs -> InPairs (CrossEraForecaster LedgerState WrapLedgerView) xs forall a b. (a -> b) -> a -> b $ EraTranslation xs -> InPairs (RequiringBoth WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView)) xs forall (xs :: [*]). EraTranslation xs -> InPairs (RequiringBoth WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView)) xs crossEraForecast EraTranslation xs forall (xs :: [*]). CanHardFork xs => EraTranslation xs hardForkEraTranslation) HardForkState (AnnForecast LedgerState WrapLedgerView) xs annForecast where ei :: EpochInfo (Except PastHorizonException) ei = HardForkLedgerConfig xs -> HardForkState LedgerState xs -> EpochInfo (Except PastHorizonException) forall (xs :: [*]). All SingleEraBlock xs => HardForkLedgerConfig xs -> HardForkState LedgerState xs -> EpochInfo (Except PastHorizonException) State.epochInfoLedger LedgerConfig (HardForkBlock xs) HardForkLedgerConfig xs ledgerCfg HardForkState LedgerState xs ledgerSt pcfgs :: NP WrapPartialLedgerConfig xs pcfgs = PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs forall (xs :: [*]). PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs getPerEraLedgerConfig PerEraLedgerConfig xs hardForkLedgerConfigPerEra cfgs :: NP WrapLedgerConfig xs cfgs = Proxy SingleEraBlock -> (forall a. SingleEraBlock a => WrapPartialLedgerConfig a -> WrapLedgerConfig a) -> NP WrapPartialLedgerConfig xs -> NP WrapLedgerConfig xs forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint) (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *) (f' :: k -> *). (AllN (Prod h) c xs, HAp h) => proxy c -> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs hcmap Proxy SingleEraBlock proxySingle (EpochInfo (Except PastHorizonException) -> WrapPartialLedgerConfig a -> WrapLedgerConfig a forall blk. HasPartialLedgerConfig blk => EpochInfo (Except PastHorizonException) -> WrapPartialLedgerConfig blk -> WrapLedgerConfig blk completeLedgerConfig'' EpochInfo (Except PastHorizonException) ei) NP WrapPartialLedgerConfig xs pcfgs annForecast :: HardForkState (AnnForecast LedgerState WrapLedgerView) xs annForecast :: HardForkState (AnnForecast LedgerState WrapLedgerView) xs annForecast = Telescope (K Past) (Current (AnnForecast LedgerState WrapLedgerView)) xs -> HardForkState (AnnForecast LedgerState WrapLedgerView) xs forall (f :: * -> *) (xs :: [*]). Telescope (K Past) (Current f) xs -> HardForkState f xs HardForkState (Telescope (K Past) (Current (AnnForecast LedgerState WrapLedgerView)) xs -> HardForkState (AnnForecast LedgerState WrapLedgerView) xs) -> Telescope (K Past) (Current (AnnForecast LedgerState WrapLedgerView)) xs -> HardForkState (AnnForecast LedgerState WrapLedgerView) xs forall a b. (a -> b) -> a -> b $ Proxy SingleEraBlock -> (forall a. SingleEraBlock a => WrapPartialLedgerConfig a -> K EraParams a -> Current LedgerState a -> Current (AnnForecast LedgerState WrapLedgerView) a) -> Prod (Telescope (K Past)) WrapPartialLedgerConfig xs -> Prod (Telescope (K Past)) (K EraParams) xs -> Telescope (K Past) (Current LedgerState) xs -> Telescope (K Past) (Current (AnnForecast LedgerState WrapLedgerView)) xs forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint) (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *) (f' :: k -> *) (f'' :: k -> *) (f''' :: k -> *). (AllN (Prod h) c xs, HAp h, HAp (Prod h)) => proxy c -> (forall (a :: k). c a => f a -> f' a -> f'' a -> f''' a) -> Prod h f xs -> Prod h f' xs -> h f'' xs -> h f''' xs hczipWith3 Proxy SingleEraBlock proxySingle WrapPartialLedgerConfig a -> K EraParams a -> Current LedgerState a -> Current (AnnForecast LedgerState WrapLedgerView) a forall a. SingleEraBlock a => WrapPartialLedgerConfig a -> K EraParams a -> Current LedgerState a -> Current (AnnForecast LedgerState WrapLedgerView) a forecastOne Prod (Telescope (K Past)) WrapPartialLedgerConfig xs NP WrapPartialLedgerConfig xs pcfgs (Exactly xs EraParams -> NP (K EraParams) xs forall (xs :: [*]) a. Exactly xs a -> NP (K a) xs getExactly (Shape xs -> Exactly xs EraParams forall (xs :: [*]). Shape xs -> Exactly xs EraParams History.getShape Shape xs hardForkLedgerConfigShape)) (HardForkState LedgerState xs -> Telescope (K Past) (Current LedgerState) xs forall (f :: * -> *) (xs :: [*]). HardForkState f xs -> Telescope (K Past) (Current f) xs getHardForkState HardForkState LedgerState xs ledgerSt) forecastOne :: forall blk. SingleEraBlock blk => WrapPartialLedgerConfig blk -> K EraParams blk -> Current LedgerState blk -> Current (AnnForecast LedgerState WrapLedgerView) blk forecastOne :: forall a. SingleEraBlock a => WrapPartialLedgerConfig a -> K EraParams a -> Current LedgerState a -> Current (AnnForecast LedgerState WrapLedgerView) a forecastOne WrapPartialLedgerConfig blk cfg (K EraParams params) (Current Bound start LedgerState blk st) = Current { currentStart :: Bound currentStart = Bound start , currentState :: AnnForecast LedgerState WrapLedgerView blk currentState = AnnForecast { annForecast :: Forecast (WrapLedgerView blk) annForecast = (LedgerView (BlockProtocol blk) -> WrapLedgerView blk) -> Forecast (LedgerView (BlockProtocol blk)) -> Forecast (WrapLedgerView blk) forall a b. (a -> b) -> Forecast a -> Forecast b mapForecast LedgerView (BlockProtocol blk) -> WrapLedgerView blk forall blk. LedgerView (BlockProtocol blk) -> WrapLedgerView blk WrapLedgerView (Forecast (LedgerView (BlockProtocol blk)) -> Forecast (WrapLedgerView blk)) -> Forecast (LedgerView (BlockProtocol blk)) -> Forecast (WrapLedgerView blk) forall a b. (a -> b) -> a -> b $ LedgerConfig blk -> LedgerState blk -> Forecast (LedgerView (BlockProtocol blk)) forall blk. (LedgerSupportsProtocol blk, HasCallStack) => LedgerConfig blk -> LedgerState blk -> Forecast (LedgerView (BlockProtocol blk)) ledgerViewForecastAt LedgerConfig blk cfg' LedgerState blk st , annForecastState :: LedgerState blk annForecastState = LedgerState blk st , annForecastTip :: WithOrigin SlotNo annForecastTip = LedgerState blk -> WithOrigin SlotNo forall blk. UpdateLedger blk => LedgerState blk -> WithOrigin SlotNo ledgerTipSlot LedgerState blk st , annForecastEnd :: Maybe Bound annForecastEnd = HasCallStack => EraParams -> Bound -> EpochNo -> Bound EraParams -> Bound -> EpochNo -> Bound History.mkUpperBound EraParams params Bound start (EpochNo -> Bound) -> Maybe EpochNo -> Maybe Bound forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> WrapPartialLedgerConfig blk -> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo forall blk. SingleEraBlock blk => WrapPartialLedgerConfig blk -> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo singleEraTransition' WrapPartialLedgerConfig blk cfg EraParams params Bound start LedgerState blk st } } where cfg' :: LedgerConfig blk cfg' :: LedgerConfig blk cfg' = EpochInfo (Except PastHorizonException) -> WrapPartialLedgerConfig blk -> LedgerConfig blk forall blk. HasPartialLedgerConfig blk => EpochInfo (Except PastHorizonException) -> WrapPartialLedgerConfig blk -> LedgerConfig blk completeLedgerConfig' EpochInfo (Except PastHorizonException) ei WrapPartialLedgerConfig blk cfg {------------------------------------------------------------------------------- Annotated forecasts -------------------------------------------------------------------------------} -- | Forecast annotated with details about the ledger it was derived from data AnnForecast state view blk = AnnForecast { forall (state :: * -> *) (view :: * -> *) blk. AnnForecast state view blk -> Forecast (view blk) annForecast :: Forecast (view blk) , forall (state :: * -> *) (view :: * -> *) blk. AnnForecast state view blk -> state blk annForecastState :: state blk , forall (state :: * -> *) (view :: * -> *) blk. AnnForecast state view blk -> WithOrigin SlotNo annForecastTip :: WithOrigin SlotNo , forall (state :: * -> *) (view :: * -> *) blk. AnnForecast state view blk -> Maybe Bound annForecastEnd :: Maybe Bound } -- | Change a telescope of a forecast into a forecast of a telescope mkHardForkForecast :: forall state view xs. SListI xs => InPairs (CrossEraForecaster state view) xs -> HardForkState (AnnForecast state view) xs -> Forecast (HardForkLedgerView_ view xs) mkHardForkForecast :: forall (state :: * -> *) (view :: * -> *) (xs :: [*]). SListI xs => InPairs (CrossEraForecaster state view) xs -> HardForkState (AnnForecast state view) xs -> Forecast (HardForkLedgerView_ view xs) mkHardForkForecast InPairs (CrossEraForecaster state view) xs translations HardForkState (AnnForecast state view) xs st = Forecast { forecastAt :: WithOrigin SlotNo forecastAt = HardForkState (K (WithOrigin SlotNo)) xs -> CollapseTo HardForkState (WithOrigin SlotNo) forall (xs :: [*]) a. SListIN HardForkState xs => HardForkState (K a) xs -> CollapseTo HardForkState a forall k l (h :: (k -> *) -> l -> *) (xs :: l) a. (HCollapse h, SListIN h xs) => h (K a) xs -> CollapseTo h a hcollapse ((forall a. AnnForecast state view a -> K (WithOrigin SlotNo) a) -> HardForkState (AnnForecast state view) xs -> HardForkState (K (WithOrigin SlotNo)) xs forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *) (f' :: k -> *). (SListIN (Prod h) xs, HAp h) => (forall (a :: k). f a -> f' a) -> h f xs -> h f' xs hmap (WithOrigin SlotNo -> K (WithOrigin SlotNo) a forall k a (b :: k). a -> K a b K (WithOrigin SlotNo -> K (WithOrigin SlotNo) a) -> (AnnForecast state view a -> WithOrigin SlotNo) -> AnnForecast state view a -> K (WithOrigin SlotNo) a forall b c a. (b -> c) -> (a -> b) -> a -> c . Forecast (view a) -> WithOrigin SlotNo forall a. Forecast a -> WithOrigin SlotNo forecastAt (Forecast (view a) -> WithOrigin SlotNo) -> (AnnForecast state view a -> Forecast (view a)) -> AnnForecast state view a -> WithOrigin SlotNo forall b c a. (b -> c) -> (a -> b) -> a -> c . AnnForecast state view a -> Forecast (view a) forall (state :: * -> *) (view :: * -> *) blk. AnnForecast state view blk -> Forecast (view blk) annForecast) HardForkState (AnnForecast state view) xs st) , forecastFor :: SlotNo -> Except OutsideForecastRange (HardForkLedgerView_ view xs) forecastFor = \SlotNo sno -> SlotNo -> InPairs (CrossEraForecaster state view) xs -> Telescope (K Past) (Current (AnnForecast state view)) xs -> Except OutsideForecastRange (HardForkLedgerView_ view xs) forall (xs' :: [*]). SlotNo -> InPairs (CrossEraForecaster state view) xs' -> Telescope (K Past) (Current (AnnForecast state view)) xs' -> Except OutsideForecastRange (HardForkLedgerView_ view xs') go SlotNo sno InPairs (CrossEraForecaster state view) xs translations (HardForkState (AnnForecast state view) xs -> Telescope (K Past) (Current (AnnForecast state view)) xs forall (f :: * -> *) (xs :: [*]). HardForkState f xs -> Telescope (K Past) (Current f) xs getHardForkState HardForkState (AnnForecast state view) xs st) } where go :: SlotNo -> InPairs (CrossEraForecaster state view) xs' -> Telescope (K Past) (Current (AnnForecast state view)) xs' -> Except OutsideForecastRange (HardForkLedgerView_ view xs') go :: forall (xs' :: [*]). SlotNo -> InPairs (CrossEraForecaster state view) xs' -> Telescope (K Past) (Current (AnnForecast state view)) xs' -> Except OutsideForecastRange (HardForkLedgerView_ view xs') go SlotNo sno InPairs (CrossEraForecaster state view) xs' pairs (TZ Current (AnnForecast state view) x cur) = SlotNo -> InPairs (CrossEraForecaster state view) (x : xs1) -> Current (AnnForecast state view) x -> Except OutsideForecastRange (HardForkLedgerView_ view (x : xs1)) forall (state :: * -> *) (view :: * -> *) blk (blks :: [*]). SlotNo -> InPairs (CrossEraForecaster state view) (blk : blks) -> Current (AnnForecast state view) blk -> Except OutsideForecastRange (HardForkLedgerView_ view (blk : blks)) oneForecast SlotNo sno InPairs (CrossEraForecaster state view) xs' InPairs (CrossEraForecaster state view) (x : xs1) pairs Current (AnnForecast state view) x cur go SlotNo sno (PCons CrossEraForecaster state view x y _ InPairs (CrossEraForecaster state view) (y : zs) ts) (TS K Past x past Telescope (K Past) (Current (AnnForecast state view)) xs1 rest) = K Past x -> HardForkLedgerView_ view (y : zs) -> HardForkLedgerView_ view (x : y : zs) forall blk (f :: * -> *) (blks :: [*]). K Past blk -> HardForkLedgerView_ f blks -> HardForkLedgerView_ f (blk : blks) shiftView K Past x past (HardForkLedgerView_ view (y : zs) -> HardForkLedgerView_ view xs') -> ExceptT OutsideForecastRange Identity (HardForkLedgerView_ view (y : zs)) -> ExceptT OutsideForecastRange Identity (HardForkLedgerView_ view xs') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> SlotNo -> InPairs (CrossEraForecaster state view) (y : zs) -> Telescope (K Past) (Current (AnnForecast state view)) (y : zs) -> ExceptT OutsideForecastRange Identity (HardForkLedgerView_ view (y : zs)) forall (xs' :: [*]). SlotNo -> InPairs (CrossEraForecaster state view) xs' -> Telescope (K Past) (Current (AnnForecast state view)) xs' -> Except OutsideForecastRange (HardForkLedgerView_ view xs') go SlotNo sno InPairs (CrossEraForecaster state view) (y : zs) ts Telescope (K Past) (Current (AnnForecast state view)) xs1 Telescope (K Past) (Current (AnnForecast state view)) (y : zs) rest oneForecast :: forall state view blk blks. SlotNo -> InPairs (CrossEraForecaster state view) (blk : blks) -- ^ this function uses at most the first translation -> Current (AnnForecast state view) blk -> Except OutsideForecastRange (HardForkLedgerView_ view (blk : blks)) oneForecast :: forall (state :: * -> *) (view :: * -> *) blk (blks :: [*]). SlotNo -> InPairs (CrossEraForecaster state view) (blk : blks) -> Current (AnnForecast state view) blk -> Except OutsideForecastRange (HardForkLedgerView_ view (blk : blks)) oneForecast SlotNo sno InPairs (CrossEraForecaster state view) (blk : blks) pairs (Current Bound start AnnForecast{state blk Maybe Bound WithOrigin SlotNo Forecast (view blk) annForecast :: forall (state :: * -> *) (view :: * -> *) blk. AnnForecast state view blk -> Forecast (view blk) annForecastState :: forall (state :: * -> *) (view :: * -> *) blk. AnnForecast state view blk -> state blk annForecastTip :: forall (state :: * -> *) (view :: * -> *) blk. AnnForecast state view blk -> WithOrigin SlotNo annForecastEnd :: forall (state :: * -> *) (view :: * -> *) blk. AnnForecast state view blk -> Maybe Bound annForecast :: Forecast (view blk) annForecastState :: state blk annForecastTip :: WithOrigin SlotNo annForecastEnd :: Maybe Bound ..}) = case Maybe Bound annForecastEnd of Maybe Bound Nothing -> view blk -> HardForkLedgerView_ view (blk : blks) forall (f :: * -> *). f blk -> HardForkLedgerView_ f (blk : blks) endUnknown (view blk -> HardForkLedgerView_ view (blk : blks)) -> ExceptT OutsideForecastRange Identity (view blk) -> Except OutsideForecastRange (HardForkLedgerView_ view (blk : blks)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Forecast (view blk) -> SlotNo -> ExceptT OutsideForecastRange Identity (view blk) forall a. Forecast a -> SlotNo -> Except OutsideForecastRange a forecastFor Forecast (view blk) annForecast SlotNo sno Just Bound end -> if SlotNo sno SlotNo -> SlotNo -> Bool forall a. Ord a => a -> a -> Bool < Bound -> SlotNo boundSlot Bound end then Bound -> view blk -> HardForkLedgerView_ view (blk : blks) forall (f :: * -> *). Bound -> f blk -> HardForkLedgerView_ f (blk : blks) beforeKnownEnd Bound end (view blk -> HardForkLedgerView_ view (blk : blks)) -> ExceptT OutsideForecastRange Identity (view blk) -> Except OutsideForecastRange (HardForkLedgerView_ view (blk : blks)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Forecast (view blk) -> SlotNo -> ExceptT OutsideForecastRange Identity (view blk) forall a. Forecast a -> SlotNo -> Except OutsideForecastRange a forecastFor Forecast (view blk) annForecast SlotNo sno else case InPairs (CrossEraForecaster state view) (blk : blks) pairs of PCons CrossEraForecaster state view x y translate InPairs (CrossEraForecaster state view) (y : zs) _ -> Bound -> view y -> HardForkLedgerView_ view (blk : y : zs) forall (f :: * -> *) blk' (blks' :: [*]). Bound -> f blk' -> HardForkLedgerView_ f (blk : blk' : blks') afterKnownEnd Bound end (view y -> HardForkLedgerView_ view (blk : blks)) -> ExceptT OutsideForecastRange Identity (view y) -> Except OutsideForecastRange (HardForkLedgerView_ view (blk : blks)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> CrossEraForecaster state view x y -> Bound -> SlotNo -> state x -> ExceptT OutsideForecastRange Identity (view y) forall (state :: * -> *) (view :: * -> *) x y. CrossEraForecaster state view x y -> Bound -> SlotNo -> state x -> Except OutsideForecastRange (view y) crossEraForecastWith CrossEraForecaster state view x y translate Bound end SlotNo sno state blk state x annForecastState InPairs (CrossEraForecaster state view) (blk : blks) PNil -> -- The requested slot is after the last era the code knows about. OutsideForecastRange -> Except OutsideForecastRange (HardForkLedgerView_ view (blk : blks)) forall a. OutsideForecastRange -> ExceptT OutsideForecastRange Identity a forall e (m :: * -> *) a. MonadError e m => e -> m a throwError OutsideForecastRange { outsideForecastAt :: WithOrigin SlotNo outsideForecastAt = Forecast (view blk) -> WithOrigin SlotNo forall a. Forecast a -> WithOrigin SlotNo forecastAt Forecast (view blk) annForecast , outsideForecastMaxFor :: SlotNo outsideForecastMaxFor = Bound -> SlotNo boundSlot Bound end , outsideForecastFor :: SlotNo outsideForecastFor = SlotNo sno } where endUnknown :: f blk -> HardForkLedgerView_ f (blk : blks) endUnknown :: forall (f :: * -> *). f blk -> HardForkLedgerView_ f (blk : blks) endUnknown f blk view = HardForkLedgerView { hardForkLedgerViewTransition :: TransitionInfo hardForkLedgerViewTransition = WithOrigin SlotNo -> TransitionInfo TransitionUnknown WithOrigin SlotNo annForecastTip , hardForkLedgerViewPerEra :: HardForkState f (blk : blks) hardForkLedgerViewPerEra = Telescope (K Past) (Current f) (blk : blks) -> HardForkState f (blk : blks) forall (f :: * -> *) (xs :: [*]). Telescope (K Past) (Current f) xs -> HardForkState f xs HardForkState (Telescope (K Past) (Current f) (blk : blks) -> HardForkState f (blk : blks)) -> Telescope (K Past) (Current f) (blk : blks) -> HardForkState f (blk : blks) forall a b. (a -> b) -> a -> b $ Current f blk -> Telescope (K Past) (Current f) (blk : blks) forall {k} (f :: k -> *) (x :: k) (g :: k -> *) (xs1 :: [k]). f x -> Telescope g f (x : xs1) TZ (Bound -> f blk -> Current f blk forall (f :: * -> *) blk. Bound -> f blk -> Current f blk Current Bound start f blk view) } beforeKnownEnd :: Bound -> f blk -> HardForkLedgerView_ f (blk : blks) beforeKnownEnd :: forall (f :: * -> *). Bound -> f blk -> HardForkLedgerView_ f (blk : blks) beforeKnownEnd Bound end f blk view = HardForkLedgerView { hardForkLedgerViewTransition :: TransitionInfo hardForkLedgerViewTransition = EpochNo -> TransitionInfo TransitionKnown (Bound -> EpochNo boundEpoch Bound end) , hardForkLedgerViewPerEra :: HardForkState f (blk : blks) hardForkLedgerViewPerEra = Telescope (K Past) (Current f) (blk : blks) -> HardForkState f (blk : blks) forall (f :: * -> *) (xs :: [*]). Telescope (K Past) (Current f) xs -> HardForkState f xs HardForkState (Telescope (K Past) (Current f) (blk : blks) -> HardForkState f (blk : blks)) -> Telescope (K Past) (Current f) (blk : blks) -> HardForkState f (blk : blks) forall a b. (a -> b) -> a -> b $ Current f blk -> Telescope (K Past) (Current f) (blk : blks) forall {k} (f :: k -> *) (x :: k) (g :: k -> *) (xs1 :: [k]). f x -> Telescope g f (x : xs1) TZ (Bound -> f blk -> Current f blk forall (f :: * -> *) blk. Bound -> f blk -> Current f blk Current Bound start f blk view) } afterKnownEnd :: Bound -> f blk' -> HardForkLedgerView_ f (blk : blk' : blks') afterKnownEnd :: forall (f :: * -> *) blk' (blks' :: [*]). Bound -> f blk' -> HardForkLedgerView_ f (blk : blk' : blks') afterKnownEnd Bound end f blk' view = HardForkLedgerView { hardForkLedgerViewTransition :: TransitionInfo hardForkLedgerViewTransition = -- We assume that we only ever have to translate to the /next/ era -- (as opposed to /any/ subsequent era) TransitionInfo TransitionImpossible , hardForkLedgerViewPerEra :: HardForkState f (blk : blk' : blks') hardForkLedgerViewPerEra = Telescope (K Past) (Current f) (blk : blk' : blks') -> HardForkState f (blk : blk' : blks') forall (f :: * -> *) (xs :: [*]). Telescope (K Past) (Current f) xs -> HardForkState f xs HardForkState (Telescope (K Past) (Current f) (blk : blk' : blks') -> HardForkState f (blk : blk' : blks')) -> Telescope (K Past) (Current f) (blk : blk' : blks') -> HardForkState f (blk : blk' : blks') forall a b. (a -> b) -> a -> b $ K Past blk -> Telescope (K Past) (Current f) (blk' : blks') -> Telescope (K Past) (Current f) (blk : blk' : blks') forall {k} (g :: k -> *) (x :: k) (f :: k -> *) (xs1 :: [k]). g x -> Telescope g f xs1 -> Telescope g f (x : xs1) TS (Past -> K Past blk forall k a (b :: k). a -> K a b K (Bound -> Bound -> Past Past Bound start Bound end)) (Telescope (K Past) (Current f) (blk' : blks') -> Telescope (K Past) (Current f) (blk : blk' : blks')) -> Telescope (K Past) (Current f) (blk' : blks') -> Telescope (K Past) (Current f) (blk : blk' : blks') forall a b. (a -> b) -> a -> b $ Current f blk' -> Telescope (K Past) (Current f) (blk' : blks') forall {k} (f :: k -> *) (x :: k) (g :: k -> *) (xs1 :: [k]). f x -> Telescope g f (x : xs1) TZ (Bound -> f blk' -> Current f blk' forall (f :: * -> *) blk. Bound -> f blk -> Current f blk Current Bound end f blk' view) } shiftView :: K Past blk -> HardForkLedgerView_ f blks -> HardForkLedgerView_ f (blk : blks) shiftView :: forall blk (f :: * -> *) (blks :: [*]). K Past blk -> HardForkLedgerView_ f blks -> HardForkLedgerView_ f (blk : blks) shiftView K Past blk past HardForkLedgerView{TransitionInfo HardForkState f blks hardForkLedgerViewTransition :: forall (f :: * -> *) (xs :: [*]). HardForkLedgerView_ f xs -> TransitionInfo hardForkLedgerViewPerEra :: forall (f :: * -> *) (xs :: [*]). HardForkLedgerView_ f xs -> HardForkState f xs hardForkLedgerViewTransition :: TransitionInfo hardForkLedgerViewPerEra :: HardForkState f blks ..} = HardForkLedgerView { hardForkLedgerViewTransition :: TransitionInfo hardForkLedgerViewTransition = TransitionInfo hardForkLedgerViewTransition , hardForkLedgerViewPerEra :: HardForkState f (blk : blks) hardForkLedgerViewPerEra = Telescope (K Past) (Current f) (blk : blks) -> HardForkState f (blk : blks) forall (f :: * -> *) (xs :: [*]). Telescope (K Past) (Current f) xs -> HardForkState f xs HardForkState (Telescope (K Past) (Current f) (blk : blks) -> HardForkState f (blk : blks)) -> (HardForkState f blks -> Telescope (K Past) (Current f) (blk : blks)) -> HardForkState f blks -> HardForkState f (blk : blks) forall b c a. (b -> c) -> (a -> b) -> a -> c . K Past blk -> Telescope (K Past) (Current f) blks -> Telescope (K Past) (Current f) (blk : blks) forall {k} (g :: k -> *) (x :: k) (f :: k -> *) (xs1 :: [k]). g x -> Telescope g f xs1 -> Telescope g f (x : xs1) TS K Past blk past (Telescope (K Past) (Current f) blks -> Telescope (K Past) (Current f) (blk : blks)) -> (HardForkState f blks -> Telescope (K Past) (Current f) blks) -> HardForkState f blks -> Telescope (K Past) (Current f) (blk : blks) forall b c a. (b -> c) -> (a -> b) -> a -> c . HardForkState f blks -> Telescope (K Past) (Current f) blks forall (f :: * -> *) (xs :: [*]). HardForkState f xs -> Telescope (K Past) (Current f) xs getHardForkState (HardForkState f blks -> HardForkState f (blk : blks)) -> HardForkState f blks -> HardForkState f (blk : blks) forall a b. (a -> b) -> a -> b $ HardForkState f blks hardForkLedgerViewPerEra } {------------------------------------------------------------------------------- Inspection -------------------------------------------------------------------------------} data HardForkLedgerWarning xs = -- | Warning from the underlying era HardForkWarningInEra (OneEraLedgerWarning xs) -- | The transition to the next era does not match the 'EraParams' -- -- The 'EraParams' can specify a lower bound on when the transition to the -- next era will happen. If the actual transition, when confirmed, is -- /before/ this lower bound, the node is misconfigured and will likely -- not work correctly. This should be taken care of as soon as possible -- (before the transition happens). | HardForkWarningTransitionMismatch (EraIndex xs) EraParams EpochNo -- | Transition in the final era -- -- The final era should never confirm any transitions. For clarity, we also -- record the index of that final era. | HardForkWarningTransitionInFinalEra (EraIndex xs) EpochNo -- | An already-confirmed transition got un-confirmed | HardForkWarningTransitionUnconfirmed (EraIndex xs) -- | An already-confirmed transition got changed -- -- We record the indices of the era we are transitioning from and to, -- as well as the old and new 'EpochNo' of that transition, in that order. | HardForkWarningTransitionReconfirmed (EraIndex xs) (EraIndex xs) EpochNo EpochNo data HardForkLedgerUpdate xs = HardForkUpdateInEra (OneEraLedgerUpdate xs) -- | Hard fork transition got confirmed | HardForkUpdateTransitionConfirmed (EraIndex xs) (EraIndex xs) EpochNo -- | Hard fork transition happened -- -- We record the 'EpochNo' at the start of the era after the transition | HardForkUpdateTransitionDone (EraIndex xs) (EraIndex xs) EpochNo -- | The hard fork transition rolled back | HardForkUpdateTransitionRolledBack (EraIndex xs) (EraIndex xs) deriving instance CanHardFork xs => Show (HardForkLedgerWarning xs) deriving instance CanHardFork xs => Eq (HardForkLedgerWarning xs) deriving instance CanHardFork xs => Show (HardForkLedgerUpdate xs) deriving instance CanHardFork xs => Eq (HardForkLedgerUpdate xs) instance CanHardFork xs => Condense (HardForkLedgerUpdate xs) where condense :: HardForkLedgerUpdate xs -> String condense (HardForkUpdateInEra (OneEraLedgerUpdate NS WrapLedgerUpdate xs update)) = NS (K String) xs -> CollapseTo NS String forall (xs :: [*]) a. SListIN NS xs => NS (K a) xs -> CollapseTo NS a forall k l (h :: (k -> *) -> l -> *) (xs :: l) a. (HCollapse h, SListIN h xs) => h (K a) xs -> CollapseTo h a hcollapse (NS (K String) xs -> CollapseTo NS String) -> NS (K String) xs -> CollapseTo NS String forall a b. (a -> b) -> a -> b $ Proxy SingleEraBlock -> (forall a. SingleEraBlock a => WrapLedgerUpdate a -> K String a) -> NS WrapLedgerUpdate xs -> NS (K String) xs forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint) (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *) (f' :: k -> *). (AllN (Prod h) c xs, HAp h) => proxy c -> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs hcmap Proxy SingleEraBlock proxySingle (String -> K String a forall k a (b :: k). a -> K a b K (String -> K String a) -> (WrapLedgerUpdate a -> String) -> WrapLedgerUpdate a -> K String a forall b c a. (b -> c) -> (a -> b) -> a -> c . LedgerUpdate a -> String forall a. Condense a => a -> String condense (LedgerUpdate a -> String) -> (WrapLedgerUpdate a -> LedgerUpdate a) -> WrapLedgerUpdate a -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . WrapLedgerUpdate a -> LedgerUpdate a forall blk. WrapLedgerUpdate blk -> LedgerUpdate blk unwrapLedgerUpdate) NS WrapLedgerUpdate xs update condense (HardForkUpdateTransitionConfirmed EraIndex xs ix EraIndex xs ix' EpochNo t) = String "confirmed " String -> ShowS forall a. [a] -> [a] -> [a] ++ (EraIndex xs, EraIndex xs, EpochNo) -> String forall a. Condense a => a -> String condense (EraIndex xs ix, EraIndex xs ix', EpochNo t) condense (HardForkUpdateTransitionDone EraIndex xs ix EraIndex xs ix' EpochNo e) = String "done " String -> ShowS forall a. [a] -> [a] -> [a] ++ (EraIndex xs, EraIndex xs, EpochNo) -> String forall a. Condense a => a -> String condense (EraIndex xs ix, EraIndex xs ix', EpochNo e) condense (HardForkUpdateTransitionRolledBack EraIndex xs ix EraIndex xs ix') = String "rolled back " String -> ShowS forall a. [a] -> [a] -> [a] ++ (EraIndex xs, EraIndex xs) -> String forall a. Condense a => a -> String condense (EraIndex xs ix, EraIndex xs ix') instance CanHardFork xs => InspectLedger (HardForkBlock xs) where type LedgerWarning (HardForkBlock xs) = HardForkLedgerWarning xs type LedgerUpdate (HardForkBlock xs) = HardForkLedgerUpdate xs inspectLedger :: TopLevelConfig (HardForkBlock xs) -> LedgerState (HardForkBlock xs) -> LedgerState (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)] inspectLedger TopLevelConfig (HardForkBlock xs) cfg (HardForkLedgerState HardForkState LedgerState xs before) (HardForkLedgerState HardForkState LedgerState xs after) = NP WrapPartialLedgerConfig xs -> NP (K EraParams) xs -> NP TopLevelConfig xs -> NS (Current LedgerState) xs -> NS (Current LedgerState) xs -> [LedgerEvent (HardForkBlock xs)] forall (xs :: [*]). CanHardFork xs => NP WrapPartialLedgerConfig xs -> NP (K EraParams) xs -> NP TopLevelConfig xs -> NS (Current LedgerState) xs -> NS (Current LedgerState) xs -> [LedgerEvent (HardForkBlock xs)] inspectHardForkLedger NP WrapPartialLedgerConfig xs pcfgs (Exactly xs EraParams -> NP (K EraParams) xs forall (xs :: [*]) a. Exactly xs a -> NP (K a) xs getExactly Exactly xs EraParams shape) NP TopLevelConfig xs cfgs (Telescope (K Past) (Current LedgerState) xs -> NS (Current LedgerState) xs forall {k} (g :: k -> *) (f :: k -> *) (xs :: [k]). Telescope g f xs -> NS f xs Telescope.tip (HardForkState LedgerState xs -> Telescope (K Past) (Current LedgerState) xs forall (f :: * -> *) (xs :: [*]). HardForkState f xs -> Telescope (K Past) (Current f) xs getHardForkState HardForkState LedgerState xs before)) (Telescope (K Past) (Current LedgerState) xs -> NS (Current LedgerState) xs forall {k} (g :: k -> *) (f :: k -> *) (xs :: [k]). Telescope g f xs -> NS f xs Telescope.tip (HardForkState LedgerState xs -> Telescope (K Past) (Current LedgerState) xs forall (f :: * -> *) (xs :: [*]). HardForkState f xs -> Telescope (K Past) (Current f) xs getHardForkState HardForkState LedgerState xs after)) where HardForkLedgerConfig{Shape xs PerEraLedgerConfig xs hardForkLedgerConfigShape :: forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs hardForkLedgerConfigPerEra :: forall (xs :: [*]). HardForkLedgerConfig xs -> PerEraLedgerConfig xs hardForkLedgerConfigShape :: Shape xs hardForkLedgerConfigPerEra :: PerEraLedgerConfig xs ..} = TopLevelConfig (HardForkBlock xs) -> LedgerConfig (HardForkBlock xs) forall blk. TopLevelConfig blk -> LedgerConfig blk configLedger TopLevelConfig (HardForkBlock xs) cfg pcfgs :: NP WrapPartialLedgerConfig xs pcfgs = PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs forall (xs :: [*]). PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs getPerEraLedgerConfig PerEraLedgerConfig xs hardForkLedgerConfigPerEra shape :: Exactly xs EraParams shape = Shape xs -> Exactly xs EraParams forall (xs :: [*]). Shape xs -> Exactly xs EraParams History.getShape Shape xs hardForkLedgerConfigShape cfgs :: NP TopLevelConfig xs cfgs = EpochInfo (Except PastHorizonException) -> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs forall (xs :: [*]). All SingleEraBlock xs => EpochInfo (Except PastHorizonException) -> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs distribTopLevelConfig EpochInfo (Except PastHorizonException) ei TopLevelConfig (HardForkBlock xs) cfg ei :: EpochInfo (Except PastHorizonException) ei = HardForkLedgerConfig xs -> HardForkState LedgerState xs -> EpochInfo (Except PastHorizonException) forall (xs :: [*]). All SingleEraBlock xs => HardForkLedgerConfig xs -> HardForkState LedgerState xs -> EpochInfo (Except PastHorizonException) State.epochInfoLedger (TopLevelConfig (HardForkBlock xs) -> LedgerConfig (HardForkBlock xs) forall blk. TopLevelConfig blk -> LedgerConfig blk configLedger TopLevelConfig (HardForkBlock xs) cfg) HardForkState LedgerState xs after inspectHardForkLedger :: CanHardFork xs => NP WrapPartialLedgerConfig xs -> NP (K EraParams) xs -> NP TopLevelConfig xs -> NS (Current LedgerState) xs -> NS (Current LedgerState) xs -> [LedgerEvent (HardForkBlock xs)] inspectHardForkLedger :: forall (xs :: [*]). CanHardFork xs => NP WrapPartialLedgerConfig xs -> NP (K EraParams) xs -> NP TopLevelConfig xs -> NS (Current LedgerState) xs -> NS (Current LedgerState) xs -> [LedgerEvent (HardForkBlock xs)] inspectHardForkLedger = NP WrapPartialLedgerConfig xs -> NP (K EraParams) xs -> NP TopLevelConfig xs -> NS (Current LedgerState) xs -> NS (Current LedgerState) xs -> [LedgerEvent (HardForkBlock xs)] forall (xs :: [*]). All SingleEraBlock xs => NP WrapPartialLedgerConfig xs -> NP (K EraParams) xs -> NP TopLevelConfig xs -> NS (Current LedgerState) xs -> NS (Current LedgerState) xs -> [LedgerEvent (HardForkBlock xs)] go where go :: All SingleEraBlock xs => NP WrapPartialLedgerConfig xs -> NP (K EraParams) xs -> NP TopLevelConfig xs -> NS (Current LedgerState) xs -> NS (Current LedgerState) xs -> [LedgerEvent (HardForkBlock xs)] go :: forall (xs :: [*]). All SingleEraBlock xs => NP WrapPartialLedgerConfig xs -> NP (K EraParams) xs -> NP TopLevelConfig xs -> NS (Current LedgerState) xs -> NS (Current LedgerState) xs -> [LedgerEvent (HardForkBlock xs)] go (WrapPartialLedgerConfig x pc :* NP WrapPartialLedgerConfig xs1 _) (K EraParams ps :* NP (K EraParams) xs1 pss) (TopLevelConfig x c :* NP TopLevelConfig xs1 _) (Z Current LedgerState x before) (Z Current LedgerState x after) = [[LedgerEvent (HardForkBlock xs)]] -> [LedgerEvent (HardForkBlock xs)] forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat [ (LedgerEvent x -> LedgerEvent (HardForkBlock xs)) -> [LedgerEvent x] -> [LedgerEvent (HardForkBlock xs)] forall a b. (a -> b) -> [a] -> [b] map LedgerEvent x -> LedgerEvent (HardForkBlock xs) LedgerEvent x -> LedgerEvent (HardForkBlock (x : xs1)) forall x (xs :: [*]). LedgerEvent x -> LedgerEvent (HardForkBlock (x : xs)) liftEvent ([LedgerEvent x] -> [LedgerEvent (HardForkBlock xs)]) -> [LedgerEvent x] -> [LedgerEvent (HardForkBlock xs)] forall a b. (a -> b) -> a -> b $ TopLevelConfig x -> LedgerState x -> LedgerState x -> [LedgerEvent x] forall blk. InspectLedger blk => TopLevelConfig blk -> LedgerState blk -> LedgerState blk -> [LedgerEvent blk] inspectLedger TopLevelConfig x c (Current LedgerState x -> LedgerState x forall (f :: * -> *) blk. Current f blk -> f blk currentState Current LedgerState x Current LedgerState x before) (Current LedgerState x -> LedgerState x forall (f :: * -> *) blk. Current f blk -> f blk currentState Current LedgerState x Current LedgerState x after) , case (NP (K EraParams) xs1 pss, Maybe EpochNo confirmedBefore, Maybe EpochNo confirmedAfter) of (NP (K EraParams) xs1 _, Maybe EpochNo Nothing, Maybe EpochNo Nothing) -> [] (NP (K EraParams) xs1 _, Just EpochNo _, Maybe EpochNo Nothing) -> -- TODO: This should be a warning, but this can currently happen -- in Byron. [] -- return $ LedgerWarning $ -- HardForkWarningTransitionUnconfirmed eraIndexZero (NP (K EraParams) xs1 Nil, Maybe EpochNo Nothing, Just EpochNo transition) -> LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)] forall a. a -> [a] forall (m :: * -> *) a. Monad m => a -> m a return (LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)]) -> LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)] forall a b. (a -> b) -> a -> b $ LedgerWarning (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs) forall blk. LedgerWarning blk -> LedgerEvent blk LedgerWarning (LedgerWarning (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs)) -> LedgerWarning (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs) forall a b. (a -> b) -> a -> b $ EraIndex '[x] -> EpochNo -> HardForkLedgerWarning '[x] forall (xs :: [*]). EraIndex xs -> EpochNo -> HardForkLedgerWarning xs HardForkWarningTransitionInFinalEra EraIndex '[x] forall x (xs :: [*]). EraIndex (x : xs) eraIndexZero EpochNo transition (NP (K EraParams) xs1 Nil, Just EpochNo transition, Just EpochNo transition') -> do -- Only warn if the transition has changed Bool -> [()] forall (f :: * -> *). Alternative f => Bool -> f () guard (EpochNo transition EpochNo -> EpochNo -> Bool forall a. Eq a => a -> a -> Bool /= EpochNo transition') LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)] forall a. a -> [a] forall (m :: * -> *) a. Monad m => a -> m a return (LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)]) -> LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)] forall a b. (a -> b) -> a -> b $ LedgerWarning (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs) forall blk. LedgerWarning blk -> LedgerEvent blk LedgerWarning (LedgerWarning (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs)) -> LedgerWarning (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs) forall a b. (a -> b) -> a -> b $ EraIndex '[x] -> EpochNo -> HardForkLedgerWarning '[x] forall (xs :: [*]). EraIndex xs -> EpochNo -> HardForkLedgerWarning xs HardForkWarningTransitionInFinalEra EraIndex '[x] forall x (xs :: [*]). EraIndex (x : xs) eraIndexZero EpochNo transition ((:*){}, Maybe EpochNo Nothing, Just EpochNo transition) -> LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)] forall a. a -> [a] forall (m :: * -> *) a. Monad m => a -> m a return (LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)]) -> LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)] forall a b. (a -> b) -> a -> b $ if SafeZone -> Bool validLowerBound (EraParams -> SafeZone History.eraSafeZone EraParams ps) then LedgerUpdate (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs) forall blk. LedgerUpdate blk -> LedgerEvent blk LedgerUpdate (LedgerUpdate (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs)) -> LedgerUpdate (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs) forall a b. (a -> b) -> a -> b $ EraIndex (x : x : xs1) -> EraIndex (x : x : xs1) -> EpochNo -> HardForkLedgerUpdate (x : x : xs1) forall (xs :: [*]). EraIndex xs -> EraIndex xs -> EpochNo -> HardForkLedgerUpdate xs HardForkUpdateTransitionConfirmed EraIndex (x : x : xs1) forall x (xs :: [*]). EraIndex (x : xs) eraIndexZero (EraIndex (x : xs1) -> EraIndex (x : x : xs1) forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs) eraIndexSucc EraIndex (x : xs1) forall x (xs :: [*]). EraIndex (x : xs) eraIndexZero) EpochNo transition else LedgerWarning (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs) forall blk. LedgerWarning blk -> LedgerEvent blk LedgerWarning (LedgerWarning (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs)) -> LedgerWarning (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs) forall a b. (a -> b) -> a -> b $ EraIndex (x : x : xs1) -> EraParams -> EpochNo -> HardForkLedgerWarning (x : x : xs1) forall (xs :: [*]). EraIndex xs -> EraParams -> EpochNo -> HardForkLedgerWarning xs HardForkWarningTransitionMismatch EraIndex (x : x : xs1) forall x (xs :: [*]). EraIndex (x : xs) eraIndexZero EraParams ps EpochNo transition ((:*){}, Just EpochNo transition, Just EpochNo transition') -> do Bool -> [()] forall (f :: * -> *). Alternative f => Bool -> f () guard (EpochNo transition EpochNo -> EpochNo -> Bool forall a. Eq a => a -> a -> Bool /= EpochNo transition') LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)] forall a. a -> [a] forall (m :: * -> *) a. Monad m => a -> m a return (LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)]) -> LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)] forall a b. (a -> b) -> a -> b $ LedgerWarning (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs) forall blk. LedgerWarning blk -> LedgerEvent blk LedgerWarning (LedgerWarning (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs)) -> LedgerWarning (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs) forall a b. (a -> b) -> a -> b $ EraIndex (x : x : xs1) -> EraIndex (x : x : xs1) -> EpochNo -> EpochNo -> HardForkLedgerWarning (x : x : xs1) forall (xs :: [*]). EraIndex xs -> EraIndex xs -> EpochNo -> EpochNo -> HardForkLedgerWarning xs HardForkWarningTransitionReconfirmed EraIndex (x : x : xs1) forall x (xs :: [*]). EraIndex (x : xs) eraIndexZero (EraIndex (x : xs1) -> EraIndex (x : x : xs1) forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs) eraIndexSucc EraIndex (x : xs1) forall x (xs :: [*]). EraIndex (x : xs) eraIndexZero) EpochNo transition EpochNo transition' ] where confirmedBefore, confirmedAfter :: Maybe EpochNo confirmedBefore :: Maybe EpochNo confirmedBefore = PartialLedgerConfig x -> EraParams -> Bound -> LedgerState x -> Maybe EpochNo forall blk. SingleEraBlock blk => PartialLedgerConfig blk -> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo singleEraTransition (WrapPartialLedgerConfig x -> PartialLedgerConfig x forall blk. WrapPartialLedgerConfig blk -> PartialLedgerConfig blk unwrapPartialLedgerConfig WrapPartialLedgerConfig x pc) EraParams ps (Current LedgerState x -> Bound forall (f :: * -> *) blk. Current f blk -> Bound currentStart Current LedgerState x before) (Current LedgerState x -> LedgerState x forall (f :: * -> *) blk. Current f blk -> f blk currentState Current LedgerState x before) confirmedAfter :: Maybe EpochNo confirmedAfter = PartialLedgerConfig x -> EraParams -> Bound -> LedgerState x -> Maybe EpochNo forall blk. SingleEraBlock blk => PartialLedgerConfig blk -> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo singleEraTransition (WrapPartialLedgerConfig x -> PartialLedgerConfig x forall blk. WrapPartialLedgerConfig blk -> PartialLedgerConfig blk unwrapPartialLedgerConfig WrapPartialLedgerConfig x pc) EraParams ps (Current LedgerState x -> Bound forall (f :: * -> *) blk. Current f blk -> Bound currentStart Current LedgerState x after) (Current LedgerState x -> LedgerState x forall (f :: * -> *) blk. Current f blk -> f blk currentState Current LedgerState x after) go NP WrapPartialLedgerConfig xs Nil NP (K EraParams) xs _ NP TopLevelConfig xs _ NS (Current LedgerState) xs before NS (Current LedgerState) xs _ = case NS (Current LedgerState) xs before of {} go (WrapPartialLedgerConfig x _ :* NP WrapPartialLedgerConfig xs1 pcs) (K EraParams x _ :* NP (K EraParams) xs1 pss) (TopLevelConfig x _ :* NP TopLevelConfig xs1 cs) (S NS (Current LedgerState) xs1 before) (S NS (Current LedgerState) xs1 after) = (LedgerEvent (HardForkBlock xs1) -> LedgerEvent (HardForkBlock xs)) -> [LedgerEvent (HardForkBlock xs1)] -> [LedgerEvent (HardForkBlock xs)] forall a b. (a -> b) -> [a] -> [b] map LedgerEvent (HardForkBlock xs1) -> LedgerEvent (HardForkBlock xs) LedgerEvent (HardForkBlock xs1) -> LedgerEvent (HardForkBlock (x : xs1)) forall (xs :: [*]) x. LedgerEvent (HardForkBlock xs) -> LedgerEvent (HardForkBlock (x : xs)) shiftEvent ([LedgerEvent (HardForkBlock xs1)] -> [LedgerEvent (HardForkBlock xs)]) -> [LedgerEvent (HardForkBlock xs1)] -> [LedgerEvent (HardForkBlock xs)] forall a b. (a -> b) -> a -> b $ NP WrapPartialLedgerConfig xs1 -> NP (K EraParams) xs1 -> NP TopLevelConfig xs1 -> NS (Current LedgerState) xs1 -> NS (Current LedgerState) xs1 -> [LedgerEvent (HardForkBlock xs1)] forall (xs :: [*]). All SingleEraBlock xs => NP WrapPartialLedgerConfig xs -> NP (K EraParams) xs -> NP TopLevelConfig xs -> NS (Current LedgerState) xs -> NS (Current LedgerState) xs -> [LedgerEvent (HardForkBlock xs)] go NP WrapPartialLedgerConfig xs1 pcs NP (K EraParams) xs1 NP (K EraParams) xs1 pss NP TopLevelConfig xs1 NP TopLevelConfig xs1 cs NS (Current LedgerState) xs1 NS (Current LedgerState) xs1 before NS (Current LedgerState) xs1 NS (Current LedgerState) xs1 after go NP WrapPartialLedgerConfig xs _ NP (K EraParams) xs _ NP TopLevelConfig xs _ (Z Current LedgerState x _) (S NS (Current LedgerState) xs1 after) = LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)] forall a. a -> [a] forall (m :: * -> *) a. Monad m => a -> m a return (LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)]) -> LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)] forall a b. (a -> b) -> a -> b $ LedgerUpdate (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs) forall blk. LedgerUpdate blk -> LedgerEvent blk LedgerUpdate (LedgerUpdate (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs)) -> LedgerUpdate (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs) forall a b. (a -> b) -> a -> b $ EraIndex (x : xs1) -> EraIndex (x : xs1) -> EpochNo -> HardForkLedgerUpdate (x : xs1) forall (xs :: [*]). EraIndex xs -> EraIndex xs -> EpochNo -> HardForkLedgerUpdate xs HardForkUpdateTransitionDone EraIndex (x : xs1) forall x (xs :: [*]). EraIndex (x : xs) eraIndexZero (EraIndex xs1 -> EraIndex (x : xs1) forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs) eraIndexSucc (EraIndex xs1 -> EraIndex (x : xs1)) -> EraIndex xs1 -> EraIndex (x : xs1) forall a b. (a -> b) -> a -> b $ NS (Current LedgerState) xs1 -> EraIndex xs1 forall (xs :: [*]) (f :: * -> *). SListI xs => NS f xs -> EraIndex xs eraIndexFromNS NS (Current LedgerState) xs1 after) (NS (K EpochNo) xs1 -> CollapseTo NS EpochNo forall (xs :: [*]) a. SListIN NS xs => NS (K a) xs -> CollapseTo NS a forall k l (h :: (k -> *) -> l -> *) (xs :: l) a. (HCollapse h, SListIN h xs) => h (K a) xs -> CollapseTo h a hcollapse (NS (K EpochNo) xs1 -> CollapseTo NS EpochNo) -> NS (K EpochNo) xs1 -> CollapseTo NS EpochNo forall a b. (a -> b) -> a -> b $ (forall a. Current LedgerState a -> K EpochNo a) -> NS (Current LedgerState) xs1 -> NS (K EpochNo) xs1 forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *) (f' :: k -> *). (SListIN (Prod h) xs, HAp h) => (forall (a :: k). f a -> f' a) -> h f xs -> h f' xs hmap (EpochNo -> K EpochNo a forall k a (b :: k). a -> K a b K (EpochNo -> K EpochNo a) -> (Current LedgerState a -> EpochNo) -> Current LedgerState a -> K EpochNo a forall b c a. (b -> c) -> (a -> b) -> a -> c . Bound -> EpochNo boundEpoch (Bound -> EpochNo) -> (Current LedgerState a -> Bound) -> Current LedgerState a -> EpochNo forall b c a. (b -> c) -> (a -> b) -> a -> c . Current LedgerState a -> Bound forall (f :: * -> *) blk. Current f blk -> Bound currentStart) NS (Current LedgerState) xs1 after) go NP WrapPartialLedgerConfig xs _ NP (K EraParams) xs _ NP TopLevelConfig xs _ (S NS (Current LedgerState) xs1 before) (Z Current LedgerState x _) = LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)] forall a. a -> [a] forall (m :: * -> *) a. Monad m => a -> m a return (LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)]) -> LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)] forall a b. (a -> b) -> a -> b $ LedgerUpdate (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs) forall blk. LedgerUpdate blk -> LedgerEvent blk LedgerUpdate (LedgerUpdate (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs)) -> LedgerUpdate (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs) forall a b. (a -> b) -> a -> b $ EraIndex (x : xs1) -> EraIndex (x : xs1) -> HardForkLedgerUpdate (x : xs1) forall (xs :: [*]). EraIndex xs -> EraIndex xs -> HardForkLedgerUpdate xs HardForkUpdateTransitionRolledBack (EraIndex xs1 -> EraIndex (x : xs1) forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs) eraIndexSucc (EraIndex xs1 -> EraIndex (x : xs1)) -> EraIndex xs1 -> EraIndex (x : xs1) forall a b. (a -> b) -> a -> b $ NS (Current LedgerState) xs1 -> EraIndex xs1 forall (xs :: [*]) (f :: * -> *). SListI xs => NS f xs -> EraIndex xs eraIndexFromNS NS (Current LedgerState) xs1 before) EraIndex (x : xs1) forall x (xs :: [*]). EraIndex (x : xs) eraIndexZero validLowerBound :: SafeZone -> Bool validLowerBound :: SafeZone -> Bool validLowerBound (StandardSafeZone Word64 _) = Bool True validLowerBound SafeZone UnsafeIndefiniteSafeZone = Bool False {------------------------------------------------------------------------------- Internal auxiliary: lifting and shifting events -------------------------------------------------------------------------------} liftEvent :: LedgerEvent x -> LedgerEvent (HardForkBlock (x ': xs)) liftEvent :: forall x (xs :: [*]). LedgerEvent x -> LedgerEvent (HardForkBlock (x : xs)) liftEvent (LedgerWarning LedgerWarning x warning) = LedgerWarning (HardForkBlock (x : xs)) -> LedgerEvent (HardForkBlock (x : xs)) forall blk. LedgerWarning blk -> LedgerEvent blk LedgerWarning (LedgerWarning (HardForkBlock (x : xs)) -> LedgerEvent (HardForkBlock (x : xs))) -> LedgerWarning (HardForkBlock (x : xs)) -> LedgerEvent (HardForkBlock (x : xs)) forall a b. (a -> b) -> a -> b $ LedgerWarning x -> HardForkLedgerWarning (x : xs) forall x (xs :: [*]). LedgerWarning x -> HardForkLedgerWarning (x : xs) liftWarning LedgerWarning x warning liftEvent (LedgerUpdate LedgerUpdate x update) = LedgerUpdate (HardForkBlock (x : xs)) -> LedgerEvent (HardForkBlock (x : xs)) forall blk. LedgerUpdate blk -> LedgerEvent blk LedgerUpdate (LedgerUpdate (HardForkBlock (x : xs)) -> LedgerEvent (HardForkBlock (x : xs))) -> LedgerUpdate (HardForkBlock (x : xs)) -> LedgerEvent (HardForkBlock (x : xs)) forall a b. (a -> b) -> a -> b $ LedgerUpdate x -> HardForkLedgerUpdate (x : xs) forall x (xs :: [*]). LedgerUpdate x -> HardForkLedgerUpdate (x : xs) liftUpdate LedgerUpdate x update liftWarning :: LedgerWarning x -> HardForkLedgerWarning (x ': xs) liftWarning :: forall x (xs :: [*]). LedgerWarning x -> HardForkLedgerWarning (x : xs) liftWarning = OneEraLedgerWarning (x : xs) -> HardForkLedgerWarning (x : xs) forall (xs :: [*]). OneEraLedgerWarning xs -> HardForkLedgerWarning xs HardForkWarningInEra (OneEraLedgerWarning (x : xs) -> HardForkLedgerWarning (x : xs)) -> (LedgerWarning x -> OneEraLedgerWarning (x : xs)) -> LedgerWarning x -> HardForkLedgerWarning (x : xs) forall b c a. (b -> c) -> (a -> b) -> a -> c . NS WrapLedgerWarning (x : xs) -> OneEraLedgerWarning (x : xs) forall (xs :: [*]). NS WrapLedgerWarning xs -> OneEraLedgerWarning xs OneEraLedgerWarning (NS WrapLedgerWarning (x : xs) -> OneEraLedgerWarning (x : xs)) -> (LedgerWarning x -> NS WrapLedgerWarning (x : xs)) -> LedgerWarning x -> OneEraLedgerWarning (x : xs) forall b c a. (b -> c) -> (a -> b) -> a -> c . WrapLedgerWarning x -> NS WrapLedgerWarning (x : xs) forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]). f x -> NS f (x : xs1) Z (WrapLedgerWarning x -> NS WrapLedgerWarning (x : xs)) -> (LedgerWarning x -> WrapLedgerWarning x) -> LedgerWarning x -> NS WrapLedgerWarning (x : xs) forall b c a. (b -> c) -> (a -> b) -> a -> c . LedgerWarning x -> WrapLedgerWarning x forall blk. LedgerWarning blk -> WrapLedgerWarning blk WrapLedgerWarning liftUpdate :: LedgerUpdate x -> HardForkLedgerUpdate (x ': xs) liftUpdate :: forall x (xs :: [*]). LedgerUpdate x -> HardForkLedgerUpdate (x : xs) liftUpdate = OneEraLedgerUpdate (x : xs) -> HardForkLedgerUpdate (x : xs) forall (xs :: [*]). OneEraLedgerUpdate xs -> HardForkLedgerUpdate xs HardForkUpdateInEra (OneEraLedgerUpdate (x : xs) -> HardForkLedgerUpdate (x : xs)) -> (LedgerUpdate x -> OneEraLedgerUpdate (x : xs)) -> LedgerUpdate x -> HardForkLedgerUpdate (x : xs) forall b c a. (b -> c) -> (a -> b) -> a -> c . NS WrapLedgerUpdate (x : xs) -> OneEraLedgerUpdate (x : xs) forall (xs :: [*]). NS WrapLedgerUpdate xs -> OneEraLedgerUpdate xs OneEraLedgerUpdate (NS WrapLedgerUpdate (x : xs) -> OneEraLedgerUpdate (x : xs)) -> (LedgerUpdate x -> NS WrapLedgerUpdate (x : xs)) -> LedgerUpdate x -> OneEraLedgerUpdate (x : xs) forall b c a. (b -> c) -> (a -> b) -> a -> c . WrapLedgerUpdate x -> NS WrapLedgerUpdate (x : xs) forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]). f x -> NS f (x : xs1) Z (WrapLedgerUpdate x -> NS WrapLedgerUpdate (x : xs)) -> (LedgerUpdate x -> WrapLedgerUpdate x) -> LedgerUpdate x -> NS WrapLedgerUpdate (x : xs) forall b c a. (b -> c) -> (a -> b) -> a -> c . LedgerUpdate x -> WrapLedgerUpdate x forall blk. LedgerUpdate blk -> WrapLedgerUpdate blk WrapLedgerUpdate shiftEvent :: LedgerEvent (HardForkBlock xs) -> LedgerEvent (HardForkBlock (x ': xs)) shiftEvent :: forall (xs :: [*]) x. LedgerEvent (HardForkBlock xs) -> LedgerEvent (HardForkBlock (x : xs)) shiftEvent (LedgerWarning LedgerWarning (HardForkBlock xs) warning) = LedgerWarning (HardForkBlock (x : xs)) -> LedgerEvent (HardForkBlock (x : xs)) forall blk. LedgerWarning blk -> LedgerEvent blk LedgerWarning (LedgerWarning (HardForkBlock (x : xs)) -> LedgerEvent (HardForkBlock (x : xs))) -> LedgerWarning (HardForkBlock (x : xs)) -> LedgerEvent (HardForkBlock (x : xs)) forall a b. (a -> b) -> a -> b $ HardForkLedgerWarning xs -> HardForkLedgerWarning (x : xs) forall (xs :: [*]) x. HardForkLedgerWarning xs -> HardForkLedgerWarning (x : xs) shiftWarning LedgerWarning (HardForkBlock xs) HardForkLedgerWarning xs warning shiftEvent (LedgerUpdate LedgerUpdate (HardForkBlock xs) update) = LedgerUpdate (HardForkBlock (x : xs)) -> LedgerEvent (HardForkBlock (x : xs)) forall blk. LedgerUpdate blk -> LedgerEvent blk LedgerUpdate (LedgerUpdate (HardForkBlock (x : xs)) -> LedgerEvent (HardForkBlock (x : xs))) -> LedgerUpdate (HardForkBlock (x : xs)) -> LedgerEvent (HardForkBlock (x : xs)) forall a b. (a -> b) -> a -> b $ HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x : xs) forall (xs :: [*]) x. HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x : xs) shiftUpdate LedgerUpdate (HardForkBlock xs) HardForkLedgerUpdate xs update shiftWarning :: HardForkLedgerWarning xs -> HardForkLedgerWarning (x ': xs) shiftWarning :: forall (xs :: [*]) x. HardForkLedgerWarning xs -> HardForkLedgerWarning (x : xs) shiftWarning = HardForkLedgerWarning xs -> HardForkLedgerWarning (x : xs) forall (xs :: [*]) x. HardForkLedgerWarning xs -> HardForkLedgerWarning (x : xs) go where go :: HardForkLedgerWarning xs1 -> HardForkLedgerWarning (x : xs1) go (HardForkWarningInEra (OneEraLedgerWarning NS WrapLedgerWarning xs1 warning)) = OneEraLedgerWarning (x : xs1) -> HardForkLedgerWarning (x : xs1) forall (xs :: [*]). OneEraLedgerWarning xs -> HardForkLedgerWarning xs HardForkWarningInEra (NS WrapLedgerWarning (x : xs1) -> OneEraLedgerWarning (x : xs1) forall (xs :: [*]). NS WrapLedgerWarning xs -> OneEraLedgerWarning xs OneEraLedgerWarning (NS WrapLedgerWarning xs1 -> NS WrapLedgerWarning (x : xs1) forall {k} (f :: k -> *) (xs1 :: [k]) (x :: k). NS f xs1 -> NS f (x : xs1) S NS WrapLedgerWarning xs1 warning)) go (HardForkWarningTransitionMismatch EraIndex xs1 ix EraParams ps EpochNo t) = EraIndex (x : xs1) -> EraParams -> EpochNo -> HardForkLedgerWarning (x : xs1) forall (xs :: [*]). EraIndex xs -> EraParams -> EpochNo -> HardForkLedgerWarning xs HardForkWarningTransitionMismatch (EraIndex xs1 -> EraIndex (x : xs1) forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs) eraIndexSucc EraIndex xs1 ix) EraParams ps EpochNo t go (HardForkWarningTransitionInFinalEra EraIndex xs1 ix EpochNo t) = EraIndex (x : xs1) -> EpochNo -> HardForkLedgerWarning (x : xs1) forall (xs :: [*]). EraIndex xs -> EpochNo -> HardForkLedgerWarning xs HardForkWarningTransitionInFinalEra (EraIndex xs1 -> EraIndex (x : xs1) forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs) eraIndexSucc EraIndex xs1 ix) EpochNo t go (HardForkWarningTransitionUnconfirmed EraIndex xs1 ix) = EraIndex (x : xs1) -> HardForkLedgerWarning (x : xs1) forall (xs :: [*]). EraIndex xs -> HardForkLedgerWarning xs HardForkWarningTransitionUnconfirmed (EraIndex xs1 -> EraIndex (x : xs1) forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs) eraIndexSucc EraIndex xs1 ix) go (HardForkWarningTransitionReconfirmed EraIndex xs1 ix EraIndex xs1 ix' EpochNo t EpochNo t') = EraIndex (x : xs1) -> EraIndex (x : xs1) -> EpochNo -> EpochNo -> HardForkLedgerWarning (x : xs1) forall (xs :: [*]). EraIndex xs -> EraIndex xs -> EpochNo -> EpochNo -> HardForkLedgerWarning xs HardForkWarningTransitionReconfirmed (EraIndex xs1 -> EraIndex (x : xs1) forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs) eraIndexSucc EraIndex xs1 ix) (EraIndex xs1 -> EraIndex (x : xs1) forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs) eraIndexSucc EraIndex xs1 ix') EpochNo t EpochNo t' shiftUpdate :: HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x ': xs) shiftUpdate :: forall (xs :: [*]) x. HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x : xs) shiftUpdate = HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x : xs) forall (xs :: [*]) x. HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x : xs) go where go :: HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x ': xs) go :: forall (xs :: [*]) x. HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x : xs) go (HardForkUpdateInEra (OneEraLedgerUpdate NS WrapLedgerUpdate xs update)) = OneEraLedgerUpdate (x : xs) -> HardForkLedgerUpdate (x : xs) forall (xs :: [*]). OneEraLedgerUpdate xs -> HardForkLedgerUpdate xs HardForkUpdateInEra (NS WrapLedgerUpdate (x : xs) -> OneEraLedgerUpdate (x : xs) forall (xs :: [*]). NS WrapLedgerUpdate xs -> OneEraLedgerUpdate xs OneEraLedgerUpdate (NS WrapLedgerUpdate xs -> NS WrapLedgerUpdate (x : xs) forall {k} (f :: k -> *) (xs1 :: [k]) (x :: k). NS f xs1 -> NS f (x : xs1) S NS WrapLedgerUpdate xs update)) go (HardForkUpdateTransitionConfirmed EraIndex xs ix EraIndex xs ix' EpochNo t) = EraIndex (x : xs) -> EraIndex (x : xs) -> EpochNo -> HardForkLedgerUpdate (x : xs) forall (xs :: [*]). EraIndex xs -> EraIndex xs -> EpochNo -> HardForkLedgerUpdate xs HardForkUpdateTransitionConfirmed (EraIndex xs -> EraIndex (x : xs) forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs) eraIndexSucc EraIndex xs ix) (EraIndex xs -> EraIndex (x : xs) forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs) eraIndexSucc EraIndex xs ix') EpochNo t go (HardForkUpdateTransitionDone EraIndex xs ix EraIndex xs ix' EpochNo e) = EraIndex (x : xs) -> EraIndex (x : xs) -> EpochNo -> HardForkLedgerUpdate (x : xs) forall (xs :: [*]). EraIndex xs -> EraIndex xs -> EpochNo -> HardForkLedgerUpdate xs HardForkUpdateTransitionDone (EraIndex xs -> EraIndex (x : xs) forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs) eraIndexSucc EraIndex xs ix) (EraIndex xs -> EraIndex (x : xs) forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs) eraIndexSucc EraIndex xs ix') EpochNo e go (HardForkUpdateTransitionRolledBack EraIndex xs ix EraIndex xs ix') = EraIndex (x : xs) -> EraIndex (x : xs) -> HardForkLedgerUpdate (x : xs) forall (xs :: [*]). EraIndex xs -> EraIndex xs -> HardForkLedgerUpdate xs HardForkUpdateTransitionRolledBack (EraIndex xs -> EraIndex (x : xs) forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs) eraIndexSucc EraIndex xs ix) (EraIndex xs -> EraIndex (x : xs) forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs) eraIndexSucc EraIndex xs ix') {------------------------------------------------------------------------------- Auxiliary -------------------------------------------------------------------------------} ledgerInfo :: forall blk. SingleEraBlock blk => Current (Ticked :.: LedgerState) blk -> LedgerEraInfo blk ledgerInfo :: forall x. SingleEraBlock x => Current (Ticked :.: LedgerState) x -> LedgerEraInfo x ledgerInfo Current (Ticked :.: LedgerState) blk _ = SingleEraInfo blk -> LedgerEraInfo blk forall blk. SingleEraInfo blk -> LedgerEraInfo blk LedgerEraInfo (SingleEraInfo blk -> LedgerEraInfo blk) -> SingleEraInfo blk -> LedgerEraInfo blk forall a b. (a -> b) -> a -> b $ Proxy blk -> SingleEraInfo blk forall blk (proxy :: * -> *). SingleEraBlock blk => proxy blk -> SingleEraInfo blk forall (proxy :: * -> *). proxy blk -> SingleEraInfo blk singleEraInfo (forall t. Proxy t forall {k} (t :: k). Proxy t Proxy @blk) ledgerViewInfo :: forall blk f. SingleEraBlock blk => f blk -> LedgerEraInfo blk ledgerViewInfo :: forall blk (f :: * -> *). SingleEraBlock blk => f blk -> LedgerEraInfo blk ledgerViewInfo f blk _ = SingleEraInfo blk -> LedgerEraInfo blk forall blk. SingleEraInfo blk -> LedgerEraInfo blk LedgerEraInfo (SingleEraInfo blk -> LedgerEraInfo blk) -> SingleEraInfo blk -> LedgerEraInfo blk forall a b. (a -> b) -> a -> b $ Proxy blk -> SingleEraInfo blk forall blk (proxy :: * -> *). SingleEraBlock blk => proxy blk -> SingleEraInfo blk forall (proxy :: * -> *). proxy blk -> SingleEraInfo blk singleEraInfo (forall t. Proxy t forall {k} (t :: k). Proxy t Proxy @blk) injectLedgerError :: Index xs blk -> LedgerError blk -> HardForkLedgerError xs injectLedgerError :: forall (xs :: [*]) blk. Index xs blk -> LedgerError blk -> HardForkLedgerError xs injectLedgerError Index xs blk index = OneEraLedgerError xs -> HardForkLedgerError xs forall (xs :: [*]). OneEraLedgerError xs -> HardForkLedgerError xs HardForkLedgerErrorFromEra (OneEraLedgerError xs -> HardForkLedgerError xs) -> (LedgerErr (LedgerState blk) -> OneEraLedgerError xs) -> LedgerErr (LedgerState blk) -> HardForkLedgerError xs forall b c a. (b -> c) -> (a -> b) -> a -> c . NS WrapLedgerErr xs -> OneEraLedgerError xs forall (xs :: [*]). NS WrapLedgerErr xs -> OneEraLedgerError xs OneEraLedgerError (NS WrapLedgerErr xs -> OneEraLedgerError xs) -> (LedgerErr (LedgerState blk) -> NS WrapLedgerErr xs) -> LedgerErr (LedgerState blk) -> OneEraLedgerError xs forall b c a. (b -> c) -> (a -> b) -> a -> c . Index xs blk -> WrapLedgerErr blk -> NS WrapLedgerErr xs forall {k} (f :: k -> *) (x :: k) (xs :: [k]). Index xs x -> f x -> NS f xs injectNS Index xs blk index (WrapLedgerErr blk -> NS WrapLedgerErr xs) -> (LedgerErr (LedgerState blk) -> WrapLedgerErr blk) -> LedgerErr (LedgerState blk) -> NS WrapLedgerErr xs forall b c a. (b -> c) -> (a -> b) -> a -> c . LedgerErr (LedgerState blk) -> WrapLedgerErr blk forall blk. LedgerError blk -> WrapLedgerErr blk WrapLedgerErr injectLedgerEvent :: Index xs blk -> AuxLedgerEvent (LedgerState blk) -> OneEraLedgerEvent xs injectLedgerEvent :: forall (xs :: [*]) blk. Index xs blk -> AuxLedgerEvent (LedgerState blk) -> OneEraLedgerEvent xs injectLedgerEvent Index xs blk index = NS WrapLedgerEvent xs -> OneEraLedgerEvent xs forall (xs :: [*]). NS WrapLedgerEvent xs -> OneEraLedgerEvent xs OneEraLedgerEvent (NS WrapLedgerEvent xs -> OneEraLedgerEvent xs) -> (AuxLedgerEvent (LedgerState blk) -> NS WrapLedgerEvent xs) -> AuxLedgerEvent (LedgerState blk) -> OneEraLedgerEvent xs forall b c a. (b -> c) -> (a -> b) -> a -> c . Index xs blk -> WrapLedgerEvent blk -> NS WrapLedgerEvent xs forall {k} (f :: k -> *) (x :: k) (xs :: [k]). Index xs x -> f x -> NS f xs injectNS Index xs blk index (WrapLedgerEvent blk -> NS WrapLedgerEvent xs) -> (AuxLedgerEvent (LedgerState blk) -> WrapLedgerEvent blk) -> AuxLedgerEvent (LedgerState blk) -> NS WrapLedgerEvent xs forall b c a. (b -> c) -> (a -> b) -> a -> c . AuxLedgerEvent (LedgerState blk) -> WrapLedgerEvent blk forall blk. AuxLedgerEvent (LedgerState blk) -> WrapLedgerEvent blk WrapLedgerEvent