{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveAnyClass             #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE EmptyCase                  #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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.Except
import           Data.Functor ((<&>))
import           Data.Functor.Product
import           Data.Proxy
import           Data.SOP.Strict hiding (shape)
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.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
import           Ouroboros.Consensus.Util.Counting (getExactly)
import           Ouroboros.Consensus.Util.SOP

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.Combinator.Util.InPairs
                     (InPairs (..))
import qualified Ouroboros.Consensus.HardFork.Combinator.Util.InPairs as InPairs
import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Match as Match
import           Ouroboros.Consensus.HardFork.Combinator.Util.Telescope
                     (Telescope (..))
import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Telescope as Telescope

{-------------------------------------------------------------------------------
  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
$cto :: forall (xs :: [*]) x.
Rep (HardForkLedgerError xs) x -> HardForkLedgerError xs
$cfrom :: forall (xs :: [*]) x.
HardForkLedgerError xs -> Rep (HardForkLedgerError xs) x
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
showList :: [HardForkLedgerError xs] -> ShowS
$cshowList :: forall (xs :: [*]).
CanHardFork xs =>
[HardForkLedgerError xs] -> ShowS
show :: HardForkLedgerError xs -> String
$cshow :: forall (xs :: [*]).
CanHardFork xs =>
HardForkLedgerError xs -> String
showsPrec :: Int -> HardForkLedgerError xs -> ShowS
$cshowsPrec :: forall (xs :: [*]).
CanHardFork xs =>
Int -> 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
/= :: HardForkLedgerError xs -> HardForkLedgerError xs -> Bool
$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
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
showTypeOf :: Proxy (HardForkLedgerError xs) -> String
$cshowTypeOf :: forall (xs :: [*]).
CanHardFork xs =>
Proxy (HardForkLedgerError xs) -> String
wNoThunks :: Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo)
noThunks :: Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo)
$cnoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo)
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 b b'.
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 b b'.
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 b b'.
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 b b'.
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 {
        Ticked (LedgerState (HardForkBlock xs)) -> TransitionInfo
tickedHardForkLedgerStateTransition :: !TransitionInfo
      , 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
$cto :: forall (xs :: [*]) x.
Rep (Ticked (LedgerState (HardForkBlock xs))) x
-> Ticked (LedgerState (HardForkBlock xs))
$cfrom :: forall (xs :: [*]) x.
Ticked (LedgerState (HardForkBlock xs))
-> Rep (Ticked (LedgerState (HardForkBlock xs))) x
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{..} SlotNo
slot (HardForkLedgerState 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 :: forall (xs :: [*]).
TransitionInfo
-> HardForkState (Ticked :.: LedgerState) xs
-> Ticked (LedgerState (HardForkBlock xs))
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 :: 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 (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 :: 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 transition 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
-> ExceptT
     (HardForkLedgerError xs)
     Identity
     (LedgerResult
        (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs)))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
          (HardForkLedgerError xs
 -> ExceptT
      (HardForkLedgerError xs)
      Identity
      (LedgerResult
         (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs))))
-> HardForkLedgerError xs
-> ExceptT
     (HardForkLedgerError xs)
     Identity
     (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 forall x. SingleEraBlock x => I x -> SingleEraInfo x
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
singleEraInfo 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
     (HardForkLedgerError xs)
     Identity
     (HardForkState
        (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs)
-> ExceptT
     (HardForkLedgerError xs)
     Identity
     (LedgerResult
        (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs)))
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 (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
   (HardForkLedgerError xs)
   Identity
   (HardForkState
      (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs)
 -> ExceptT
      (HardForkLedgerError xs)
      Identity
      (LedgerResult
         (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs))))
-> ExceptT
     (HardForkLedgerError xs)
     Identity
     (HardForkState
        (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) xs)
-> ExceptT
     (HardForkLedgerError xs)
     Identity
     (LedgerResult
        (LedgerState (HardForkBlock xs)) (LedgerState (HardForkBlock xs)))
forall a b. (a -> b) -> a -> b
$ HardForkState
  (ExceptT (HardForkLedgerError xs) Identity
   :.: (LedgerResult (LedgerState (HardForkBlock xs))
        :.: LedgerState))
  xs
-> ExceptT
     (HardForkLedgerError xs)
     Identity
     (HardForkState
        (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState) 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 (HardForkLedgerError xs) Identity
    :.: (LedgerResult (LedgerState (HardForkBlock xs))
         :.: LedgerState))
   xs
 -> ExceptT
      (HardForkLedgerError xs)
      Identity
      (HardForkState
         (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState)
         xs))
-> HardForkState
     (ExceptT (HardForkLedgerError xs) Identity
      :.: (LedgerResult (LedgerState (HardForkBlock xs))
           :.: LedgerState))
     xs
-> ExceptT
     (HardForkLedgerError 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 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 :: 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 transition 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 (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 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 :: 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)) =
      ExceptT
  (HardForkLedgerError xs)
  Identity
  ((:.:)
     (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
    (ExceptT
   (HardForkLedgerError xs)
   Identity
   ((:.:)
      (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk)
 -> (:.:)
      (Except (HardForkLedgerError xs))
      (LedgerResult (LedgerState (HardForkBlock xs)) :.: LedgerState)
      blk)
-> ExceptT
     (HardForkLedgerError xs)
     Identity
     ((:.:)
        (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)
-> ExceptT
     (HardForkLedgerError xs)
     Identity
     ((:.:)
        (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)
 -> ExceptT
      (HardForkLedgerError xs)
      Identity
      ((:.:)
         (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk))
-> Except
     (LedgerErr (LedgerState blk))
     ((:.:)
        (LedgerResult (LedgerState (HardForkBlock xs))) LedgerState blk)
-> ExceptT
     (HardForkLedgerError xs)
     Identity
     ((:.:)
        (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 (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 :: 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
/= :: HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool
$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
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
showList :: [HardForkEnvelopeErr xs] -> ShowS
$cshowList :: forall (xs :: [*]).
CanHardFork xs =>
[HardForkEnvelopeErr xs] -> ShowS
show :: HardForkEnvelopeErr xs -> String
$cshow :: forall (xs :: [*]).
CanHardFork xs =>
HardForkEnvelopeErr xs -> String
showsPrec :: Int -> HardForkEnvelopeErr xs -> ShowS
$cshowsPrec :: forall (xs :: [*]).
CanHardFork xs =>
Int -> 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
$cto :: forall (xs :: [*]) x.
Rep (HardForkEnvelopeErr xs) x -> HardForkEnvelopeErr xs
$cfrom :: forall (xs :: [*]) x.
HardForkEnvelopeErr xs -> Rep (HardForkEnvelopeErr xs) x
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
showTypeOf :: Proxy (HardForkEnvelopeErr xs) -> String
$cshowTypeOf :: forall (xs :: [*]).
CanHardFork xs =>
Proxy (HardForkEnvelopeErr xs) -> String
wNoThunks :: Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo)
noThunks :: Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo)
$cnoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo)
NoThunks)

instance CanHardFork xs => ValidateEnvelope (HardForkBlock xs) where
  type OtherHeaderEnvelopeError (HardForkBlock xs) = HardForkEnvelopeErr xs

  additionalEnvelopeChecks :: TopLevelConfig (HardForkBlock xs)
-> Ticked (LedgerView (BlockProtocol (HardForkBlock xs)))
-> Header (HardForkBlock xs)
-> Except (OtherHeaderEnvelopeError (HardForkBlock xs)) ()
additionalEnvelopeChecks TopLevelConfig (HardForkBlock xs)
tlc
                           (TickedHardForkLedgerView transition hardForkView) =
                          \(HardForkHeader (OneEraHeader hdr)) ->
      case NS Header xs
-> NS (Ticked :.: WrapLedgerView) xs
-> Either
     (Mismatch Header (Ticked :.: WrapLedgerView) xs)
     (NS (Product Header (Ticked :.: 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 (Ticked :.: WrapLedgerView) xs
-> NS (Ticked :.: WrapLedgerView) xs
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
HardForkState f xs -> NS f xs
State.tip HardForkState (Ticked :.: WrapLedgerView) xs
hardForkView) of
        Left Mismatch Header (Ticked :.: WrapLedgerView) xs
mismatch ->
          HardForkEnvelopeErr xs
-> ExceptT (HardForkEnvelopeErr xs) Identity ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (HardForkEnvelopeErr xs
 -> ExceptT (HardForkEnvelopeErr xs) Identity ())
-> HardForkEnvelopeErr xs
-> ExceptT (HardForkEnvelopeErr xs) Identity ()
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 =>
    (:.:) Ticked WrapLedgerView x -> LedgerEraInfo x)
-> Mismatch Header (Ticked :.: 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 forall x. SingleEraBlock x => Header x -> SingleEraInfo x
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
singleEraInfo forall x.
SingleEraBlock x =>
(:.:) Ticked WrapLedgerView x -> LedgerEraInfo x
forall blk (f :: * -> *).
SingleEraBlock blk =>
(:.:) Ticked f blk -> LedgerEraInfo blk
ledgerViewInfo Mismatch Header (Ticked :.: WrapLedgerView) xs
mismatch
        Right NS (Product Header (Ticked :.: WrapLedgerView)) xs
matched ->
          NS (K (ExceptT (HardForkEnvelopeErr xs) Identity ())) xs
-> CollapseTo NS (ExceptT (HardForkEnvelopeErr xs) Identity ())
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 (Ticked :.: WrapLedgerView) a
    -> K (ExceptT (HardForkEnvelopeErr xs) Identity ()) a)
-> NP TopLevelConfig xs
-> NS (Product Header (Ticked :.: 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 forall a.
SingleEraBlock a =>
Index xs a
-> TopLevelConfig a
-> Product Header (Ticked :.: WrapLedgerView) a
-> K (ExceptT (HardForkEnvelopeErr xs) Identity ()) a
aux NP TopLevelConfig xs
cfgs NS (Product Header (Ticked :.: WrapLedgerView)) xs
matched
    where
      ei :: EpochInfo (Except PastHorizonException)
      ei :: EpochInfo (Except PastHorizonException)
ei = Shape xs
-> TransitionInfo
-> HardForkState (Ticked :.: 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 (Ticked :.: 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 (Ticked :.: WrapLedgerView) blk
          -> K (Except (HardForkEnvelopeErr xs) ()) blk
      aux :: Index xs blk
-> TopLevelConfig blk
-> Product Header (Ticked :.: WrapLedgerView) blk
-> K (ExceptT (HardForkEnvelopeErr xs) Identity ()) blk
aux Index xs blk
index TopLevelConfig blk
cfg (Pair Header blk
hdr (Comp Ticked (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
-> Ticked (LedgerView (BlockProtocol blk))
-> Header blk
-> Except (OtherHeaderEnvelopeError blk) ()
forall blk.
ValidateEnvelope blk =>
TopLevelConfig blk
-> Ticked (LedgerView (BlockProtocol blk))
-> Header blk
-> Except (OtherHeaderEnvelopeError blk) ()
additionalEnvelopeChecks
              TopLevelConfig blk
cfg
              (Ticked (WrapLedgerView blk)
-> Ticked (LedgerView (BlockProtocol blk))
forall blk.
Ticked (WrapLedgerView blk)
-> Ticked (LedgerView (BlockProtocol blk))
unwrapTickedLedgerView Ticked (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))
-> Ticked (LedgerView (BlockProtocol (HardForkBlock xs)))
protocolLedgerView HardForkLedgerConfig{..}
                     (TickedHardForkLedgerState transition ticked) =
      TickedHardForkLedgerView :: forall (f :: * -> *) (xs :: [*]).
TransitionInfo
-> HardForkState (Ticked :.: f) xs
-> Ticked (HardForkLedgerView_ f xs)
TickedHardForkLedgerView {
          tickedHardForkLedgerViewTransition :: TransitionInfo
tickedHardForkLedgerViewTransition = TransitionInfo
transition
        , tickedHardForkLedgerViewPerEra :: HardForkState (Ticked :.: WrapLedgerView) xs
tickedHardForkLedgerViewPerEra     =
            Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    WrapPartialLedgerConfig a
    -> (:.:) Ticked LedgerState a -> (:.:) Ticked WrapLedgerView a)
-> Prod HardForkState WrapPartialLedgerConfig xs
-> HardForkState (Ticked :.: LedgerState) xs
-> HardForkState (Ticked :.: 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 forall a.
SingleEraBlock a =>
WrapPartialLedgerConfig a
-> (:.:) Ticked LedgerState a -> (:.:) Ticked WrapLedgerView a
tickedViewOne 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

      tickedViewOne :: SingleEraBlock              blk
                    => WrapPartialLedgerConfig     blk
                    -> (Ticked :.: LedgerState)    blk
                    -> (Ticked :.: WrapLedgerView) blk
      tickedViewOne :: WrapPartialLedgerConfig blk
-> (:.:) Ticked LedgerState blk -> (:.:) Ticked WrapLedgerView blk
tickedViewOne WrapPartialLedgerConfig blk
cfg (Comp Ticked (LedgerState blk)
st) = Ticked (WrapLedgerView blk) -> (:.:) Ticked WrapLedgerView blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (Ticked (WrapLedgerView blk) -> (:.:) Ticked WrapLedgerView blk)
-> Ticked (WrapLedgerView blk) -> (:.:) Ticked WrapLedgerView blk
forall a b. (a -> b) -> a -> b
$
          Ticked (LedgerView (BlockProtocol blk))
-> Ticked (WrapLedgerView blk)
forall blk.
Ticked (LedgerView (BlockProtocol blk))
-> Ticked (WrapLedgerView blk)
WrapTickedLedgerView (Ticked (LedgerView (BlockProtocol blk))
 -> Ticked (WrapLedgerView blk))
-> Ticked (LedgerView (BlockProtocol blk))
-> Ticked (WrapLedgerView blk)
forall a b. (a -> b) -> a -> b
$
            LedgerConfig blk
-> Ticked (LedgerState blk)
-> Ticked (LedgerView (BlockProtocol blk))
forall blk.
LedgerSupportsProtocol blk =>
LedgerConfig blk
-> Ticked (LedgerState blk)
-> Ticked (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 :: LedgerConfig (HardForkBlock xs)
-> LedgerState (HardForkBlock xs)
-> Forecast (LedgerView (BlockProtocol (HardForkBlock xs)))
ledgerViewForecastAt ledgerCfg :: LedgerConfig (HardForkBlock xs)
ledgerCfg@HardForkLedgerConfig{..}
                       (HardForkLedgerState ledgerSt) =
      InPairs (TranslateForecast LedgerState WrapLedgerView) xs
-> HardForkState (AnnForecast LedgerState WrapLedgerView) xs
-> Forecast (HardForkLedgerView_ WrapLedgerView xs)
forall (state :: * -> *) (view :: * -> *) (xs :: [*]).
SListI xs =>
InPairs (TranslateForecast state view) xs
-> HardForkState (AnnForecast state view) xs
-> Forecast (HardForkLedgerView_ view xs)
mkHardForkForecast
        (NP WrapLedgerConfig xs
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (TranslateForecast LedgerState WrapLedgerView))
     xs
-> InPairs (TranslateForecast 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 (TranslateForecast LedgerState WrapLedgerView))
   xs
 -> InPairs (TranslateForecast LedgerState WrapLedgerView) xs)
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (TranslateForecast LedgerState WrapLedgerView))
     xs
-> InPairs (TranslateForecast LedgerState WrapLedgerView) xs
forall a b. (a -> b) -> a -> b
$ EraTranslation xs
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (TranslateForecast LedgerState WrapLedgerView))
     xs
forall (xs :: [*]).
EraTranslation xs
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (TranslateForecast LedgerState WrapLedgerView))
     xs
translateLedgerView 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
            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 :: WrapPartialLedgerConfig blk
-> K EraParams blk
-> Current LedgerState blk
-> Current (AnnForecast LedgerState WrapLedgerView) blk
forecastOne WrapPartialLedgerConfig blk
cfg (K EraParams
params) (Current Bound
start LedgerState blk
st) = Current :: forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
Current {
            currentStart :: Bound
currentStart = Bound
start
          , currentState :: AnnForecast LedgerState WrapLedgerView blk
currentState = AnnForecast :: forall (state :: * -> *) (view :: * -> *) blk.
Forecast (view blk)
-> state blk
-> WithOrigin SlotNo
-> Maybe Bound
-> AnnForecast state view blk
AnnForecast {
                annForecast :: Forecast (WrapLedgerView blk)
annForecast      = (Ticked (LedgerView (BlockProtocol blk))
 -> Ticked (WrapLedgerView blk))
-> Forecast (LedgerView (BlockProtocol blk))
-> Forecast (WrapLedgerView blk)
forall a b. (Ticked a -> Ticked b) -> Forecast a -> Forecast b
mapForecast Ticked (LedgerView (BlockProtocol blk))
-> Ticked (WrapLedgerView blk)
forall blk.
Ticked (LedgerView (BlockProtocol blk))
-> Ticked (WrapLedgerView blk)
WrapTickedLedgerView (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 {
      AnnForecast state view blk -> Forecast (view blk)
annForecast      :: Forecast (view blk)
    , AnnForecast state view blk -> state blk
annForecastState :: state blk
    , AnnForecast state view blk -> WithOrigin SlotNo
annForecastTip   :: WithOrigin SlotNo
    , 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 (TranslateForecast state view) xs
  -> HardForkState (AnnForecast state view) xs
  -> Forecast (HardForkLedgerView_ view xs)
mkHardForkForecast :: InPairs (TranslateForecast state view) xs
-> HardForkState (AnnForecast state view) xs
-> Forecast (HardForkLedgerView_ view xs)
mkHardForkForecast InPairs (TranslateForecast state view) xs
translations HardForkState (AnnForecast state view) xs
st = Forecast :: forall a.
WithOrigin SlotNo
-> (SlotNo -> Except OutsideForecastRange (Ticked a)) -> Forecast a
Forecast {
      forecastAt :: WithOrigin SlotNo
forecastAt  = HardForkState (K (WithOrigin SlotNo)) xs
-> CollapseTo HardForkState (WithOrigin SlotNo)
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 (Ticked (HardForkLedgerView_ view xs))
forecastFor = \SlotNo
sno -> SlotNo
-> InPairs (TranslateForecast state view) xs
-> Telescope (K Past) (Current (AnnForecast state view)) xs
-> Except
     OutsideForecastRange (Ticked (HardForkLedgerView_ view xs))
forall (xs' :: [*]).
SlotNo
-> InPairs (TranslateForecast state view) xs'
-> Telescope (K Past) (Current (AnnForecast state view)) xs'
-> Except
     OutsideForecastRange (Ticked (HardForkLedgerView_ view xs'))
go SlotNo
sno InPairs (TranslateForecast 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 (TranslateForecast state view) xs'
       -> Telescope (K Past) (Current (AnnForecast state view)) xs'
       -> Except OutsideForecastRange (Ticked (HardForkLedgerView_ view xs'))
    go :: SlotNo
-> InPairs (TranslateForecast state view) xs'
-> Telescope (K Past) (Current (AnnForecast state view)) xs'
-> Except
     OutsideForecastRange (Ticked (HardForkLedgerView_ view xs'))
go SlotNo
sno InPairs (TranslateForecast state view) xs'
pairs        (TZ Current (AnnForecast state view) x
cur)       = SlotNo
-> InPairs (TranslateForecast state view) (x : xs)
-> Current (AnnForecast state view) x
-> Except
     OutsideForecastRange (Ticked (HardForkLedgerView_ view (x : xs)))
forall (state :: * -> *) (view :: * -> *) blk (blks :: [*]).
SlotNo
-> InPairs (TranslateForecast state view) (blk : blks)
-> Current (AnnForecast state view) blk
-> Except
     OutsideForecastRange
     (Ticked (HardForkLedgerView_ view (blk : blks)))
oneForecast SlotNo
sno InPairs (TranslateForecast state view) xs'
InPairs (TranslateForecast state view) (x : xs)
pairs Current (AnnForecast state view) x
cur
    go SlotNo
sno (PCons TranslateForecast state view x y
_ InPairs (TranslateForecast state view) (y : zs)
ts) (TS K Past x
past Telescope (K Past) (Current (AnnForecast state view)) xs
rest) = K Past x
-> Ticked (HardForkLedgerView_ view (y : zs))
-> Ticked (HardForkLedgerView_ view (x : y : zs))
forall blk (f :: * -> *) (blks :: [*]).
K Past blk
-> Ticked (HardForkLedgerView_ f blks)
-> Ticked (HardForkLedgerView_ f (blk : blks))
shiftView K Past x
past (Ticked (HardForkLedgerView_ view (y : zs))
 -> Ticked (HardForkLedgerView_ view (x : y : zs)))
-> ExceptT
     OutsideForecastRange
     Identity
     (Ticked (HardForkLedgerView_ view (y : zs)))
-> ExceptT
     OutsideForecastRange
     Identity
     (Ticked (HardForkLedgerView_ view (x : y : zs)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotNo
-> InPairs (TranslateForecast state view) (y : zs)
-> Telescope (K Past) (Current (AnnForecast state view)) (y : zs)
-> ExceptT
     OutsideForecastRange
     Identity
     (Ticked (HardForkLedgerView_ view (y : zs)))
forall (xs' :: [*]).
SlotNo
-> InPairs (TranslateForecast state view) xs'
-> Telescope (K Past) (Current (AnnForecast state view)) xs'
-> Except
     OutsideForecastRange (Ticked (HardForkLedgerView_ view xs'))
go SlotNo
sno InPairs (TranslateForecast state view) (y : zs)
ts Telescope (K Past) (Current (AnnForecast state view)) xs
Telescope (K Past) (Current (AnnForecast state view)) (y : zs)
rest

oneForecast ::
     forall state view blk blks.
     SlotNo
  -> InPairs (TranslateForecast state view) (blk : blks)
     -- ^ this function uses at most the first translation
  -> Current (AnnForecast state view) blk
  -> Except OutsideForecastRange (Ticked (HardForkLedgerView_ view (blk : blks)))
oneForecast :: SlotNo
-> InPairs (TranslateForecast state view) (blk : blks)
-> Current (AnnForecast state view) blk
-> Except
     OutsideForecastRange
     (Ticked (HardForkLedgerView_ view (blk : blks)))
oneForecast SlotNo
sno InPairs (TranslateForecast state view) (blk : blks)
pairs (Current Bound
start AnnForecast{state blk
Maybe Bound
WithOrigin SlotNo
Forecast (view blk)
annForecastEnd :: Maybe Bound
annForecastTip :: WithOrigin SlotNo
annForecastState :: state blk
annForecast :: Forecast (view blk)
annForecastEnd :: forall (state :: * -> *) (view :: * -> *) blk.
AnnForecast state view blk -> Maybe Bound
annForecastTip :: forall (state :: * -> *) (view :: * -> *) blk.
AnnForecast state view blk -> WithOrigin SlotNo
annForecastState :: forall (state :: * -> *) (view :: * -> *) blk.
AnnForecast state view blk -> state blk
annForecast :: forall (state :: * -> *) (view :: * -> *) blk.
AnnForecast state view blk -> Forecast (view blk)
..}) =
    case Maybe Bound
annForecastEnd of
      Maybe Bound
Nothing  -> Ticked (view blk) -> Ticked (HardForkLedgerView_ view (blk : blks))
forall (f :: * -> *).
Ticked (f blk) -> Ticked (HardForkLedgerView_ f (blk : blks))
endUnknown (Ticked (view blk)
 -> Ticked (HardForkLedgerView_ view (blk : blks)))
-> ExceptT OutsideForecastRange Identity (Ticked (view blk))
-> Except
     OutsideForecastRange
     (Ticked (HardForkLedgerView_ view (blk : blks)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Forecast (view blk)
-> SlotNo
-> ExceptT OutsideForecastRange Identity (Ticked (view blk))
forall a.
Forecast a -> SlotNo -> Except OutsideForecastRange (Ticked 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
-> Ticked (view blk)
-> Ticked (HardForkLedgerView_ view (blk : blks))
forall (f :: * -> *).
Bound
-> Ticked (f blk) -> Ticked (HardForkLedgerView_ f (blk : blks))
beforeKnownEnd Bound
end (Ticked (view blk)
 -> Ticked (HardForkLedgerView_ view (blk : blks)))
-> ExceptT OutsideForecastRange Identity (Ticked (view blk))
-> Except
     OutsideForecastRange
     (Ticked (HardForkLedgerView_ view (blk : blks)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Forecast (view blk)
-> SlotNo
-> ExceptT OutsideForecastRange Identity (Ticked (view blk))
forall a.
Forecast a -> SlotNo -> Except OutsideForecastRange (Ticked a)
forecastFor Forecast (view blk)
annForecast SlotNo
sno
        else case InPairs (TranslateForecast state view) (blk : blks)
pairs of
          PCons TranslateForecast state view x y
translate InPairs (TranslateForecast state view) (y : zs)
_ ->
                Bound
-> Ticked (view y)
-> Ticked (HardForkLedgerView_ view (blk : y : zs))
forall (f :: * -> *) blk' (blks' :: [*]).
Bound
-> Ticked (f blk')
-> Ticked (HardForkLedgerView_ f (blk : blk' : blks'))
afterKnownEnd Bound
end
            (Ticked (view y)
 -> Ticked (HardForkLedgerView_ view (blk : y : zs)))
-> ExceptT OutsideForecastRange Identity (Ticked (view y))
-> ExceptT
     OutsideForecastRange
     Identity
     (Ticked (HardForkLedgerView_ view (blk : y : zs)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TranslateForecast state view x y
-> Bound
-> SlotNo
-> state x
-> ExceptT OutsideForecastRange Identity (Ticked (view y))
forall (f :: * -> *) (g :: * -> *) x y.
TranslateForecast f g x y
-> Bound
-> SlotNo
-> f x
-> Except OutsideForecastRange (Ticked (g y))
translateForecastWith TranslateForecast state view x y
translate Bound
end SlotNo
sno state blk
state x
annForecastState
          InPairs (TranslateForecast state view) (blk : blks)
PNil              ->
            -- The requested slot is after the last era the code knows about.
            OutsideForecastRange
-> Except
     OutsideForecastRange
     (Ticked (HardForkLedgerView_ view (blk : blks)))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError OutsideForecastRange :: WithOrigin SlotNo -> SlotNo -> SlotNo -> OutsideForecastRange
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 ::
         Ticked (f blk)
      -> Ticked (HardForkLedgerView_ f (blk : blks))
    endUnknown :: Ticked (f blk) -> Ticked (HardForkLedgerView_ f (blk : blks))
endUnknown Ticked (f blk)
view = TickedHardForkLedgerView :: forall (f :: * -> *) (xs :: [*]).
TransitionInfo
-> HardForkState (Ticked :.: f) xs
-> Ticked (HardForkLedgerView_ f xs)
TickedHardForkLedgerView {
          tickedHardForkLedgerViewTransition :: TransitionInfo
tickedHardForkLedgerViewTransition =
            WithOrigin SlotNo -> TransitionInfo
TransitionUnknown WithOrigin SlotNo
annForecastTip
        , tickedHardForkLedgerViewPerEra :: HardForkState (Ticked :.: f) (blk : blks)
tickedHardForkLedgerViewPerEra = Telescope (K Past) (Current (Ticked :.: f)) (blk : blks)
-> HardForkState (Ticked :.: f) (blk : blks)
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState (Telescope (K Past) (Current (Ticked :.: f)) (blk : blks)
 -> HardForkState (Ticked :.: f) (blk : blks))
-> Telescope (K Past) (Current (Ticked :.: f)) (blk : blks)
-> HardForkState (Ticked :.: f) (blk : blks)
forall a b. (a -> b) -> a -> b
$
            Current (Ticked :.: f) blk
-> Telescope (K Past) (Current (Ticked :.: f)) (blk : blks)
forall a (f :: a -> *) (x :: a) (g :: a -> *) (xs :: [a]).
f x -> Telescope g f (x : xs)
TZ (Bound -> (:.:) Ticked f blk -> Current (Ticked :.: f) blk
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
Current Bound
start (Ticked (f blk) -> (:.:) Ticked f blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp Ticked (f blk)
view))
        }

    beforeKnownEnd ::
         Bound
      -> Ticked (f blk)
      -> Ticked (HardForkLedgerView_ f (blk : blks))
    beforeKnownEnd :: Bound
-> Ticked (f blk) -> Ticked (HardForkLedgerView_ f (blk : blks))
beforeKnownEnd Bound
end Ticked (f blk)
view = TickedHardForkLedgerView :: forall (f :: * -> *) (xs :: [*]).
TransitionInfo
-> HardForkState (Ticked :.: f) xs
-> Ticked (HardForkLedgerView_ f xs)
TickedHardForkLedgerView {
          tickedHardForkLedgerViewTransition :: TransitionInfo
tickedHardForkLedgerViewTransition =
            EpochNo -> TransitionInfo
TransitionKnown (Bound -> EpochNo
boundEpoch Bound
end)
        , tickedHardForkLedgerViewPerEra :: HardForkState (Ticked :.: f) (blk : blks)
tickedHardForkLedgerViewPerEra = Telescope (K Past) (Current (Ticked :.: f)) (blk : blks)
-> HardForkState (Ticked :.: f) (blk : blks)
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState (Telescope (K Past) (Current (Ticked :.: f)) (blk : blks)
 -> HardForkState (Ticked :.: f) (blk : blks))
-> Telescope (K Past) (Current (Ticked :.: f)) (blk : blks)
-> HardForkState (Ticked :.: f) (blk : blks)
forall a b. (a -> b) -> a -> b
$
            Current (Ticked :.: f) blk
-> Telescope (K Past) (Current (Ticked :.: f)) (blk : blks)
forall a (f :: a -> *) (x :: a) (g :: a -> *) (xs :: [a]).
f x -> Telescope g f (x : xs)
TZ (Bound -> (:.:) Ticked f blk -> Current (Ticked :.: f) blk
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
Current Bound
start (Ticked (f blk) -> (:.:) Ticked f blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp Ticked (f blk)
view))
        }

    afterKnownEnd ::
         Bound
      -> Ticked (f blk')
      -> Ticked (HardForkLedgerView_ f (blk : blk' : blks'))
    afterKnownEnd :: Bound
-> Ticked (f blk')
-> Ticked (HardForkLedgerView_ f (blk : blk' : blks'))
afterKnownEnd Bound
end Ticked (f blk')
view = TickedHardForkLedgerView :: forall (f :: * -> *) (xs :: [*]).
TransitionInfo
-> HardForkState (Ticked :.: f) xs
-> Ticked (HardForkLedgerView_ f xs)
TickedHardForkLedgerView {
          tickedHardForkLedgerViewTransition :: TransitionInfo
tickedHardForkLedgerViewTransition =
            -- We assume that we only ever have to translate to the /next/ era
            -- (as opposed to /any/ subsequent era)
            TransitionInfo
TransitionImpossible
        , tickedHardForkLedgerViewPerEra :: HardForkState (Ticked :.: f) (blk : blk' : blks')
tickedHardForkLedgerViewPerEra = Telescope (K Past) (Current (Ticked :.: f)) (blk : blk' : blks')
-> HardForkState (Ticked :.: f) (blk : blk' : blks')
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState (Telescope (K Past) (Current (Ticked :.: f)) (blk : blk' : blks')
 -> HardForkState (Ticked :.: f) (blk : blk' : blks'))
-> Telescope (K Past) (Current (Ticked :.: f)) (blk : blk' : blks')
-> HardForkState (Ticked :.: f) (blk : blk' : blks')
forall a b. (a -> b) -> a -> b
$
            K Past blk
-> Telescope (K Past) (Current (Ticked :.: f)) (blk' : blks')
-> Telescope (K Past) (Current (Ticked :.: f)) (blk : blk' : blks')
forall a (g :: a -> *) (x :: a) (f :: a -> *) (xs :: [a]).
g x -> Telescope g f xs -> Telescope g f (x : xs)
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 (Ticked :.: f)) (blk' : blks')
 -> Telescope
      (K Past) (Current (Ticked :.: f)) (blk : blk' : blks'))
-> Telescope (K Past) (Current (Ticked :.: f)) (blk' : blks')
-> Telescope (K Past) (Current (Ticked :.: f)) (blk : blk' : blks')
forall a b. (a -> b) -> a -> b
$
            Current (Ticked :.: f) blk'
-> Telescope (K Past) (Current (Ticked :.: f)) (blk' : blks')
forall a (f :: a -> *) (x :: a) (g :: a -> *) (xs :: [a]).
f x -> Telescope g f (x : xs)
TZ (Bound -> (:.:) Ticked f blk' -> Current (Ticked :.: f) blk'
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
Current Bound
end (Ticked (f blk') -> (:.:) Ticked f blk'
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp Ticked (f blk')
view))
        }

shiftView :: K Past blk
          -> Ticked (HardForkLedgerView_ f blks)
          -> Ticked (HardForkLedgerView_ f (blk : blks))
shiftView :: K Past blk
-> Ticked (HardForkLedgerView_ f blks)
-> Ticked (HardForkLedgerView_ f (blk : blks))
shiftView K Past blk
past TickedHardForkLedgerView{..} = TickedHardForkLedgerView :: forall (f :: * -> *) (xs :: [*]).
TransitionInfo
-> HardForkState (Ticked :.: f) xs
-> Ticked (HardForkLedgerView_ f xs)
TickedHardForkLedgerView {
      tickedHardForkLedgerViewTransition :: TransitionInfo
tickedHardForkLedgerViewTransition = TransitionInfo
tickedHardForkLedgerViewTransition
    , tickedHardForkLedgerViewPerEra :: HardForkState (Ticked :.: f) (blk : blks)
tickedHardForkLedgerViewPerEra =
          Telescope (K Past) (Current (Ticked :.: f)) (blk : blks)
-> HardForkState (Ticked :.: f) (blk : blks)
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState
        (Telescope (K Past) (Current (Ticked :.: f)) (blk : blks)
 -> HardForkState (Ticked :.: f) (blk : blks))
-> (HardForkState (Ticked :.: f) blks
    -> Telescope (K Past) (Current (Ticked :.: f)) (blk : blks))
-> HardForkState (Ticked :.: f) blks
-> HardForkState (Ticked :.: f) (blk : blks)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K Past blk
-> Telescope (K Past) (Current (Ticked :.: f)) blks
-> Telescope (K Past) (Current (Ticked :.: f)) (blk : blks)
forall a (g :: a -> *) (x :: a) (f :: a -> *) (xs :: [a]).
g x -> Telescope g f xs -> Telescope g f (x : xs)
TS K Past blk
past
        (Telescope (K Past) (Current (Ticked :.: f)) blks
 -> Telescope (K Past) (Current (Ticked :.: f)) (blk : blks))
-> (HardForkState (Ticked :.: f) blks
    -> Telescope (K Past) (Current (Ticked :.: f)) blks)
-> HardForkState (Ticked :.: f) blks
-> Telescope (K Past) (Current (Ticked :.: f)) (blk : blks)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkState (Ticked :.: f) blks
-> Telescope (K Past) (Current (Ticked :.: f)) blks
forall (f :: * -> *) (xs :: [*]).
HardForkState f xs -> Telescope (K Past) (Current f) xs
getHardForkState
        (HardForkState (Ticked :.: f) blks
 -> HardForkState (Ticked :.: f) (blk : blks))
-> HardForkState (Ticked :.: f) blks
-> HardForkState (Ticked :.: f) (blk : blks)
forall a b. (a -> b) -> a -> b
$ HardForkState (Ticked :.: f) blks
tickedHardForkLedgerViewPerEra
    }

{-------------------------------------------------------------------------------
  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 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 before)
                (HardForkLedgerState 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
hardForkLedgerConfigPerEra :: PerEraLedgerConfig xs
hardForkLedgerConfigShape :: Shape xs
hardForkLedgerConfigPerEra :: forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
hardForkLedgerConfigShape :: forall (xs :: [*]). HardForkLedgerConfig xs -> Shape 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 :: 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 :: 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 xs
_) (K EraParams
ps :* NP (K EraParams) xs
pss) (TopLevelConfig x
c :* NP TopLevelConfig xs
_) (Z Current LedgerState x
before) (Z Current LedgerState x
after) = [[LedgerEvent (HardForkBlock (x : xs))]]
-> [LedgerEvent (HardForkBlock (x : xs))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [
          (LedgerEvent x -> LedgerEvent (HardForkBlock (x : xs)))
-> [LedgerEvent x] -> [LedgerEvent (HardForkBlock (x : xs))]
forall a b. (a -> b) -> [a] -> [b]
map LedgerEvent x -> LedgerEvent (HardForkBlock (x : xs))
forall x (xs :: [*]).
LedgerEvent x -> LedgerEvent (HardForkBlock (x : xs))
liftEvent ([LedgerEvent x] -> [LedgerEvent (HardForkBlock (x : xs))])
-> [LedgerEvent x] -> [LedgerEvent (HardForkBlock (x : 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
before) (Current LedgerState x -> LedgerState x
forall (f :: * -> *) blk. Current f blk -> f blk
currentState Current LedgerState x
after)

        , case (NP (K EraParams) xs
pss, Maybe EpochNo
confirmedBefore, Maybe EpochNo
confirmedAfter) of
            (NP (K EraParams) xs
_, Maybe EpochNo
Nothing, Maybe EpochNo
Nothing) ->
              []
            (NP (K EraParams) xs
_, 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) xs
Nil, Maybe EpochNo
Nothing, Just EpochNo
transition) ->
              LedgerEvent (HardForkBlock (x : xs))
-> [LedgerEvent (HardForkBlock (x : xs))]
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerEvent (HardForkBlock (x : xs))
 -> [LedgerEvent (HardForkBlock (x : xs))])
-> LedgerEvent (HardForkBlock (x : xs))
-> [LedgerEvent (HardForkBlock (x : xs))]
forall a b. (a -> b) -> a -> b
$ 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
$
                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) xs
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 (x : xs))
-> [LedgerEvent (HardForkBlock (x : xs))]
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerEvent (HardForkBlock (x : xs))
 -> [LedgerEvent (HardForkBlock (x : xs))])
-> LedgerEvent (HardForkBlock (x : xs))
-> [LedgerEvent (HardForkBlock (x : xs))]
forall a b. (a -> b) -> a -> b
$ 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
$
                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 (x : xs))
-> [LedgerEvent (HardForkBlock (x : xs))]
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerEvent (HardForkBlock (x : xs))
 -> [LedgerEvent (HardForkBlock (x : xs))])
-> LedgerEvent (HardForkBlock (x : xs))
-> [LedgerEvent (HardForkBlock (x : xs))]
forall a b. (a -> b) -> a -> b
$
                if SafeZone -> Bool
validLowerBound (EraParams -> SafeZone
History.eraSafeZone EraParams
ps)
                  then 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
$
                         EraIndex (x : x : xs)
-> EraIndex (x : x : xs)
-> EpochNo
-> HardForkLedgerUpdate (x : x : xs)
forall (xs :: [*]).
EraIndex xs -> EraIndex xs -> EpochNo -> HardForkLedgerUpdate xs
HardForkUpdateTransitionConfirmed
                           EraIndex (x : x : xs)
forall x (xs :: [*]). EraIndex (x : xs)
eraIndexZero
                           (EraIndex (x : xs) -> EraIndex (x : x : xs)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex (x : xs)
forall x (xs :: [*]). EraIndex (x : xs)
eraIndexZero)
                           EpochNo
transition
                  else 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
$
                         EraIndex (x : x : xs)
-> EraParams -> EpochNo -> HardForkLedgerWarning (x : x : xs)
forall (xs :: [*]).
EraIndex xs -> EraParams -> EpochNo -> HardForkLedgerWarning xs
HardForkWarningTransitionMismatch
                           EraIndex (x : x : xs)
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 (x : xs))
-> [LedgerEvent (HardForkBlock (x : xs))]
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerEvent (HardForkBlock (x : xs))
 -> [LedgerEvent (HardForkBlock (x : xs))])
-> LedgerEvent (HardForkBlock (x : xs))
-> [LedgerEvent (HardForkBlock (x : xs))]
forall a b. (a -> b) -> a -> b
$ 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
$
                EraIndex (x : x : xs)
-> EraIndex (x : x : xs)
-> EpochNo
-> EpochNo
-> HardForkLedgerWarning (x : x : xs)
forall (xs :: [*]).
EraIndex xs
-> EraIndex xs -> EpochNo -> EpochNo -> HardForkLedgerWarning xs
HardForkWarningTransitionReconfirmed
                  EraIndex (x : x : xs)
forall x (xs :: [*]). EraIndex (x : xs)
eraIndexZero
                  (EraIndex (x : xs) -> EraIndex (x : x : xs)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex (x : xs)
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 xs
pcs) (K EraParams x
_ :* NP (K EraParams) xs
pss) (TopLevelConfig x
_ :* NP TopLevelConfig xs
cs) (S NS (Current LedgerState) xs
before) (S NS (Current LedgerState) xs
after) =
        (LedgerEvent (HardForkBlock xs)
 -> LedgerEvent (HardForkBlock (x : xs)))
-> [LedgerEvent (HardForkBlock xs)]
-> [LedgerEvent (HardForkBlock (x : xs))]
forall a b. (a -> b) -> [a] -> [b]
map LedgerEvent (HardForkBlock xs)
-> LedgerEvent (HardForkBlock (x : xs))
forall (xs :: [*]) x.
LedgerEvent (HardForkBlock xs)
-> LedgerEvent (HardForkBlock (x : xs))
shiftEvent ([LedgerEvent (HardForkBlock xs)]
 -> [LedgerEvent (HardForkBlock (x : xs))])
-> [LedgerEvent (HardForkBlock xs)]
-> [LedgerEvent (HardForkBlock (x : xs))]
forall a b. (a -> b) -> a -> b
$ 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 NP WrapPartialLedgerConfig xs
pcs NP (K EraParams) xs
NP (K EraParams) xs
pss NP TopLevelConfig xs
NP TopLevelConfig xs
cs NS (Current LedgerState) xs
NS (Current LedgerState) xs
before NS (Current LedgerState) xs
NS (Current LedgerState) xs
after
    go NP WrapPartialLedgerConfig xs
_ NP (K EraParams) xs
_ NP TopLevelConfig xs
_ (Z Current LedgerState x
_) (S NS (Current LedgerState) xs
after) =
        LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)]
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 : xs)
-> EraIndex (x : xs) -> EpochNo -> HardForkLedgerUpdate (x : xs)
forall (xs :: [*]).
EraIndex xs -> EraIndex xs -> EpochNo -> HardForkLedgerUpdate xs
HardForkUpdateTransitionDone
              EraIndex (x : xs)
forall x (xs :: [*]). EraIndex (x : xs)
eraIndexZero
              (EraIndex xs -> EraIndex (x : xs)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc (EraIndex xs -> EraIndex (x : xs))
-> EraIndex xs -> EraIndex (x : xs)
forall a b. (a -> b) -> a -> b
$ NS (Current LedgerState) xs -> EraIndex xs
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
NS f xs -> EraIndex xs
eraIndexFromNS NS (Current LedgerState) xs
after)
              (NS (K EpochNo) xs -> CollapseTo NS EpochNo
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) xs -> CollapseTo NS EpochNo)
-> NS (K EpochNo) xs -> CollapseTo NS EpochNo
forall a b. (a -> b) -> a -> b
$ (forall a. Current LedgerState a -> K EpochNo a)
-> NS (Current LedgerState) xs -> NS (K EpochNo) 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 (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) xs
after)
    go NP WrapPartialLedgerConfig xs
_ NP (K EraParams) xs
_ NP TopLevelConfig xs
_ (S NS (Current LedgerState) xs
before) (Z Current LedgerState x
_) =
        LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)]
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 : 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 -> EraIndex (x : xs))
-> EraIndex xs -> EraIndex (x : xs)
forall a b. (a -> b) -> a -> b
$ NS (Current LedgerState) xs -> EraIndex xs
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
NS f xs -> EraIndex xs
eraIndexFromNS NS (Current LedgerState) xs
before)
              EraIndex (x : xs)
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 :: 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 :: 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 a (f :: a -> *) (x :: a) (xs :: [a]). f x -> NS f (x : xs)
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 :: 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 a (f :: a -> *) (x :: a) (xs :: [a]). f x -> NS f (x : xs)
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 :: 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 :: HardForkLedgerWarning xs -> HardForkLedgerWarning (x : xs)
shiftWarning = HardForkLedgerWarning xs -> HardForkLedgerWarning (x : xs)
forall (xs :: [*]) x.
HardForkLedgerWarning xs -> HardForkLedgerWarning (x : xs)
go
  where
    go :: HardForkLedgerWarning xs -> HardForkLedgerWarning (x : xs)
go (HardForkWarningInEra (OneEraLedgerWarning NS WrapLedgerWarning xs
warning)) =
        OneEraLedgerWarning (x : xs) -> HardForkLedgerWarning (x : xs)
forall (xs :: [*]).
OneEraLedgerWarning xs -> HardForkLedgerWarning xs
HardForkWarningInEra
          (NS WrapLedgerWarning (x : xs) -> OneEraLedgerWarning (x : xs)
forall (xs :: [*]).
NS WrapLedgerWarning xs -> OneEraLedgerWarning xs
OneEraLedgerWarning (NS WrapLedgerWarning xs -> NS WrapLedgerWarning (x : xs)
forall a (f :: a -> *) (xs :: [a]) (x :: a).
NS f xs -> NS f (x : xs)
S NS WrapLedgerWarning xs
warning))
    go (HardForkWarningTransitionMismatch EraIndex xs
ix EraParams
ps EpochNo
t) =
        EraIndex (x : xs)
-> EraParams -> EpochNo -> HardForkLedgerWarning (x : xs)
forall (xs :: [*]).
EraIndex xs -> EraParams -> EpochNo -> HardForkLedgerWarning xs
HardForkWarningTransitionMismatch
          (EraIndex xs -> EraIndex (x : xs)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex xs
ix)
          EraParams
ps
          EpochNo
t
    go (HardForkWarningTransitionInFinalEra EraIndex xs
ix EpochNo
t) =
        EraIndex (x : xs) -> EpochNo -> HardForkLedgerWarning (x : xs)
forall (xs :: [*]).
EraIndex xs -> EpochNo -> HardForkLedgerWarning xs
HardForkWarningTransitionInFinalEra
          (EraIndex xs -> EraIndex (x : xs)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex xs
ix)
          EpochNo
t
    go (HardForkWarningTransitionUnconfirmed EraIndex xs
ix) =
        EraIndex (x : xs) -> HardForkLedgerWarning (x : xs)
forall (xs :: [*]). EraIndex xs -> HardForkLedgerWarning xs
HardForkWarningTransitionUnconfirmed
          (EraIndex xs -> EraIndex (x : xs)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex xs
ix)
    go (HardForkWarningTransitionReconfirmed EraIndex xs
ix EraIndex xs
ix' EpochNo
t EpochNo
t') =
        EraIndex (x : xs)
-> EraIndex (x : xs)
-> EpochNo
-> EpochNo
-> HardForkLedgerWarning (x : xs)
forall (xs :: [*]).
EraIndex xs
-> EraIndex xs -> EpochNo -> EpochNo -> HardForkLedgerWarning xs
HardForkWarningTransitionReconfirmed
          (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
          EpochNo
t'

shiftUpdate :: HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x ': xs)
shiftUpdate :: 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 :: 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 a (f :: a -> *) (xs :: [a]) (x :: a).
NS f xs -> NS f (x : xs)
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 :: Current (Ticked :.: LedgerState) blk -> LedgerEraInfo blk
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
singleEraInfo (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)

ledgerViewInfo :: forall blk f. SingleEraBlock blk
               => (Ticked :.: f) blk -> LedgerEraInfo blk
ledgerViewInfo :: (:.:) Ticked f blk -> LedgerEraInfo blk
ledgerViewInfo (:.:) Ticked 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
singleEraInfo (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk)

injectLedgerError :: Index xs blk -> LedgerError blk -> HardForkLedgerError xs
injectLedgerError :: 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)
-> (LedgerError blk -> OneEraLedgerError xs)
-> LedgerError 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)
-> (LedgerError blk -> NS WrapLedgerErr xs)
-> LedgerError 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)
-> (LedgerError blk -> WrapLedgerErr blk)
-> LedgerError blk
-> NS WrapLedgerErr xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerError blk -> WrapLedgerErr blk
forall blk. LedgerError blk -> WrapLedgerErr blk
WrapLedgerErr

injectLedgerEvent :: Index xs blk -> AuxLedgerEvent (LedgerState blk) -> OneEraLedgerEvent xs
injectLedgerEvent :: 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