{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# 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
  , FlipTickedLedgerState (..)
  , Ticked (..)

    -- * Low-level API (exported for the benefit of testing)
  , AnnForecast (..)
  , mkHardForkForecast

    -- * Ledger tables
  , ejectLedgerTables
  , injectLedgerTables

    -- ** HardForkTxIn
  , HasCanonicalTxIn (..)

    -- ** HardForkTxOut
  , DefaultHardForkTxOut
  , HasHardForkTxOut (..)
  , MemPackTxOut
  , ejectHardForkTxOutDefault
  , injectHardForkTxOutDefault
  ) where

import Control.Monad (guard)
import Control.Monad.Except (throwError, withExcept)
import qualified Control.State.Transition.Extended as STS
import Data.Functor ((<&>))
import Data.Functor.Product
import Data.Kind (Type)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe, isJust)
import Data.MemPack
import Data.Proxy
import Data.SOP.BasicFunctors
import Data.SOP.Constraint
import Data.SOP.Counting (getExactly)
import Data.SOP.Functors (Flip (..))
import Data.SOP.InPairs (InPairs (..))
import qualified Data.SOP.InPairs as InPairs
import Data.SOP.Index
import qualified Data.SOP.Match as Match
import Data.SOP.Strict
import Data.SOP.Tails (Tails)
import qualified Data.SOP.Tails as Tails
import Data.SOP.Telescope (Telescope (..))
import qualified Data.SOP.Telescope as Telescope
import Data.Typeable
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks (..))
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Forecast
import Ouroboros.Consensus.HardFork.Abstract
import Ouroboros.Consensus.HardFork.Combinator.Abstract
import Ouroboros.Consensus.HardFork.Combinator.AcrossEras
import Ouroboros.Consensus.HardFork.Combinator.Basics
import Ouroboros.Consensus.HardFork.Combinator.Block
import Ouroboros.Consensus.HardFork.Combinator.Info
import Ouroboros.Consensus.HardFork.Combinator.PartialConfig
import Ouroboros.Consensus.HardFork.Combinator.Protocol ()
import Ouroboros.Consensus.HardFork.Combinator.Protocol.LedgerView
import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
import Ouroboros.Consensus.HardFork.Combinator.State.Types
import Ouroboros.Consensus.HardFork.Combinator.Translation
import Ouroboros.Consensus.HardFork.History
  ( Bound (..)
  , EraParams
  , SafeZone (..)
  )
import qualified Ouroboros.Consensus.HardFork.History as History
import Ouroboros.Consensus.HeaderValidation
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.Inspect
import Ouroboros.Consensus.Ledger.SupportsProtocol
import Ouroboros.Consensus.Ledger.Tables.Utils
import Ouroboros.Consensus.Storage.LedgerDB
import Ouroboros.Consensus.TypeFamilyWrappers
import Ouroboros.Consensus.Util.Condense
import Ouroboros.Consensus.Util.IndexedMemPack (IndexedMemPack)

-- $setup
-- >>> import Image.LaTeX.Render
-- >>> import Control.Monad
-- >>> import System.Directory
-- >>>
-- >>> createDirectoryIfMissing True "docs/haddocks/"

{-------------------------------------------------------------------------------
  Errors
-------------------------------------------------------------------------------}

data HardForkLedgerError xs
  = -- | Validation error from one of the eras
    HardForkLedgerErrorFromEra (OneEraLedgerError xs)
  | -- | We tried to apply a block from the wrong era
    HardForkLedgerErrorWrongEra (MismatchEraInfo xs)
  deriving ((forall x.
 HardForkLedgerError xs -> Rep (HardForkLedgerError xs) x)
-> (forall x.
    Rep (HardForkLedgerError xs) x -> HardForkLedgerError xs)
-> Generic (HardForkLedgerError xs)
forall (xs :: [*]) x.
Rep (HardForkLedgerError xs) x -> HardForkLedgerError xs
forall (xs :: [*]) x.
HardForkLedgerError xs -> Rep (HardForkLedgerError xs) x
forall x. Rep (HardForkLedgerError xs) x -> HardForkLedgerError xs
forall x. HardForkLedgerError xs -> Rep (HardForkLedgerError xs) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (xs :: [*]) x.
HardForkLedgerError xs -> Rep (HardForkLedgerError xs) x
from :: forall x. HardForkLedgerError xs -> Rep (HardForkLedgerError xs) x
$cto :: forall (xs :: [*]) x.
Rep (HardForkLedgerError xs) x -> HardForkLedgerError xs
to :: forall x. Rep (HardForkLedgerError xs) x -> HardForkLedgerError xs
Generic, Int -> HardForkLedgerError xs -> ShowS
[HardForkLedgerError xs] -> ShowS
HardForkLedgerError xs -> String
(Int -> HardForkLedgerError xs -> ShowS)
-> (HardForkLedgerError xs -> String)
-> ([HardForkLedgerError xs] -> ShowS)
-> Show (HardForkLedgerError xs)
forall (xs :: [*]).
CanHardFork xs =>
Int -> HardForkLedgerError xs -> ShowS
forall (xs :: [*]).
CanHardFork xs =>
[HardForkLedgerError xs] -> ShowS
forall (xs :: [*]).
CanHardFork xs =>
HardForkLedgerError xs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (xs :: [*]).
CanHardFork xs =>
Int -> HardForkLedgerError xs -> ShowS
showsPrec :: Int -> HardForkLedgerError xs -> ShowS
$cshow :: forall (xs :: [*]).
CanHardFork xs =>
HardForkLedgerError xs -> String
show :: HardForkLedgerError xs -> String
$cshowList :: forall (xs :: [*]).
CanHardFork xs =>
[HardForkLedgerError xs] -> ShowS
showList :: [HardForkLedgerError xs] -> ShowS
Show, HardForkLedgerError xs -> HardForkLedgerError xs -> Bool
(HardForkLedgerError xs -> HardForkLedgerError xs -> Bool)
-> (HardForkLedgerError xs -> HardForkLedgerError xs -> Bool)
-> Eq (HardForkLedgerError xs)
forall (xs :: [*]).
CanHardFork xs =>
HardForkLedgerError xs -> HardForkLedgerError xs -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall (xs :: [*]).
CanHardFork xs =>
HardForkLedgerError xs -> HardForkLedgerError xs -> Bool
== :: HardForkLedgerError xs -> HardForkLedgerError xs -> Bool
$c/= :: forall (xs :: [*]).
CanHardFork xs =>
HardForkLedgerError xs -> HardForkLedgerError xs -> Bool
/= :: HardForkLedgerError xs -> HardForkLedgerError xs -> Bool
Eq, Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo)
Proxy (HardForkLedgerError xs) -> String
(Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo))
-> (Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo))
-> (Proxy (HardForkLedgerError xs) -> String)
-> NoThunks (HardForkLedgerError xs)
forall (xs :: [*]).
CanHardFork xs =>
Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo)
forall (xs :: [*]).
CanHardFork xs =>
Proxy (HardForkLedgerError xs) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo)
noThunks :: Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> HardForkLedgerError xs -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (xs :: [*]).
CanHardFork xs =>
Proxy (HardForkLedgerError xs) -> String
showTypeOf :: Proxy (HardForkLedgerError xs) -> String
NoThunks)

{-------------------------------------------------------------------------------
  GetTip
-------------------------------------------------------------------------------}

instance CanHardFork xs => GetTip (LedgerState (HardForkBlock xs)) where
  getTip :: forall (mk :: MapKind).
LedgerState (HardForkBlock xs) mk
-> Point (LedgerState (HardForkBlock xs))
getTip =
    Point (HardForkBlock xs) -> Point (LedgerState (HardForkBlock xs))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint
      (Point (HardForkBlock xs)
 -> Point (LedgerState (HardForkBlock xs)))
-> (LedgerState (HardForkBlock xs) mk -> Point (HardForkBlock xs))
-> LedgerState (HardForkBlock xs) mk
-> Point (LedgerState (HardForkBlock xs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall blk.
 SingleEraBlock blk =>
 Flip LedgerState mk blk -> Point blk)
-> HardForkState (Flip LedgerState mk) xs
-> Point (HardForkBlock xs)
forall (f :: * -> *) (xs :: [*]).
CanHardFork xs =>
(forall blk. SingleEraBlock blk => f blk -> Point blk)
-> HardForkState f xs -> Point (HardForkBlock xs)
State.getTip (Point (LedgerState blk) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (LedgerState blk) -> Point blk)
-> (Flip LedgerState mk blk -> Point (LedgerState blk))
-> Flip LedgerState mk blk
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState blk mk -> Point (LedgerState blk)
forall (mk :: MapKind).
LedgerState blk mk -> Point (LedgerState blk)
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip (LedgerState blk mk -> Point (LedgerState blk))
-> (Flip LedgerState mk blk -> LedgerState blk mk)
-> Flip LedgerState mk blk
-> Point (LedgerState blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flip LedgerState mk blk -> LedgerState blk mk
forall x1 y1 (f :: x1 -> y1 -> *) (x2 :: y1) (y2 :: x1).
Flip f x2 y2 -> f y2 x2
unFlip)
      (HardForkState (Flip LedgerState mk) xs
 -> Point (HardForkBlock xs))
-> (LedgerState (HardForkBlock xs) mk
    -> HardForkState (Flip LedgerState mk) xs)
-> LedgerState (HardForkBlock xs) mk
-> Point (HardForkBlock xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (HardForkBlock xs) mk
-> HardForkState (Flip LedgerState mk) xs
forall (xs :: [*]) (mk :: MapKind).
LedgerState (HardForkBlock xs) mk
-> HardForkState (Flip LedgerState mk) xs
hardForkLedgerStatePerEra

instance CanHardFork xs => GetTip (Ticked (LedgerState (HardForkBlock xs))) where
  getTip :: forall (mk :: MapKind).
Ticked (LedgerState (HardForkBlock xs)) mk
-> Point (Ticked (LedgerState (HardForkBlock xs)))
getTip =
    Point (HardForkBlock xs)
-> Point (Ticked (LedgerState (HardForkBlock xs)))
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint
      (Point (HardForkBlock xs)
 -> Point (Ticked (LedgerState (HardForkBlock xs))))
-> (Ticked (LedgerState (HardForkBlock xs)) mk
    -> Point (HardForkBlock xs))
-> Ticked (LedgerState (HardForkBlock xs)) mk
-> Point (Ticked (LedgerState (HardForkBlock xs)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall blk.
 SingleEraBlock blk =>
 FlipTickedLedgerState mk blk -> Point blk)
-> HardForkState (FlipTickedLedgerState mk) xs
-> Point (HardForkBlock xs)
forall (f :: * -> *) (xs :: [*]).
CanHardFork xs =>
(forall blk. SingleEraBlock blk => f blk -> Point blk)
-> HardForkState f xs -> Point (HardForkBlock xs)
State.getTip (Point (Ticked (LedgerState blk)) -> Point blk
forall {k1} {k2} (b :: k1) (b' :: k2).
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (Ticked (LedgerState blk)) -> Point blk)
-> (FlipTickedLedgerState mk blk
    -> Point (Ticked (LedgerState blk)))
-> FlipTickedLedgerState mk blk
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState blk) mk -> Point (Ticked (LedgerState blk))
forall (mk :: MapKind).
Ticked (LedgerState blk) mk -> Point (Ticked (LedgerState blk))
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> Point l
getTip (Ticked (LedgerState blk) mk -> Point (Ticked (LedgerState blk)))
-> (FlipTickedLedgerState mk blk -> Ticked (LedgerState blk) mk)
-> FlipTickedLedgerState mk blk
-> Point (Ticked (LedgerState blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlipTickedLedgerState mk blk -> Ticked (LedgerState blk) mk
forall (mk :: MapKind) blk.
FlipTickedLedgerState mk blk -> Ticked (LedgerState blk) mk
getFlipTickedLedgerState)
      (HardForkState (FlipTickedLedgerState mk) xs
 -> Point (HardForkBlock xs))
-> (Ticked (LedgerState (HardForkBlock xs)) mk
    -> HardForkState (FlipTickedLedgerState mk) xs)
-> Ticked (LedgerState (HardForkBlock xs)) mk
-> Point (HardForkBlock xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState (HardForkBlock xs)) mk
-> HardForkState (FlipTickedLedgerState mk) xs
forall (xs :: [*]) (mk :: MapKind).
Ticked (LedgerState (HardForkBlock xs)) mk
-> HardForkState (FlipTickedLedgerState mk) xs
tickedHardForkLedgerStatePerEra

{-------------------------------------------------------------------------------
  Ticking
-------------------------------------------------------------------------------}

newtype FlipTickedLedgerState mk blk = FlipTickedLedgerState
  { forall (mk :: MapKind) blk.
FlipTickedLedgerState mk blk -> Ticked (LedgerState blk) mk
getFlipTickedLedgerState :: Ticked (LedgerState blk) mk
  }

data instance Ticked (LedgerState (HardForkBlock xs)) mk
  = TickedHardForkLedgerState
  { forall (xs :: [*]) (mk :: MapKind).
Ticked (LedgerState (HardForkBlock xs)) mk -> TransitionInfo
tickedHardForkLedgerStateTransition :: !TransitionInfo
  , forall (xs :: [*]) (mk :: MapKind).
Ticked (LedgerState (HardForkBlock xs)) mk
-> HardForkState (FlipTickedLedgerState mk) xs
tickedHardForkLedgerStatePerEra ::
      !(HardForkState (FlipTickedLedgerState mk) xs)
  }

instance CanHardFork xs => IsLedger (LedgerState (HardForkBlock xs)) where
  type LedgerErr (LedgerState (HardForkBlock xs)) = HardForkLedgerError xs

  type AuxLedgerEvent (LedgerState (HardForkBlock xs)) = OneEraLedgerEvent xs

  applyChainTickLedgerResult :: ComputeLedgerEvents
-> LedgerCfg (LedgerState (HardForkBlock xs))
-> SlotNo
-> LedgerState (HardForkBlock xs) EmptyMK
-> LedgerResult
     (LedgerState (HardForkBlock xs))
     (Ticked (LedgerState (HardForkBlock xs)) DiffMK)
applyChainTickLedgerResult ComputeLedgerEvents
evs cfg :: LedgerCfg (LedgerState (HardForkBlock xs))
cfg@HardForkLedgerConfig{Shape xs
PerEraLedgerConfig xs
hardForkLedgerConfigShape :: Shape xs
hardForkLedgerConfigPerEra :: PerEraLedgerConfig xs
hardForkLedgerConfigPerEra :: forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
hardForkLedgerConfigShape :: forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs
..} SlotNo
slot (HardForkLedgerState HardForkState (Flip LedgerState EmptyMK) xs
st) =
    HardForkState
  (LedgerResult (LedgerState (HardForkBlock xs))
   :.: FlipTickedLedgerState DiffMK)
  xs
-> LedgerResult
     (LedgerState (HardForkBlock xs))
     (HardForkState (FlipTickedLedgerState DiffMK) 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
    -> Flip LedgerState DiffMK a
    -> (:.:)
         (LedgerResult (LedgerState (HardForkBlock xs)))
         (FlipTickedLedgerState DiffMK)
         a)
-> NP WrapPartialLedgerConfig xs
-> HardForkState (Flip LedgerState DiffMK) xs
-> HardForkState
     (LedgerResult (LedgerState (HardForkBlock xs))
      :.: FlipTickedLedgerState DiffMK)
     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
-> ComputeLedgerEvents
-> Index xs a
-> WrapPartialLedgerConfig a
-> Flip LedgerState DiffMK a
-> (:.:)
     (LedgerResult (LedgerState (HardForkBlock xs)))
     (FlipTickedLedgerState DiffMK)
     a
forall (xs :: [*]) blk.
(SListI xs, SingleEraBlock blk) =>
EpochInfo (Except PastHorizonException)
-> SlotNo
-> ComputeLedgerEvents
-> Index xs blk
-> WrapPartialLedgerConfig blk
-> Flip LedgerState DiffMK blk
-> (:.:)
     (LedgerResult (LedgerState (HardForkBlock xs)))
     (FlipTickedLedgerState DiffMK)
     blk
tickOne EpochInfo (Except PastHorizonException)
ei SlotNo
slot ComputeLedgerEvents
evs)
          NP WrapPartialLedgerConfig xs
cfgs
          HardForkState (Flip LedgerState DiffMK) xs
extended
      )
      LedgerResult
  (LedgerState (HardForkBlock xs))
  (HardForkState (FlipTickedLedgerState DiffMK) xs)
-> (HardForkState (FlipTickedLedgerState DiffMK) xs
    -> Ticked (LedgerState (HardForkBlock xs)) DiffMK)
-> LedgerResult
     (LedgerState (HardForkBlock xs))
     (Ticked (LedgerState (HardForkBlock xs)) DiffMK)
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \HardForkState (FlipTickedLedgerState DiffMK) xs
l' ->
        TickedHardForkLedgerState
          { tickedHardForkLedgerStateTransition :: TransitionInfo
tickedHardForkLedgerStateTransition =
              -- We are bundling a 'TransitionInfo' with a /ticked/ ledger state,
              -- but /derive/ that 'TransitionInfo' from the /unticked/  (albeit
              -- extended) state. That requires justification. Three cases:
              --
              -- o 'TransitionUnknown'. If the transition is unknown, then it
              --   cannot become known due to ticking. In this case, we record
              --   the tip of the ledger, which ticking also does not modify
              --   (this is an explicit postcondition of 'applyChainTick').
              -- o 'TransitionKnown'. If the transition to the next epoch is
              --   already known, then ticking does not change that information.
              --   It can't be the case that the 'SlotNo' we're ticking to is
              --   /in/ that next era, because if was, then 'extendToSlot' would
              --   have extended the telescope further.
              --   (This does mean however that it is important to use the
              --   /extended/ ledger state, not the original, to determine the
              --   'TransitionInfo'.)
              -- o 'TransitionImpossible'. This has two subcases: either we are
              --   in the final era, in which case ticking certainly won't be able
              --   to change that, or we're forecasting, which is simply not
              --   applicable here.
              HardForkLedgerConfig xs
-> HardForkState (Flip LedgerState DiffMK) xs -> TransitionInfo
forall (xs :: [*]) (mk :: MapKind).
All SingleEraBlock xs =>
HardForkLedgerConfig xs
-> HardForkState (Flip LedgerState mk) xs -> TransitionInfo
State.mostRecentTransitionInfo LedgerCfg (LedgerState (HardForkBlock xs))
HardForkLedgerConfig xs
cfg HardForkState (Flip LedgerState DiffMK) xs
extended
          , tickedHardForkLedgerStatePerEra :: HardForkState (FlipTickedLedgerState DiffMK) xs
tickedHardForkLedgerStatePerEra = HardForkState (FlipTickedLedgerState DiffMK) 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 (Flip LedgerState EmptyMK) xs
-> EpochInfo (Except PastHorizonException)
forall (xs :: [*]) (mk :: MapKind).
All SingleEraBlock xs =>
HardForkLedgerConfig xs
-> HardForkState (Flip LedgerState mk) xs
-> EpochInfo (Except PastHorizonException)
State.epochInfoLedger LedgerCfg (LedgerState (HardForkBlock xs))
HardForkLedgerConfig xs
cfg HardForkState (Flip LedgerState EmptyMK) xs
st

    extended :: HardForkState (Flip LedgerState DiffMK) xs
    extended :: HardForkState (Flip LedgerState DiffMK) xs
extended = HardForkLedgerConfig xs
-> SlotNo
-> HardForkState (Flip LedgerState EmptyMK) xs
-> HardForkState (Flip LedgerState DiffMK) xs
forall (xs :: [*]).
CanHardFork xs =>
HardForkLedgerConfig xs
-> SlotNo
-> HardForkState (Flip LedgerState EmptyMK) xs
-> HardForkState (Flip LedgerState DiffMK) xs
State.extendToSlot LedgerCfg (LedgerState (HardForkBlock xs))
HardForkLedgerConfig xs
cfg SlotNo
slot HardForkState (Flip LedgerState EmptyMK) xs
st

-- | Ticking outside of era transitions for now does not generate differences
-- now that we only have the UTxO table, but we need the same type regardless of
-- whether we are crossing an era boundary or not.
--
-- This function ticks the ledger state using the particular block function, and
-- prepends the diffs that might have been created if this tick crossed an era
-- boundary.
tickOne ::
  (SListI xs, SingleEraBlock blk) =>
  EpochInfo (Except PastHorizonException) ->
  SlotNo ->
  ComputeLedgerEvents ->
  Index xs blk ->
  WrapPartialLedgerConfig blk ->
  (Flip LedgerState DiffMK) blk ->
  ( LedgerResult (LedgerState (HardForkBlock xs))
      :.: FlipTickedLedgerState DiffMK
  )
    blk
tickOne :: forall (xs :: [*]) blk.
(SListI xs, SingleEraBlock blk) =>
EpochInfo (Except PastHorizonException)
-> SlotNo
-> ComputeLedgerEvents
-> Index xs blk
-> WrapPartialLedgerConfig blk
-> Flip LedgerState DiffMK blk
-> (:.:)
     (LedgerResult (LedgerState (HardForkBlock xs)))
     (FlipTickedLedgerState DiffMK)
     blk
tickOne EpochInfo (Except PastHorizonException)
ei SlotNo
slot ComputeLedgerEvents
evs Index xs blk
sopIdx WrapPartialLedgerConfig blk
partialCfg Flip LedgerState DiffMK blk
st =
  LedgerResult
  (LedgerState (HardForkBlock xs)) (FlipTickedLedgerState DiffMK blk)
-> (:.:)
     (LedgerResult (LedgerState (HardForkBlock xs)))
     (FlipTickedLedgerState DiffMK)
     blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp
    (LedgerResult
   (LedgerState (HardForkBlock xs)) (FlipTickedLedgerState DiffMK blk)
 -> (:.:)
      (LedgerResult (LedgerState (HardForkBlock xs)))
      (FlipTickedLedgerState DiffMK)
      blk)
-> (Flip LedgerState DiffMK blk
    -> LedgerResult
         (LedgerState (HardForkBlock xs))
         (FlipTickedLedgerState DiffMK blk))
-> Flip LedgerState DiffMK blk
-> (:.:)
     (LedgerResult (LedgerState (HardForkBlock xs)))
     (FlipTickedLedgerState DiffMK)
     blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Ticked (LedgerState blk) DiffMK
 -> FlipTickedLedgerState DiffMK blk)
-> LedgerResult
     (LedgerState (HardForkBlock xs)) (Ticked (LedgerState blk) DiffMK)
-> LedgerResult
     (LedgerState (HardForkBlock xs)) (FlipTickedLedgerState DiffMK blk)
forall a b.
(a -> b)
-> LedgerResult (LedgerState (HardForkBlock xs)) a
-> LedgerResult (LedgerState (HardForkBlock xs)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
      ( Ticked (LedgerState blk) DiffMK -> FlipTickedLedgerState DiffMK blk
forall (mk :: MapKind) blk.
Ticked (LedgerState blk) mk -> FlipTickedLedgerState mk blk
FlipTickedLedgerState
          (Ticked (LedgerState blk) DiffMK
 -> FlipTickedLedgerState DiffMK blk)
-> (Ticked (LedgerState blk) DiffMK
    -> Ticked (LedgerState blk) DiffMK)
-> Ticked (LedgerState blk) DiffMK
-> FlipTickedLedgerState DiffMK blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState blk DiffMK
-> Ticked (LedgerState blk) DiffMK
-> Ticked (LedgerState blk) DiffMK
forall (l :: LedgerStateKind) (l' :: LedgerStateKind).
(SameUtxoTypes l l', HasLedgerTables l, HasLedgerTables l') =>
l DiffMK -> l' DiffMK -> l' DiffMK
prependDiffs (Flip LedgerState DiffMK blk -> LedgerState blk DiffMK
forall x1 y1 (f :: x1 -> y1 -> *) (x2 :: y1) (y2 :: x1).
Flip f x2 y2 -> f y2 x2
unFlip Flip LedgerState DiffMK blk
st)
      )
    (LedgerResult
   (LedgerState (HardForkBlock xs)) (Ticked (LedgerState blk) DiffMK)
 -> LedgerResult
      (LedgerState (HardForkBlock xs))
      (FlipTickedLedgerState DiffMK blk))
-> (Flip LedgerState DiffMK blk
    -> LedgerResult
         (LedgerState (HardForkBlock xs)) (Ticked (LedgerState blk) DiffMK))
-> Flip LedgerState DiffMK blk
-> LedgerResult
     (LedgerState (HardForkBlock xs)) (FlipTickedLedgerState DiffMK blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AuxLedgerEvent (LedgerState blk)
 -> AuxLedgerEvent (LedgerState (HardForkBlock xs)))
-> LedgerResult (LedgerState blk) (Ticked (LedgerState blk) DiffMK)
-> LedgerResult
     (LedgerState (HardForkBlock xs)) (Ticked (LedgerState blk) DiffMK)
forall (l :: LedgerStateKind) (l' :: LedgerStateKind) a.
(AuxLedgerEvent l -> AuxLedgerEvent l')
-> LedgerResult l a -> LedgerResult l' a
embedLedgerResult (Index xs blk
-> AuxLedgerEvent (LedgerState blk) -> OneEraLedgerEvent xs
forall (xs :: [*]) blk.
SListI xs =>
Index xs blk
-> AuxLedgerEvent (LedgerState blk) -> OneEraLedgerEvent xs
injectLedgerEvent Index xs blk
sopIdx)
    (LedgerResult (LedgerState blk) (Ticked (LedgerState blk) DiffMK)
 -> LedgerResult
      (LedgerState (HardForkBlock xs)) (Ticked (LedgerState blk) DiffMK))
-> (Flip LedgerState DiffMK blk
    -> LedgerResult
         (LedgerState blk) (Ticked (LedgerState blk) DiffMK))
-> Flip LedgerState DiffMK blk
-> LedgerResult
     (LedgerState (HardForkBlock xs)) (Ticked (LedgerState blk) DiffMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ComputeLedgerEvents
-> LedgerCfg (LedgerState blk)
-> SlotNo
-> LedgerState blk EmptyMK
-> LedgerResult (LedgerState blk) (Ticked (LedgerState blk) DiffMK)
forall (l :: LedgerStateKind).
IsLedger l =>
ComputeLedgerEvents
-> LedgerCfg l
-> SlotNo
-> l EmptyMK
-> LedgerResult l (Ticked l DiffMK)
applyChainTickLedgerResult ComputeLedgerEvents
evs (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
partialCfg) SlotNo
slot
    (LedgerState blk EmptyMK
 -> LedgerResult
      (LedgerState blk) (Ticked (LedgerState blk) DiffMK))
-> (Flip LedgerState DiffMK blk -> LedgerState blk EmptyMK)
-> Flip LedgerState DiffMK blk
-> LedgerResult (LedgerState blk) (Ticked (LedgerState blk) DiffMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState blk DiffMK -> LedgerState blk EmptyMK
forall (l :: LedgerStateKind) (mk :: MapKind).
HasLedgerTables l =>
l mk -> l EmptyMK
forgetLedgerTables
    (LedgerState blk DiffMK -> LedgerState blk EmptyMK)
-> (Flip LedgerState DiffMK blk -> LedgerState blk DiffMK)
-> Flip LedgerState DiffMK blk
-> LedgerState blk EmptyMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flip LedgerState DiffMK blk -> LedgerState blk DiffMK
forall x1 y1 (f :: x1 -> y1 -> *) (x2 :: y1) (y2 :: x1).
Flip f x2 y2 -> f y2 x2
unFlip
    (Flip LedgerState DiffMK blk
 -> (:.:)
      (LedgerResult (LedgerState (HardForkBlock xs)))
      (FlipTickedLedgerState DiffMK)
      blk)
-> Flip LedgerState DiffMK blk
-> (:.:)
     (LedgerResult (LedgerState (HardForkBlock xs)))
     (FlipTickedLedgerState DiffMK)
     blk
forall a b. (a -> b) -> a -> b
$ Flip LedgerState DiffMK blk
st

{-------------------------------------------------------------------------------
  ApplyBlock
-------------------------------------------------------------------------------}

instance
  ( CanHardFork xs
  , HasCanonicalTxIn xs
  , HasHardForkTxOut xs
  ) =>
  ApplyBlock (LedgerState (HardForkBlock xs)) (HardForkBlock xs)
  where
  applyBlockLedgerResultWithValidation :: HasCallStack =>
ValidationPolicy
-> ComputeLedgerEvents
-> LedgerCfg (LedgerState (HardForkBlock xs))
-> HardForkBlock xs
-> Ticked (LedgerState (HardForkBlock xs)) ValuesMK
-> Except
     (LedgerErr (LedgerState (HardForkBlock xs)))
     (LedgerResult
        (LedgerState (HardForkBlock xs))
        (LedgerState (HardForkBlock xs) DiffMK))
applyBlockLedgerResultWithValidation
    ValidationPolicy
doValidate
    ComputeLedgerEvents
opts
    LedgerCfg (LedgerState (HardForkBlock xs))
cfg
    (HardForkBlock (OneEraBlock NS I xs
block))
    (TickedHardForkLedgerState TransitionInfo
transition HardForkState (FlipTickedLedgerState ValuesMK) xs
st) =
      case NS I xs
-> HardForkState (FlipTickedLedgerState ValuesMK) xs
-> Either
     (Mismatch I (Current (FlipTickedLedgerState ValuesMK)) xs)
     (HardForkState (Product I (FlipTickedLedgerState ValuesMK)) 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 (FlipTickedLedgerState ValuesMK) xs
st of
        Left Mismatch I (Current (FlipTickedLedgerState ValuesMK)) xs
mismatch ->
          -- Block from the wrong era (note that 'applyChainTick' will already
          -- have initiated the transition to the next era if appropriate).
          HardForkLedgerError xs
-> Except
     (LedgerErr (LedgerState (HardForkBlock xs)))
     (LedgerResult
        (LedgerState (HardForkBlock xs))
        (LedgerState (HardForkBlock xs) DiffMK))
forall a.
HardForkLedgerError xs
-> ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (HardForkLedgerError xs
 -> Except
      (LedgerErr (LedgerState (HardForkBlock xs)))
      (LedgerResult
         (LedgerState (HardForkBlock xs))
         (LedgerState (HardForkBlock xs) DiffMK)))
-> HardForkLedgerError xs
-> Except
     (LedgerErr (LedgerState (HardForkBlock xs)))
     (LedgerResult
        (LedgerState (HardForkBlock xs))
        (LedgerState (HardForkBlock xs) DiffMK))
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 (FlipTickedLedgerState ValuesMK) x -> LedgerEraInfo x)
-> Mismatch I (Current (FlipTickedLedgerState ValuesMK)) xs
-> Mismatch SingleEraInfo LedgerEraInfo xs
forall {k} (c :: k -> Constraint) (xs :: [k])
       (proxy :: (k -> Constraint) -> *) (f :: k -> *) (f' :: k -> *)
       (g :: k -> *) (g' :: k -> *).
All c xs =>
proxy c
-> (forall (x :: k). c x => f x -> f' x)
-> (forall (x :: k). c x => g x -> g' x)
-> Mismatch f g xs
-> Mismatch f' g' xs
Match.bihcmap Proxy SingleEraBlock
proxySingle I x -> SingleEraInfo x
forall x. SingleEraBlock x => I x -> SingleEraInfo x
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
forall (proxy :: * -> *). proxy x -> SingleEraInfo x
singleEraInfo Current (FlipTickedLedgerState ValuesMK) x -> LedgerEraInfo x
forall x.
SingleEraBlock x =>
Current (FlipTickedLedgerState ValuesMK) x -> LedgerEraInfo x
forall blk (mk :: MapKind).
SingleEraBlock blk =>
Current (FlipTickedLedgerState mk) blk -> LedgerEraInfo blk
ledgerInfo Mismatch I (Current (FlipTickedLedgerState ValuesMK)) xs
mismatch
        Right HardForkState (Product I (FlipTickedLedgerState ValuesMK)) xs
matched ->
          (HardForkState
   (LedgerResult (LedgerState (HardForkBlock xs))
    :.: Flip LedgerState DiffMK)
   xs
 -> LedgerResult
      (LedgerState (HardForkBlock xs))
      (LedgerState (HardForkBlock xs) DiffMK))
-> ExceptT
     (LedgerErr (LedgerState (HardForkBlock xs)))
     Identity
     (HardForkState
        (LedgerResult (LedgerState (HardForkBlock xs))
         :.: Flip LedgerState DiffMK)
        xs)
-> Except
     (LedgerErr (LedgerState (HardForkBlock xs)))
     (LedgerResult
        (LedgerState (HardForkBlock xs))
        (LedgerState (HardForkBlock xs) DiffMK))
forall a b.
(a -> b)
-> ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity a
-> ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((HardForkState (Flip LedgerState DiffMK) xs
 -> LedgerState (HardForkBlock xs) DiffMK)
-> LedgerResult
     (LedgerState (HardForkBlock xs))
     (HardForkState (Flip LedgerState DiffMK) xs)
-> LedgerResult
     (LedgerState (HardForkBlock xs))
     (LedgerState (HardForkBlock xs) DiffMK)
forall a b.
(a -> b)
-> LedgerResult (LedgerState (HardForkBlock xs)) a
-> LedgerResult (LedgerState (HardForkBlock xs)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HardForkState (Flip LedgerState DiffMK) xs
-> LedgerState (HardForkBlock xs) DiffMK
forall (xs :: [*]) (mk :: MapKind).
HardForkState (Flip LedgerState mk) xs
-> LedgerState (HardForkBlock xs) mk
HardForkLedgerState (LedgerResult
   (LedgerState (HardForkBlock xs))
   (HardForkState (Flip LedgerState DiffMK) xs)
 -> LedgerResult
      (LedgerState (HardForkBlock xs))
      (LedgerState (HardForkBlock xs) DiffMK))
-> (HardForkState
      (LedgerResult (LedgerState (HardForkBlock xs))
       :.: Flip LedgerState DiffMK)
      xs
    -> LedgerResult
         (LedgerState (HardForkBlock xs))
         (HardForkState (Flip LedgerState DiffMK) xs))
-> HardForkState
     (LedgerResult (LedgerState (HardForkBlock xs))
      :.: Flip LedgerState DiffMK)
     xs
-> LedgerResult
     (LedgerState (HardForkBlock xs))
     (LedgerState (HardForkBlock xs) DiffMK)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkState
  (LedgerResult (LedgerState (HardForkBlock xs))
   :.: Flip LedgerState DiffMK)
  xs
-> LedgerResult
     (LedgerState (HardForkBlock xs))
     (HardForkState (Flip LedgerState DiffMK) xs)
forall (m :: * -> *) (f :: * -> *) (xs :: [*]).
(All Top xs, Functor m) =>
HardForkState (m :.: f) xs -> m (HardForkState f xs)
sequenceHardForkState) (ExceptT
   (LedgerErr (LedgerState (HardForkBlock xs)))
   Identity
   (HardForkState
      (LedgerResult (LedgerState (HardForkBlock xs))
       :.: Flip LedgerState DiffMK)
      xs)
 -> Except
      (LedgerErr (LedgerState (HardForkBlock xs)))
      (LedgerResult
         (LedgerState (HardForkBlock xs))
         (LedgerState (HardForkBlock xs) DiffMK)))
-> ExceptT
     (LedgerErr (LedgerState (HardForkBlock xs)))
     Identity
     (HardForkState
        (LedgerResult (LedgerState (HardForkBlock xs))
         :.: Flip LedgerState DiffMK)
        xs)
-> Except
     (LedgerErr (LedgerState (HardForkBlock xs)))
     (LedgerResult
        (LedgerState (HardForkBlock xs))
        (LedgerState (HardForkBlock xs) DiffMK))
forall a b. (a -> b) -> a -> b
$
            HardForkState
  (ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity
   :.: (LedgerResult (LedgerState (HardForkBlock xs))
        :.: Flip LedgerState DiffMK))
  xs
-> ExceptT
     (LedgerErr (LedgerState (HardForkBlock xs)))
     Identity
     (HardForkState
        (LedgerResult (LedgerState (HardForkBlock xs))
         :.: Flip LedgerState DiffMK)
        xs)
forall (xs :: [*]) (f :: * -> *) (g :: * -> *).
(SListIN HardForkState xs, Applicative f) =>
HardForkState (f :.: g) xs -> f (HardForkState g xs)
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: * -> *)
       (g :: k -> *).
(HSequence h, SListIN h xs, Applicative f) =>
h (f :.: g) xs -> f (h g xs)
hsequence' (HardForkState
   (ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity
    :.: (LedgerResult (LedgerState (HardForkBlock xs))
         :.: Flip LedgerState DiffMK))
   xs
 -> ExceptT
      (LedgerErr (LedgerState (HardForkBlock xs)))
      Identity
      (HardForkState
         (LedgerResult (LedgerState (HardForkBlock xs))
          :.: Flip LedgerState DiffMK)
         xs))
-> HardForkState
     (ExceptT (LedgerErr (LedgerState (HardForkBlock xs))) Identity
      :.: (LedgerResult (LedgerState (HardForkBlock xs))
           :.: Flip LedgerState DiffMK))
     xs
-> ExceptT
     (LedgerErr (LedgerState (HardForkBlock xs)))
     Identity
     (HardForkState
        (LedgerResult (LedgerState (HardForkBlock xs))
         :.: Flip LedgerState DiffMK)
        xs)
forall a b. (a -> b) -> a -> b
$
              Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    Index xs a
    -> WrapLedgerConfig a
    -> Product I (FlipTickedLedgerState ValuesMK) a
    -> (:.:)
         (ExceptT (HardForkLedgerError xs) Identity)
         (LedgerResult (LedgerState (HardForkBlock xs))
          :.: Flip LedgerState DiffMK)
         a)
-> NP WrapLedgerConfig xs
-> HardForkState (Product I (FlipTickedLedgerState ValuesMK)) xs
-> HardForkState
     (ExceptT (HardForkLedgerError xs) Identity
      :.: (LedgerResult (LedgerState (HardForkBlock xs))
           :.: Flip LedgerState DiffMK))
     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 (ValidationPolicy
-> ComputeLedgerEvents
-> Index xs a
-> WrapLedgerConfig a
-> Product I (FlipTickedLedgerState ValuesMK) a
-> (:.:)
     (ExceptT (HardForkLedgerError xs) Identity)
     (LedgerResult (LedgerState (HardForkBlock xs))
      :.: Flip LedgerState DiffMK)
     a
forall (xs :: [*]) blk.
(SListI xs, SingleEraBlock blk) =>
ValidationPolicy
-> ComputeLedgerEvents
-> Index xs blk
-> WrapLedgerConfig blk
-> Product I (FlipTickedLedgerState ValuesMK) blk
-> (:.:)
     (Except (HardForkLedgerError xs))
     (LedgerResult (LedgerState (HardForkBlock xs))
      :.: Flip LedgerState DiffMK)
     blk
apply ValidationPolicy
doValidate ComputeLedgerEvents
opts) NP WrapLedgerConfig xs
cfgs HardForkState (Product I (FlipTickedLedgerState ValuesMK)) 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 (FlipTickedLedgerState ValuesMK) 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 (FlipTickedLedgerState ValuesMK) xs
st

  applyBlockLedgerResult :: HasCallStack =>
ComputeLedgerEvents
-> LedgerCfg (LedgerState (HardForkBlock xs))
-> HardForkBlock xs
-> Ticked (LedgerState (HardForkBlock xs)) ValuesMK
-> Except
     (LedgerErr (LedgerState (HardForkBlock xs)))
     (LedgerResult
        (LedgerState (HardForkBlock xs))
        (LedgerState (HardForkBlock xs) DiffMK))
applyBlockLedgerResult = ComputeLedgerEvents
-> LedgerCfg (LedgerState (HardForkBlock xs))
-> HardForkBlock xs
-> Ticked (LedgerState (HardForkBlock xs)) ValuesMK
-> Except
     (LedgerErr (LedgerState (HardForkBlock xs)))
     (LedgerResult
        (LedgerState (HardForkBlock xs))
        (LedgerState (HardForkBlock xs) DiffMK))
forall (l :: LedgerStateKind) blk.
(HasCallStack, ApplyBlock l blk) =>
ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> Ticked l ValuesMK
-> Except (LedgerErr l) (LedgerResult l (l DiffMK))
defaultApplyBlockLedgerResult

  reapplyBlockLedgerResult :: HasCallStack =>
ComputeLedgerEvents
-> LedgerCfg (LedgerState (HardForkBlock xs))
-> HardForkBlock xs
-> Ticked (LedgerState (HardForkBlock xs)) ValuesMK
-> LedgerResult
     (LedgerState (HardForkBlock xs))
     (LedgerState (HardForkBlock xs) DiffMK)
reapplyBlockLedgerResult =
    (LedgerErr (LedgerState (HardForkBlock xs))
 -> LedgerResult
      (LedgerState (HardForkBlock xs))
      (LedgerState (HardForkBlock xs) DiffMK))
-> ComputeLedgerEvents
-> LedgerCfg (LedgerState (HardForkBlock xs))
-> HardForkBlock xs
-> Ticked (LedgerState (HardForkBlock xs)) ValuesMK
-> LedgerResult
     (LedgerState (HardForkBlock xs))
     (LedgerState (HardForkBlock xs) DiffMK)
forall (l :: LedgerStateKind) blk.
(HasCallStack, ApplyBlock l blk) =>
(LedgerErr l -> LedgerResult l (l DiffMK))
-> ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> Ticked l ValuesMK
-> LedgerResult l (l DiffMK)
defaultReapplyBlockLedgerResult
      ( \LedgerErr (LedgerState (HardForkBlock xs))
_ ->
          -- 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) DiffMK)
forall a. HasCallStack => String -> a
error String
"reapplyBlockLedgerResult: can't be from other era"
      )

  getBlockKeySets :: HardForkBlock xs
-> LedgerTables (LedgerState (HardForkBlock xs)) KeysMK
getBlockKeySets (HardForkBlock (OneEraBlock NS I xs
ns)) =
    NS (K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK)) xs
-> CollapseTo
     NS (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK)
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK)) xs
 -> CollapseTo
      NS (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK))
-> NS (K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK)) xs
-> CollapseTo
     NS (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK)
forall a b. (a -> b) -> a -> b
$
      Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    Index xs a
    -> I a
    -> K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK) a)
-> NS I xs
-> NS (K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK)) xs
forall {k} (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint)
       (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *)
       (f2 :: k -> *).
(HAp h, All c xs, Prod h ~ NP) =>
proxy c
-> (forall (a :: k). c a => Index xs a -> f1 a -> f2 a)
-> h f1 xs
-> h f2 xs
hcimap Proxy SingleEraBlock
proxySingle Index xs a
-> I a
-> K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK) a
forall a.
SingleEraBlock a =>
Index xs a
-> I a
-> K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK) a
f NS I xs
ns
   where
    f ::
      SingleEraBlock x =>
      Index xs x ->
      I x ->
      K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK) x
    f :: forall a.
SingleEraBlock a =>
Index xs a
-> I a
-> K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK) a
f Index xs x
idx (I x
blk) = LedgerTables (LedgerState (HardForkBlock xs)) KeysMK
-> K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK) x
forall k a (b :: k). a -> K a b
K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK
 -> K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK) x)
-> LedgerTables (LedgerState (HardForkBlock xs)) KeysMK
-> K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK) x
forall a b. (a -> b) -> a -> b
$ Index xs x
-> LedgerTables (LedgerState x) KeysMK
-> LedgerTables (LedgerState (HardForkBlock xs)) KeysMK
forall (xs :: [*]) x (mk :: MapKind).
(CanMapKeysMK mk, CanMapMK mk, HasCanonicalTxIn xs,
 HasHardForkTxOut xs) =>
Index xs x
-> LedgerTables (LedgerState x) mk
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
injectLedgerTables Index xs x
idx (LedgerTables (LedgerState x) KeysMK
 -> LedgerTables (LedgerState (HardForkBlock xs)) KeysMK)
-> LedgerTables (LedgerState x) KeysMK
-> LedgerTables (LedgerState (HardForkBlock xs)) KeysMK
forall a b. (a -> b) -> a -> b
$ x -> LedgerTables (LedgerState x) KeysMK
forall (l :: LedgerStateKind) blk.
ApplyBlock l blk =>
blk -> LedgerTables l KeysMK
getBlockKeySets x
blk

apply ::
  (SListI xs, SingleEraBlock blk) =>
  STS.ValidationPolicy ->
  ComputeLedgerEvents ->
  Index xs blk ->
  WrapLedgerConfig blk ->
  Product I (FlipTickedLedgerState ValuesMK) blk ->
  ( Except (HardForkLedgerError xs)
      :.: LedgerResult (LedgerState (HardForkBlock xs))
      :.: Flip LedgerState DiffMK
  )
    blk
apply :: forall (xs :: [*]) blk.
(SListI xs, SingleEraBlock blk) =>
ValidationPolicy
-> ComputeLedgerEvents
-> Index xs blk
-> WrapLedgerConfig blk
-> Product I (FlipTickedLedgerState ValuesMK) blk
-> (:.:)
     (Except (HardForkLedgerError xs))
     (LedgerResult (LedgerState (HardForkBlock xs))
      :.: Flip LedgerState DiffMK)
     blk
apply ValidationPolicy
doValidate ComputeLedgerEvents
opts Index xs blk
index (WrapLedgerConfig LedgerConfig blk
cfg) (Pair (I blk
block) (FlipTickedLedgerState Ticked (LedgerState blk) ValuesMK
st)) =
  Except
  (HardForkLedgerError xs)
  ((:.:)
     (LedgerResult (LedgerState (HardForkBlock xs)))
     (Flip LedgerState DiffMK)
     blk)
-> (:.:)
     (Except (HardForkLedgerError xs))
     (LedgerResult (LedgerState (HardForkBlock xs))
      :.: Flip LedgerState DiffMK)
     blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (Except
   (HardForkLedgerError xs)
   ((:.:)
      (LedgerResult (LedgerState (HardForkBlock xs)))
      (Flip LedgerState DiffMK)
      blk)
 -> (:.:)
      (Except (HardForkLedgerError xs))
      (LedgerResult (LedgerState (HardForkBlock xs))
       :.: Flip LedgerState DiffMK)
      blk)
-> Except
     (HardForkLedgerError xs)
     ((:.:)
        (LedgerResult (LedgerState (HardForkBlock xs)))
        (Flip LedgerState DiffMK)
        blk)
-> (:.:)
     (Except (HardForkLedgerError xs))
     (LedgerResult (LedgerState (HardForkBlock xs))
      :.: Flip LedgerState DiffMK)
     blk
forall a b. (a -> b) -> a -> b
$
    (LedgerErr (LedgerState blk) -> HardForkLedgerError xs)
-> Except
     (LedgerErr (LedgerState blk))
     ((:.:)
        (LedgerResult (LedgerState (HardForkBlock xs)))
        (Flip LedgerState DiffMK)
        blk)
-> Except
     (HardForkLedgerError xs)
     ((:.:)
        (LedgerResult (LedgerState (HardForkBlock xs)))
        (Flip LedgerState DiffMK)
        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.
SListI xs =>
Index xs blk -> LedgerError blk -> HardForkLedgerError xs
injectLedgerError Index xs blk
index) (Except
   (LedgerErr (LedgerState blk))
   ((:.:)
      (LedgerResult (LedgerState (HardForkBlock xs)))
      (Flip LedgerState DiffMK)
      blk)
 -> Except
      (HardForkLedgerError xs)
      ((:.:)
         (LedgerResult (LedgerState (HardForkBlock xs)))
         (Flip LedgerState DiffMK)
         blk))
-> Except
     (LedgerErr (LedgerState blk))
     ((:.:)
        (LedgerResult (LedgerState (HardForkBlock xs)))
        (Flip LedgerState DiffMK)
        blk)
-> Except
     (HardForkLedgerError xs)
     ((:.:)
        (LedgerResult (LedgerState (HardForkBlock xs)))
        (Flip LedgerState DiffMK)
        blk)
forall a b. (a -> b) -> a -> b
$
      (LedgerResult (LedgerState blk) (LedgerState blk DiffMK)
 -> (:.:)
      (LedgerResult (LedgerState (HardForkBlock xs)))
      (Flip LedgerState DiffMK)
      blk)
-> ExceptT
     (LedgerErr (LedgerState blk))
     Identity
     (LedgerResult (LedgerState blk) (LedgerState blk DiffMK))
-> Except
     (LedgerErr (LedgerState blk))
     ((:.:)
        (LedgerResult (LedgerState (HardForkBlock xs)))
        (Flip LedgerState DiffMK)
        blk)
forall a b.
(a -> b)
-> ExceptT (LedgerErr (LedgerState blk)) Identity a
-> ExceptT (LedgerErr (LedgerState blk)) Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LedgerResult
  (LedgerState (HardForkBlock xs)) (Flip LedgerState DiffMK blk)
-> (:.:)
     (LedgerResult (LedgerState (HardForkBlock xs)))
     (Flip LedgerState DiffMK)
     blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (LedgerResult
   (LedgerState (HardForkBlock xs)) (Flip LedgerState DiffMK blk)
 -> (:.:)
      (LedgerResult (LedgerState (HardForkBlock xs)))
      (Flip LedgerState DiffMK)
      blk)
-> (LedgerResult (LedgerState blk) (LedgerState blk DiffMK)
    -> LedgerResult
         (LedgerState (HardForkBlock xs)) (Flip LedgerState DiffMK blk))
-> LedgerResult (LedgerState blk) (LedgerState blk DiffMK)
-> (:.:)
     (LedgerResult (LedgerState (HardForkBlock xs)))
     (Flip LedgerState DiffMK)
     blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerState blk DiffMK -> Flip LedgerState DiffMK blk)
-> LedgerResult
     (LedgerState (HardForkBlock xs)) (LedgerState blk DiffMK)
-> LedgerResult
     (LedgerState (HardForkBlock xs)) (Flip LedgerState DiffMK blk)
forall a b.
(a -> b)
-> LedgerResult (LedgerState (HardForkBlock xs)) a
-> LedgerResult (LedgerState (HardForkBlock xs)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LedgerState blk DiffMK -> Flip LedgerState DiffMK blk
forall x y (f :: x -> y -> *) (x1 :: y) (y1 :: x).
f y1 x1 -> Flip f x1 y1
Flip (LedgerResult
   (LedgerState (HardForkBlock xs)) (LedgerState blk DiffMK)
 -> LedgerResult
      (LedgerState (HardForkBlock xs)) (Flip LedgerState DiffMK blk))
-> (LedgerResult (LedgerState blk) (LedgerState blk DiffMK)
    -> LedgerResult
         (LedgerState (HardForkBlock xs)) (LedgerState blk DiffMK))
-> LedgerResult (LedgerState blk) (LedgerState blk DiffMK)
-> LedgerResult
     (LedgerState (HardForkBlock xs)) (Flip LedgerState DiffMK blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AuxLedgerEvent (LedgerState blk)
 -> AuxLedgerEvent (LedgerState (HardForkBlock xs)))
-> LedgerResult (LedgerState blk) (LedgerState blk DiffMK)
-> LedgerResult
     (LedgerState (HardForkBlock xs)) (LedgerState blk DiffMK)
forall (l :: LedgerStateKind) (l' :: LedgerStateKind) a.
(AuxLedgerEvent l -> AuxLedgerEvent l')
-> LedgerResult l a -> LedgerResult l' a
embedLedgerResult (Index xs blk
-> AuxLedgerEvent (LedgerState blk) -> OneEraLedgerEvent xs
forall (xs :: [*]) blk.
SListI xs =>
Index xs blk
-> AuxLedgerEvent (LedgerState blk) -> OneEraLedgerEvent xs
injectLedgerEvent Index xs blk
index)) (ExceptT
   (LedgerErr (LedgerState blk))
   Identity
   (LedgerResult (LedgerState blk) (LedgerState blk DiffMK))
 -> Except
      (LedgerErr (LedgerState blk))
      ((:.:)
         (LedgerResult (LedgerState (HardForkBlock xs)))
         (Flip LedgerState DiffMK)
         blk))
-> ExceptT
     (LedgerErr (LedgerState blk))
     Identity
     (LedgerResult (LedgerState blk) (LedgerState blk DiffMK))
-> Except
     (LedgerErr (LedgerState blk))
     ((:.:)
        (LedgerResult (LedgerState (HardForkBlock xs)))
        (Flip LedgerState DiffMK)
        blk)
forall a b. (a -> b) -> a -> b
$
        ValidationPolicy
-> ComputeLedgerEvents
-> LedgerConfig blk
-> blk
-> Ticked (LedgerState blk) ValuesMK
-> ExceptT
     (LedgerErr (LedgerState blk))
     Identity
     (LedgerResult (LedgerState blk) (LedgerState blk DiffMK))
forall (l :: LedgerStateKind) blk.
(ApplyBlock l blk, HasCallStack) =>
ValidationPolicy
-> ComputeLedgerEvents
-> LedgerCfg l
-> blk
-> Ticked l ValuesMK
-> Except (LedgerErr l) (LedgerResult l (l DiffMK))
applyBlockLedgerResultWithValidation ValidationPolicy
doValidate ComputeLedgerEvents
opts LedgerConfig blk
cfg blk
block Ticked (LedgerState blk) ValuesMK
st

{-------------------------------------------------------------------------------
  UpdateLedger
-------------------------------------------------------------------------------}

instance
  ( CanHardFork xs
  , HasCanonicalTxIn xs
  , HasHardForkTxOut xs
  ) =>
  UpdateLedger (HardForkBlock xs)

{-------------------------------------------------------------------------------
  HasHardForkHistory
-------------------------------------------------------------------------------}

instance All SingleEraBlock xs => HasHardForkHistory (HardForkBlock xs) where
  type HardForkIndices (HardForkBlock xs) = xs

  hardForkSummary :: forall (mk :: MapKind).
LedgerConfig (HardForkBlock xs)
-> LedgerState (HardForkBlock xs) mk
-> Summary (HardForkIndices (HardForkBlock xs))
hardForkSummary LedgerConfig (HardForkBlock xs)
cfg =
    HardForkLedgerConfig xs
-> HardForkState (Flip LedgerState mk) xs -> Summary xs
forall (xs :: [*]) (mk :: MapKind).
All SingleEraBlock xs =>
HardForkLedgerConfig xs
-> HardForkState (Flip LedgerState mk) xs -> Summary xs
State.reconstructSummaryLedger LedgerConfig (HardForkBlock xs)
HardForkLedgerConfig xs
cfg
      (HardForkState (Flip LedgerState mk) xs -> Summary xs)
-> (LedgerState (HardForkBlock xs) mk
    -> HardForkState (Flip LedgerState mk) xs)
-> LedgerState (HardForkBlock xs) mk
-> Summary xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (HardForkBlock xs) mk
-> HardForkState (Flip LedgerState mk) xs
forall (xs :: [*]) (mk :: MapKind).
LedgerState (HardForkBlock xs) mk
-> HardForkState (Flip LedgerState mk) xs
hardForkLedgerStatePerEra

{-------------------------------------------------------------------------------
  HeaderValidation
-------------------------------------------------------------------------------}

data HardForkEnvelopeErr xs
  = -- | Validation error from one of the eras
    HardForkEnvelopeErrFromEra (OneEraEnvelopeErr xs)
  | -- | We tried to apply a block from the wrong era
    HardForkEnvelopeErrWrongEra (MismatchEraInfo xs)
  deriving (HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool
(HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool)
-> (HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool)
-> Eq (HardForkEnvelopeErr xs)
forall (xs :: [*]).
CanHardFork xs =>
HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall (xs :: [*]).
CanHardFork xs =>
HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool
== :: HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool
$c/= :: forall (xs :: [*]).
CanHardFork xs =>
HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool
/= :: HardForkEnvelopeErr xs -> HardForkEnvelopeErr xs -> Bool
Eq, Int -> HardForkEnvelopeErr xs -> ShowS
[HardForkEnvelopeErr xs] -> ShowS
HardForkEnvelopeErr xs -> String
(Int -> HardForkEnvelopeErr xs -> ShowS)
-> (HardForkEnvelopeErr xs -> String)
-> ([HardForkEnvelopeErr xs] -> ShowS)
-> Show (HardForkEnvelopeErr xs)
forall (xs :: [*]).
CanHardFork xs =>
Int -> HardForkEnvelopeErr xs -> ShowS
forall (xs :: [*]).
CanHardFork xs =>
[HardForkEnvelopeErr xs] -> ShowS
forall (xs :: [*]).
CanHardFork xs =>
HardForkEnvelopeErr xs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (xs :: [*]).
CanHardFork xs =>
Int -> HardForkEnvelopeErr xs -> ShowS
showsPrec :: Int -> HardForkEnvelopeErr xs -> ShowS
$cshow :: forall (xs :: [*]).
CanHardFork xs =>
HardForkEnvelopeErr xs -> String
show :: HardForkEnvelopeErr xs -> String
$cshowList :: forall (xs :: [*]).
CanHardFork xs =>
[HardForkEnvelopeErr xs] -> ShowS
showList :: [HardForkEnvelopeErr xs] -> ShowS
Show, (forall x.
 HardForkEnvelopeErr xs -> Rep (HardForkEnvelopeErr xs) x)
-> (forall x.
    Rep (HardForkEnvelopeErr xs) x -> HardForkEnvelopeErr xs)
-> Generic (HardForkEnvelopeErr xs)
forall (xs :: [*]) x.
Rep (HardForkEnvelopeErr xs) x -> HardForkEnvelopeErr xs
forall (xs :: [*]) x.
HardForkEnvelopeErr xs -> Rep (HardForkEnvelopeErr xs) x
forall x. Rep (HardForkEnvelopeErr xs) x -> HardForkEnvelopeErr xs
forall x. HardForkEnvelopeErr xs -> Rep (HardForkEnvelopeErr xs) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (xs :: [*]) x.
HardForkEnvelopeErr xs -> Rep (HardForkEnvelopeErr xs) x
from :: forall x. HardForkEnvelopeErr xs -> Rep (HardForkEnvelopeErr xs) x
$cto :: forall (xs :: [*]) x.
Rep (HardForkEnvelopeErr xs) x -> HardForkEnvelopeErr xs
to :: forall x. Rep (HardForkEnvelopeErr xs) x -> HardForkEnvelopeErr xs
Generic, Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo)
Proxy (HardForkEnvelopeErr xs) -> String
(Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo))
-> (Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo))
-> (Proxy (HardForkEnvelopeErr xs) -> String)
-> NoThunks (HardForkEnvelopeErr xs)
forall (xs :: [*]).
CanHardFork xs =>
Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo)
forall (xs :: [*]).
CanHardFork xs =>
Proxy (HardForkEnvelopeErr xs) -> String
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
$cnoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo)
noThunks :: Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> HardForkEnvelopeErr xs -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (xs :: [*]).
CanHardFork xs =>
Proxy (HardForkEnvelopeErr xs) -> String
showTypeOf :: Proxy (HardForkEnvelopeErr xs) -> String
NoThunks)

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

  additionalEnvelopeChecks :: TopLevelConfig (HardForkBlock xs)
-> LedgerView (BlockProtocol (HardForkBlock xs))
-> Header (HardForkBlock xs)
-> Except (OtherHeaderEnvelopeError (HardForkBlock xs)) ()
additionalEnvelopeChecks
    TopLevelConfig (HardForkBlock xs)
tlc
    (HardForkLedgerView TransitionInfo
transition HardForkState WrapLedgerView xs
hardForkView) =
      \(HardForkHeader (OneEraHeader NS Header xs
hdr)) ->
        case NS Header xs
-> NS WrapLedgerView xs
-> Either
     (Mismatch Header WrapLedgerView xs)
     (NS (Product Header WrapLedgerView) xs)
forall {k} (f :: k -> *) (xs :: [k]) (g :: k -> *).
NS f xs
-> NS g xs -> Either (Mismatch f g xs) (NS (Product f g) xs)
Match.matchNS NS Header xs
hdr (HardForkState WrapLedgerView xs -> NS WrapLedgerView xs
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
HardForkState f xs -> NS f xs
State.tip HardForkState WrapLedgerView xs
hardForkView) of
          Left Mismatch Header WrapLedgerView xs
mismatch ->
            HardForkEnvelopeErr xs
-> Except (OtherHeaderEnvelopeError (HardForkBlock xs)) ()
forall a.
HardForkEnvelopeErr xs
-> ExceptT (OtherHeaderEnvelopeError (HardForkBlock xs)) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (HardForkEnvelopeErr xs
 -> Except (OtherHeaderEnvelopeError (HardForkBlock xs)) ())
-> HardForkEnvelopeErr xs
-> Except (OtherHeaderEnvelopeError (HardForkBlock xs)) ()
forall a b. (a -> b) -> a -> b
$
              MismatchEraInfo xs -> HardForkEnvelopeErr xs
forall (xs :: [*]). MismatchEraInfo xs -> HardForkEnvelopeErr xs
HardForkEnvelopeErrWrongEra (MismatchEraInfo xs -> HardForkEnvelopeErr xs)
-> (Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs)
-> Mismatch SingleEraInfo LedgerEraInfo xs
-> HardForkEnvelopeErr xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
forall (xs :: [*]).
Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
MismatchEraInfo (Mismatch SingleEraInfo LedgerEraInfo xs -> HardForkEnvelopeErr xs)
-> Mismatch SingleEraInfo LedgerEraInfo xs
-> HardForkEnvelopeErr xs
forall a b. (a -> b) -> a -> b
$
                Proxy SingleEraBlock
-> (forall x. SingleEraBlock x => Header x -> SingleEraInfo x)
-> (forall x.
    SingleEraBlock x =>
    WrapLedgerView x -> LedgerEraInfo x)
-> Mismatch Header WrapLedgerView xs
-> Mismatch SingleEraInfo LedgerEraInfo xs
forall {k} (c :: k -> Constraint) (xs :: [k])
       (proxy :: (k -> Constraint) -> *) (f :: k -> *) (f' :: k -> *)
       (g :: k -> *) (g' :: k -> *).
All c xs =>
proxy c
-> (forall (x :: k). c x => f x -> f' x)
-> (forall (x :: k). c x => g x -> g' x)
-> Mismatch f g xs
-> Mismatch f' g' xs
Match.bihcmap Proxy SingleEraBlock
proxySingle Header x -> SingleEraInfo x
forall x. SingleEraBlock x => Header x -> SingleEraInfo x
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
forall (proxy :: * -> *). proxy x -> SingleEraInfo x
singleEraInfo WrapLedgerView x -> LedgerEraInfo x
forall x. SingleEraBlock x => WrapLedgerView x -> LedgerEraInfo x
forall blk (f :: * -> *).
SingleEraBlock blk =>
f blk -> LedgerEraInfo blk
ledgerViewInfo Mismatch Header WrapLedgerView xs
mismatch
          Right NS (Product Header WrapLedgerView) xs
matched ->
            NS (K (Except (HardForkEnvelopeErr xs) ())) xs
-> CollapseTo NS (Except (HardForkEnvelopeErr xs) ())
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K (Except (HardForkEnvelopeErr xs) ())) xs
 -> CollapseTo NS (Except (HardForkEnvelopeErr xs) ()))
-> NS (K (Except (HardForkEnvelopeErr xs) ())) xs
-> CollapseTo NS (Except (HardForkEnvelopeErr xs) ())
forall a b. (a -> b) -> a -> b
$ Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    Index xs a
    -> TopLevelConfig a
    -> Product Header WrapLedgerView a
    -> K (Except (HardForkEnvelopeErr xs) ()) a)
-> NP TopLevelConfig xs
-> NS (Product Header WrapLedgerView) xs
-> NS (K (Except (HardForkEnvelopeErr xs) ())) xs
forall {k} (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint)
       (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *)
       (f2 :: k -> *) (f3 :: k -> *).
(HAp h, All c xs, Prod h ~ NP) =>
proxy c
-> (forall (a :: k). c a => Index xs a -> f1 a -> f2 a -> f3 a)
-> NP f1 xs
-> h f2 xs
-> h f3 xs
hcizipWith Proxy SingleEraBlock
proxySingle Index xs a
-> TopLevelConfig a
-> Product Header WrapLedgerView a
-> K (Except (HardForkEnvelopeErr xs) ()) a
forall a.
SingleEraBlock a =>
Index xs a
-> TopLevelConfig a
-> Product Header WrapLedgerView a
-> K (Except (HardForkEnvelopeErr xs) ()) a
aux NP TopLevelConfig xs
cfgs NS (Product Header WrapLedgerView) xs
matched
     where
      ei :: EpochInfo (Except PastHorizonException)
      ei :: EpochInfo (Except PastHorizonException)
ei =
        Shape xs
-> TransitionInfo
-> HardForkState WrapLedgerView xs
-> EpochInfo (Except PastHorizonException)
forall (xs :: [*]) (f :: * -> *).
Shape xs
-> TransitionInfo
-> HardForkState f xs
-> EpochInfo (Except PastHorizonException)
State.epochInfoPrecomputedTransitionInfo
          (HardForkLedgerConfig xs -> Shape xs
forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs
hardForkLedgerConfigShape (HardForkLedgerConfig xs -> Shape xs)
-> HardForkLedgerConfig xs -> Shape xs
forall a b. (a -> b) -> a -> b
$ TopLevelConfig (HardForkBlock xs)
-> LedgerConfig (HardForkBlock xs)
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig (HardForkBlock xs)
tlc)
          TransitionInfo
transition
          HardForkState WrapLedgerView xs
hardForkView

      cfgs :: NP TopLevelConfig xs
      cfgs :: NP TopLevelConfig xs
cfgs = EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
forall (xs :: [*]).
All SingleEraBlock xs =>
EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
distribTopLevelConfig EpochInfo (Except PastHorizonException)
ei TopLevelConfig (HardForkBlock xs)
tlc

      aux ::
        forall blk.
        SingleEraBlock blk =>
        Index xs blk ->
        TopLevelConfig blk ->
        Product Header WrapLedgerView blk ->
        K (Except (HardForkEnvelopeErr xs) ()) blk
      aux :: forall a.
SingleEraBlock a =>
Index xs a
-> TopLevelConfig a
-> Product Header WrapLedgerView a
-> K (Except (HardForkEnvelopeErr xs) ()) a
aux Index xs blk
index TopLevelConfig blk
cfg (Pair Header blk
hdr WrapLedgerView blk
view) =
        Except (HardForkEnvelopeErr xs) ()
-> K (Except (HardForkEnvelopeErr xs) ()) blk
forall k a (b :: k). a -> K a b
K (Except (HardForkEnvelopeErr xs) ()
 -> K (Except (HardForkEnvelopeErr xs) ()) blk)
-> Except (HardForkEnvelopeErr xs) ()
-> K (Except (HardForkEnvelopeErr xs) ()) blk
forall a b. (a -> b) -> a -> b
$
          (OtherHeaderEnvelopeError blk -> HardForkEnvelopeErr xs)
-> Except (OtherHeaderEnvelopeError blk) ()
-> Except (HardForkEnvelopeErr xs) ()
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept OtherHeaderEnvelopeError blk -> HardForkEnvelopeErr xs
injErr' (Except (OtherHeaderEnvelopeError blk) ()
 -> Except (HardForkEnvelopeErr xs) ())
-> Except (OtherHeaderEnvelopeError blk) ()
-> Except (HardForkEnvelopeErr xs) ()
forall a b. (a -> b) -> a -> b
$
            TopLevelConfig blk
-> LedgerView (BlockProtocol blk)
-> Header blk
-> Except (OtherHeaderEnvelopeError blk) ()
forall blk.
ValidateEnvelope blk =>
TopLevelConfig blk
-> LedgerView (BlockProtocol blk)
-> Header blk
-> Except (OtherHeaderEnvelopeError blk) ()
additionalEnvelopeChecks
              TopLevelConfig blk
cfg
              (WrapLedgerView blk -> LedgerView (BlockProtocol blk)
forall blk. WrapLedgerView blk -> LedgerView (BlockProtocol blk)
unwrapLedgerView WrapLedgerView blk
view)
              Header blk
hdr
       where
        injErr' :: OtherHeaderEnvelopeError blk -> HardForkEnvelopeErr xs
        injErr' :: OtherHeaderEnvelopeError blk -> HardForkEnvelopeErr xs
injErr' =
          OneEraEnvelopeErr xs -> HardForkEnvelopeErr xs
forall (xs :: [*]). OneEraEnvelopeErr xs -> HardForkEnvelopeErr xs
HardForkEnvelopeErrFromEra
            (OneEraEnvelopeErr xs -> HardForkEnvelopeErr xs)
-> (OtherHeaderEnvelopeError blk -> OneEraEnvelopeErr xs)
-> OtherHeaderEnvelopeError blk
-> HardForkEnvelopeErr xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS WrapEnvelopeErr xs -> OneEraEnvelopeErr xs
forall (xs :: [*]). NS WrapEnvelopeErr xs -> OneEraEnvelopeErr xs
OneEraEnvelopeErr
            (NS WrapEnvelopeErr xs -> OneEraEnvelopeErr xs)
-> (OtherHeaderEnvelopeError blk -> NS WrapEnvelopeErr xs)
-> OtherHeaderEnvelopeError blk
-> OneEraEnvelopeErr xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index xs blk -> WrapEnvelopeErr blk -> NS WrapEnvelopeErr xs
forall {k} (f :: k -> *) (x :: k) (xs :: [k]).
All Top xs =>
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
  , HasCanonicalTxIn xs
  , HasHardForkTxOut xs
  ) =>
  LedgerSupportsProtocol (HardForkBlock xs)
  where
  protocolLedgerView :: forall (mk :: MapKind).
LedgerConfig (HardForkBlock xs)
-> Ticked (LedgerState (HardForkBlock xs)) mk
-> LedgerView (BlockProtocol (HardForkBlock xs))
protocolLedgerView
    HardForkLedgerConfig{Shape xs
PerEraLedgerConfig xs
hardForkLedgerConfigPerEra :: forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
hardForkLedgerConfigShape :: forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs
hardForkLedgerConfigShape :: Shape xs
hardForkLedgerConfigPerEra :: PerEraLedgerConfig xs
..}
    (TickedHardForkLedgerState TransitionInfo
transition HardForkState (FlipTickedLedgerState mk) xs
ticked) =
      HardForkLedgerView
        { hardForkLedgerViewTransition :: TransitionInfo
hardForkLedgerViewTransition = TransitionInfo
transition
        , hardForkLedgerViewPerEra :: HardForkState WrapLedgerView xs
hardForkLedgerViewPerEra =
            Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    WrapPartialLedgerConfig a
    -> FlipTickedLedgerState mk a -> WrapLedgerView a)
-> Prod HardForkState WrapPartialLedgerConfig xs
-> HardForkState (FlipTickedLedgerState mk) xs
-> HardForkState WrapLedgerView xs
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a)
-> Prod h f xs
-> h f' xs
-> h f'' xs
hczipWith Proxy SingleEraBlock
proxySingle WrapPartialLedgerConfig a
-> FlipTickedLedgerState mk a -> WrapLedgerView a
forall a.
SingleEraBlock a =>
WrapPartialLedgerConfig a
-> FlipTickedLedgerState mk a -> WrapLedgerView a
forall blk (mk :: MapKind).
SingleEraBlock blk =>
WrapPartialLedgerConfig blk
-> FlipTickedLedgerState mk blk -> WrapLedgerView blk
viewOne Prod HardForkState WrapPartialLedgerConfig xs
NP WrapPartialLedgerConfig xs
cfgs HardForkState (FlipTickedLedgerState mk) 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 (FlipTickedLedgerState mk) xs
-> EpochInfo (Except PastHorizonException)
forall (xs :: [*]) (f :: * -> *).
Shape xs
-> TransitionInfo
-> HardForkState f xs
-> EpochInfo (Except PastHorizonException)
State.epochInfoPrecomputedTransitionInfo
          Shape xs
hardForkLedgerConfigShape
          TransitionInfo
transition
          HardForkState (FlipTickedLedgerState mk) xs
ticked

      viewOne ::
        SingleEraBlock blk =>
        WrapPartialLedgerConfig blk ->
        FlipTickedLedgerState mk blk ->
        WrapLedgerView blk
      viewOne :: forall blk (mk :: MapKind).
SingleEraBlock blk =>
WrapPartialLedgerConfig blk
-> FlipTickedLedgerState mk blk -> WrapLedgerView blk
viewOne WrapPartialLedgerConfig blk
cfg (FlipTickedLedgerState Ticked (LedgerState blk) mk
st) =
        LedgerView (BlockProtocol blk) -> WrapLedgerView blk
forall blk. LedgerView (BlockProtocol blk) -> WrapLedgerView blk
WrapLedgerView (LedgerView (BlockProtocol blk) -> WrapLedgerView blk)
-> LedgerView (BlockProtocol blk) -> WrapLedgerView blk
forall a b. (a -> b) -> a -> b
$
          LedgerConfig blk
-> Ticked (LedgerState blk) mk -> LedgerView (BlockProtocol blk)
forall blk (mk :: MapKind).
LedgerSupportsProtocol blk =>
LedgerConfig blk
-> Ticked (LedgerState blk) mk -> LedgerView (BlockProtocol blk)
forall (mk :: MapKind).
LedgerConfig blk
-> Ticked (LedgerState blk) mk -> 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) mk
st

  ledgerViewForecastAt :: forall (mk :: MapKind).
HasCallStack =>
LedgerConfig (HardForkBlock xs)
-> LedgerState (HardForkBlock xs) mk
-> Forecast (LedgerView (BlockProtocol (HardForkBlock xs)))
ledgerViewForecastAt
    ledgerCfg :: LedgerConfig (HardForkBlock xs)
ledgerCfg@HardForkLedgerConfig{Shape xs
PerEraLedgerConfig xs
hardForkLedgerConfigPerEra :: forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
hardForkLedgerConfigShape :: forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs
hardForkLedgerConfigShape :: Shape xs
hardForkLedgerConfigPerEra :: PerEraLedgerConfig xs
..}
    (HardForkLedgerState HardForkState (Flip LedgerState mk) xs
ledgerSt) =
      InPairs (CrossEraForecaster LedgerState WrapLedgerView) xs
-> HardForkState (AnnForecast LedgerState WrapLedgerView) xs
-> Forecast (HardForkLedgerView_ WrapLedgerView xs)
forall (state :: * -> LedgerStateKind) (view :: * -> *)
       (xs :: [*]).
SListI xs =>
InPairs (CrossEraForecaster state view) xs
-> HardForkState (AnnForecast state view) xs
-> Forecast (HardForkLedgerView_ view xs)
mkHardForkForecast
        (NP WrapLedgerConfig xs
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView))
     xs
-> InPairs (CrossEraForecaster LedgerState WrapLedgerView) xs
forall {k} (h :: k -> *) (xs :: [k]) (f :: k -> k -> *).
NP h xs -> InPairs (RequiringBoth h f) xs -> InPairs f xs
InPairs.requiringBoth NP WrapLedgerConfig xs
cfgs (InPairs
   (RequiringBoth
      WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView))
   xs
 -> InPairs (CrossEraForecaster LedgerState WrapLedgerView) xs)
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView))
     xs
-> InPairs (CrossEraForecaster LedgerState WrapLedgerView) xs
forall a b. (a -> b) -> a -> b
$ EraTranslation xs
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView))
     xs
forall (xs :: [*]).
EraTranslation xs
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (CrossEraForecaster LedgerState WrapLedgerView))
     xs
crossEraForecast EraTranslation xs
forall (xs :: [*]). CanHardFork xs => EraTranslation xs
hardForkEraTranslation)
        HardForkState (AnnForecast LedgerState WrapLedgerView) xs
annForecast
     where
      ei :: EpochInfo (Except PastHorizonException)
ei = HardForkLedgerConfig xs
-> HardForkState (Flip LedgerState mk) xs
-> EpochInfo (Except PastHorizonException)
forall (xs :: [*]) (mk :: MapKind).
All SingleEraBlock xs =>
HardForkLedgerConfig xs
-> HardForkState (Flip LedgerState mk) xs
-> EpochInfo (Except PastHorizonException)
State.epochInfoLedger LedgerConfig (HardForkBlock xs)
HardForkLedgerConfig xs
ledgerCfg HardForkState (Flip LedgerState mk) 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 (Flip LedgerState mk) a
    -> Current (AnnForecast LedgerState WrapLedgerView) a)
-> Prod (Telescope (K Past)) WrapPartialLedgerConfig xs
-> Prod (Telescope (K Past)) (K EraParams) xs
-> Telescope (K Past) (Current (Flip LedgerState mk)) xs
-> Telescope
     (K Past) (Current (AnnForecast LedgerState WrapLedgerView)) xs
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *) (f'' :: k -> *) (f''' :: k -> *).
(AllN (Prod h) c xs, HAp h, HAp (Prod h)) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a -> f'' a -> f''' a)
-> Prod h f xs
-> Prod h f' xs
-> h f'' xs
-> h f''' xs
hczipWith3
            Proxy SingleEraBlock
proxySingle
            WrapPartialLedgerConfig a
-> K EraParams a
-> Current (Flip LedgerState mk) a
-> Current (AnnForecast LedgerState WrapLedgerView) a
forall a.
SingleEraBlock a =>
WrapPartialLedgerConfig a
-> K EraParams a
-> Current (Flip LedgerState mk) a
-> Current (AnnForecast LedgerState WrapLedgerView) a
forall blk (mk :: MapKind).
SingleEraBlock blk =>
WrapPartialLedgerConfig blk
-> K EraParams blk
-> Current (Flip LedgerState mk) blk
-> Current (AnnForecast LedgerState WrapLedgerView) blk
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 (Flip LedgerState mk) xs
-> Telescope (K Past) (Current (Flip LedgerState mk)) xs
forall (f :: * -> *) (xs :: [*]).
HardForkState f xs -> Telescope (K Past) (Current f) xs
getHardForkState HardForkState (Flip LedgerState mk) xs
ledgerSt)

      forecastOne ::
        forall blk mk.
        SingleEraBlock blk =>
        WrapPartialLedgerConfig blk ->
        K EraParams blk ->
        Current (Flip LedgerState mk) blk ->
        Current (AnnForecast LedgerState WrapLedgerView) blk
      forecastOne :: forall blk (mk :: MapKind).
SingleEraBlock blk =>
WrapPartialLedgerConfig blk
-> K EraParams blk
-> Current (Flip LedgerState mk) blk
-> Current (AnnForecast LedgerState WrapLedgerView) blk
forecastOne WrapPartialLedgerConfig blk
cfg (K EraParams
params) (Current Bound
start (Flip LedgerState blk mk
st)) =
        Current
          { currentStart :: Bound
currentStart = Bound
start
          , currentState :: AnnForecast LedgerState WrapLedgerView blk
currentState =
              AnnForecast
                { annForecast :: Forecast (WrapLedgerView blk)
annForecast =
                    (LedgerView (BlockProtocol blk) -> WrapLedgerView blk)
-> Forecast (LedgerView (BlockProtocol blk))
-> Forecast (WrapLedgerView blk)
forall a b. (a -> b) -> Forecast a -> Forecast b
mapForecast LedgerView (BlockProtocol blk) -> WrapLedgerView blk
forall blk. LedgerView (BlockProtocol blk) -> WrapLedgerView blk
WrapLedgerView (Forecast (LedgerView (BlockProtocol blk))
 -> Forecast (WrapLedgerView blk))
-> Forecast (LedgerView (BlockProtocol blk))
-> Forecast (WrapLedgerView blk)
forall a b. (a -> b) -> a -> b
$
                      LedgerConfig blk
-> LedgerState blk mk -> Forecast (LedgerView (BlockProtocol blk))
forall blk (mk :: MapKind).
(LedgerSupportsProtocol blk, HasCallStack) =>
LedgerConfig blk
-> LedgerState blk mk -> Forecast (LedgerView (BlockProtocol blk))
forall (mk :: MapKind).
HasCallStack =>
LedgerConfig blk
-> LedgerState blk mk -> Forecast (LedgerView (BlockProtocol blk))
ledgerViewForecastAt LedgerConfig blk
cfg' LedgerState blk mk
st
                , annForecastState :: LedgerState blk EmptyMK
annForecastState = LedgerState blk mk -> LedgerState blk EmptyMK
forall (l :: LedgerStateKind) (mk :: MapKind).
HasLedgerTables l =>
l mk -> l EmptyMK
forgetLedgerTables LedgerState blk mk
st
                , annForecastTip :: WithOrigin SlotNo
annForecastTip = LedgerState blk mk -> WithOrigin SlotNo
forall blk (mk :: MapKind).
UpdateLedger blk =>
LedgerState blk mk -> WithOrigin SlotNo
ledgerTipSlot LedgerState blk mk
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 mk -> Maybe EpochNo
forall blk (mk :: MapKind).
SingleEraBlock blk =>
WrapPartialLedgerConfig blk
-> EraParams -> Bound -> LedgerState blk mk -> Maybe EpochNo
singleEraTransition' WrapPartialLedgerConfig blk
cfg EraParams
params Bound
start LedgerState blk mk
st
                }
          }
       where
        cfg' :: LedgerConfig blk
        cfg' :: LedgerConfig blk
cfg' = EpochInfo (Except PastHorizonException)
-> WrapPartialLedgerConfig blk -> LedgerConfig blk
forall blk.
HasPartialLedgerConfig blk =>
EpochInfo (Except PastHorizonException)
-> WrapPartialLedgerConfig blk -> LedgerConfig blk
completeLedgerConfig' EpochInfo (Except PastHorizonException)
ei WrapPartialLedgerConfig blk
cfg

{-------------------------------------------------------------------------------
  Annotated forecasts
-------------------------------------------------------------------------------}

-- | Forecast annotated with details about the ledger it was derived from
data AnnForecast state view blk = AnnForecast
  { forall (state :: * -> LedgerStateKind) (view :: * -> *) blk.
AnnForecast state view blk -> Forecast (view blk)
annForecast :: Forecast (view blk)
  , forall (state :: * -> LedgerStateKind) (view :: * -> *) blk.
AnnForecast state view blk -> state blk EmptyMK
annForecastState :: state blk EmptyMK
  , forall (state :: * -> LedgerStateKind) (view :: * -> *) blk.
AnnForecast state view blk -> WithOrigin SlotNo
annForecastTip :: WithOrigin SlotNo
  , forall (state :: * -> LedgerStateKind) (view :: * -> *) blk.
AnnForecast state view blk -> Maybe Bound
annForecastEnd :: Maybe Bound
  }

-- | Change a telescope of a forecast into a forecast of a telescope
mkHardForkForecast ::
  forall state view xs.
  SListI xs =>
  InPairs (CrossEraForecaster state view) xs ->
  HardForkState (AnnForecast state view) xs ->
  Forecast (HardForkLedgerView_ view xs)
mkHardForkForecast :: forall (state :: * -> LedgerStateKind) (view :: * -> *)
       (xs :: [*]).
SListI xs =>
InPairs (CrossEraForecaster state view) xs
-> HardForkState (AnnForecast state view) xs
-> Forecast (HardForkLedgerView_ view xs)
mkHardForkForecast InPairs (CrossEraForecaster state view) xs
translations HardForkState (AnnForecast state view) xs
st =
  Forecast
    { forecastAt :: WithOrigin SlotNo
forecastAt = HardForkState (K (WithOrigin SlotNo)) xs
-> CollapseTo HardForkState (WithOrigin SlotNo)
forall (xs :: [*]) a.
SListIN HardForkState xs =>
HardForkState (K a) xs -> CollapseTo HardForkState a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse ((forall a. AnnForecast state view a -> K (WithOrigin SlotNo) a)
-> HardForkState (AnnForecast state view) xs
-> HardForkState (K (WithOrigin SlotNo)) xs
forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap (WithOrigin SlotNo -> K (WithOrigin SlotNo) a
forall k a (b :: k). a -> K a b
K (WithOrigin SlotNo -> K (WithOrigin SlotNo) a)
-> (AnnForecast state view a -> WithOrigin SlotNo)
-> AnnForecast state view a
-> K (WithOrigin SlotNo) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Forecast (view a) -> WithOrigin SlotNo
forall a. Forecast a -> WithOrigin SlotNo
forecastAt (Forecast (view a) -> WithOrigin SlotNo)
-> (AnnForecast state view a -> Forecast (view a))
-> AnnForecast state view a
-> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnForecast state view a -> Forecast (view a)
forall (state :: * -> LedgerStateKind) (view :: * -> *) blk.
AnnForecast state view blk -> Forecast (view blk)
annForecast) HardForkState (AnnForecast state view) xs
st)
    , forecastFor :: SlotNo -> Except OutsideForecastRange (HardForkLedgerView_ view xs)
forecastFor = \SlotNo
sno -> SlotNo
-> InPairs (CrossEraForecaster state view) xs
-> Telescope (K Past) (Current (AnnForecast state view)) xs
-> Except OutsideForecastRange (HardForkLedgerView_ view xs)
forall (xs' :: [*]).
SlotNo
-> InPairs (CrossEraForecaster state view) xs'
-> Telescope (K Past) (Current (AnnForecast state view)) xs'
-> Except OutsideForecastRange (HardForkLedgerView_ view xs')
go SlotNo
sno InPairs (CrossEraForecaster state view) xs
translations (HardForkState (AnnForecast state view) xs
-> Telescope (K Past) (Current (AnnForecast state view)) xs
forall (f :: * -> *) (xs :: [*]).
HardForkState f xs -> Telescope (K Past) (Current f) xs
getHardForkState HardForkState (AnnForecast state view) xs
st)
    }
 where
  go ::
    SlotNo ->
    InPairs (CrossEraForecaster state view) xs' ->
    Telescope (K Past) (Current (AnnForecast state view)) xs' ->
    Except OutsideForecastRange (HardForkLedgerView_ view xs')
  go :: forall (xs' :: [*]).
SlotNo
-> InPairs (CrossEraForecaster state view) xs'
-> Telescope (K Past) (Current (AnnForecast state view)) xs'
-> Except OutsideForecastRange (HardForkLedgerView_ view xs')
go SlotNo
sno InPairs (CrossEraForecaster state view) xs'
pairs (TZ Current (AnnForecast state view) x
cur) = SlotNo
-> InPairs (CrossEraForecaster state view) (x : xs1)
-> Current (AnnForecast state view) x
-> Except OutsideForecastRange (HardForkLedgerView_ view (x : xs1))
forall (state :: * -> LedgerStateKind) (view :: * -> *) blk
       (blks :: [*]).
SlotNo
-> InPairs (CrossEraForecaster state view) (blk : blks)
-> Current (AnnForecast state view) blk
-> Except
     OutsideForecastRange (HardForkLedgerView_ view (blk : blks))
oneForecast SlotNo
sno InPairs (CrossEraForecaster state view) xs'
InPairs (CrossEraForecaster state view) (x : xs1)
pairs Current (AnnForecast state view) x
cur
  go SlotNo
sno (PCons CrossEraForecaster state view x y
_ InPairs (CrossEraForecaster state view) (y : zs)
ts) (TS K Past x
past Telescope (K Past) (Current (AnnForecast state view)) xs1
rest) = K Past x
-> HardForkLedgerView_ view (y : zs)
-> HardForkLedgerView_ view (x : y : zs)
forall blk (f :: * -> *) (blks :: [*]).
K Past blk
-> HardForkLedgerView_ f blks -> HardForkLedgerView_ f (blk : blks)
shiftView K Past x
past (HardForkLedgerView_ view (y : zs) -> HardForkLedgerView_ view xs')
-> ExceptT
     OutsideForecastRange Identity (HardForkLedgerView_ view (y : zs))
-> ExceptT
     OutsideForecastRange Identity (HardForkLedgerView_ view xs')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SlotNo
-> InPairs (CrossEraForecaster state view) (y : zs)
-> Telescope (K Past) (Current (AnnForecast state view)) (y : zs)
-> ExceptT
     OutsideForecastRange Identity (HardForkLedgerView_ view (y : zs))
forall (xs' :: [*]).
SlotNo
-> InPairs (CrossEraForecaster state view) xs'
-> Telescope (K Past) (Current (AnnForecast state view)) xs'
-> Except OutsideForecastRange (HardForkLedgerView_ view xs')
go SlotNo
sno InPairs (CrossEraForecaster state view) (y : zs)
ts Telescope (K Past) (Current (AnnForecast state view)) xs1
Telescope (K Past) (Current (AnnForecast state view)) (y : zs)
rest

oneForecast ::
  forall state view blk blks.
  SlotNo ->
  -- | this function uses at most the first translation
  InPairs (CrossEraForecaster state view) (blk : blks) ->
  Current (AnnForecast state view) blk ->
  Except OutsideForecastRange (HardForkLedgerView_ view (blk : blks))
oneForecast :: forall (state :: * -> LedgerStateKind) (view :: * -> *) blk
       (blks :: [*]).
SlotNo
-> InPairs (CrossEraForecaster state view) (blk : blks)
-> Current (AnnForecast state view) blk
-> Except
     OutsideForecastRange (HardForkLedgerView_ view (blk : blks))
oneForecast SlotNo
sno InPairs (CrossEraForecaster state view) (blk : blks)
pairs (Current Bound
start AnnForecast{state blk EmptyMK
Maybe Bound
WithOrigin SlotNo
Forecast (view blk)
annForecast :: forall (state :: * -> LedgerStateKind) (view :: * -> *) blk.
AnnForecast state view blk -> Forecast (view blk)
annForecastState :: forall (state :: * -> LedgerStateKind) (view :: * -> *) blk.
AnnForecast state view blk -> state blk EmptyMK
annForecastTip :: forall (state :: * -> LedgerStateKind) (view :: * -> *) blk.
AnnForecast state view blk -> WithOrigin SlotNo
annForecastEnd :: forall (state :: * -> LedgerStateKind) (view :: * -> *) blk.
AnnForecast state view blk -> Maybe Bound
annForecast :: Forecast (view blk)
annForecastState :: state blk EmptyMK
annForecastTip :: WithOrigin SlotNo
annForecastEnd :: Maybe Bound
..}) =
  case Maybe Bound
annForecastEnd of
    Maybe Bound
Nothing -> view blk -> HardForkLedgerView_ view (blk : blks)
forall (f :: * -> *). f blk -> HardForkLedgerView_ f (blk : blks)
endUnknown (view blk -> HardForkLedgerView_ view (blk : blks))
-> ExceptT OutsideForecastRange Identity (view blk)
-> Except
     OutsideForecastRange (HardForkLedgerView_ view (blk : blks))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Forecast (view blk)
-> SlotNo -> ExceptT OutsideForecastRange Identity (view blk)
forall a. Forecast a -> SlotNo -> Except OutsideForecastRange a
forecastFor Forecast (view blk)
annForecast SlotNo
sno
    Just Bound
end ->
      if SlotNo
sno SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< Bound -> SlotNo
boundSlot Bound
end
        then Bound -> view blk -> HardForkLedgerView_ view (blk : blks)
forall (f :: * -> *).
Bound -> f blk -> HardForkLedgerView_ f (blk : blks)
beforeKnownEnd Bound
end (view blk -> HardForkLedgerView_ view (blk : blks))
-> ExceptT OutsideForecastRange Identity (view blk)
-> Except
     OutsideForecastRange (HardForkLedgerView_ view (blk : blks))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Forecast (view blk)
-> SlotNo -> ExceptT OutsideForecastRange Identity (view blk)
forall a. Forecast a -> SlotNo -> Except OutsideForecastRange a
forecastFor Forecast (view blk)
annForecast SlotNo
sno
        else case InPairs (CrossEraForecaster state view) (blk : blks)
pairs of
          PCons CrossEraForecaster state view x y
translate InPairs (CrossEraForecaster state view) (y : zs)
_ ->
            Bound -> view y -> HardForkLedgerView_ view (blk : y : zs)
forall (f :: * -> *) blk' (blks' :: [*]).
Bound -> f blk' -> HardForkLedgerView_ f (blk : blk' : blks')
afterKnownEnd Bound
end
              (view y -> HardForkLedgerView_ view (blk : blks))
-> ExceptT OutsideForecastRange Identity (view y)
-> Except
     OutsideForecastRange (HardForkLedgerView_ view (blk : blks))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CrossEraForecaster state view x y
-> Bound
-> SlotNo
-> state x EmptyMK
-> ExceptT OutsideForecastRange Identity (view y)
forall (state :: * -> LedgerStateKind) (view :: * -> *) x y.
CrossEraForecaster state view x y
-> Bound
-> SlotNo
-> state x EmptyMK
-> Except OutsideForecastRange (view y)
crossEraForecastWith CrossEraForecaster state view x y
translate Bound
end SlotNo
sno state blk EmptyMK
state x EmptyMK
annForecastState
          InPairs (CrossEraForecaster state view) (blk : blks)
PNil ->
            -- The requested slot is after the last era the code knows about.
            OutsideForecastRange
-> Except
     OutsideForecastRange (HardForkLedgerView_ view (blk : blks))
forall a.
OutsideForecastRange -> ExceptT OutsideForecastRange Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
              OutsideForecastRange
                { outsideForecastAt :: WithOrigin SlotNo
outsideForecastAt = Forecast (view blk) -> WithOrigin SlotNo
forall a. Forecast a -> WithOrigin SlotNo
forecastAt Forecast (view blk)
annForecast
                , outsideForecastMaxFor :: SlotNo
outsideForecastMaxFor = Bound -> SlotNo
boundSlot Bound
end
                , outsideForecastFor :: SlotNo
outsideForecastFor = SlotNo
sno
                }
 where
  endUnknown ::
    f blk ->
    HardForkLedgerView_ f (blk : blks)
  endUnknown :: forall (f :: * -> *). f blk -> HardForkLedgerView_ f (blk : blks)
endUnknown f blk
view =
    HardForkLedgerView
      { hardForkLedgerViewTransition :: TransitionInfo
hardForkLedgerViewTransition =
          WithOrigin SlotNo -> TransitionInfo
TransitionUnknown WithOrigin SlotNo
annForecastTip
      , hardForkLedgerViewPerEra :: HardForkState f (blk : blks)
hardForkLedgerViewPerEra =
          Telescope (K Past) (Current f) (blk : blks)
-> HardForkState f (blk : blks)
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState (Telescope (K Past) (Current f) (blk : blks)
 -> HardForkState f (blk : blks))
-> Telescope (K Past) (Current f) (blk : blks)
-> HardForkState f (blk : blks)
forall a b. (a -> b) -> a -> b
$
            Current f blk -> Telescope (K Past) (Current f) (blk : blks)
forall {k} (f :: k -> *) (x :: k) (g :: k -> *) (xs1 :: [k]).
f x -> Telescope g f (x : xs1)
TZ (Bound -> f blk -> Current f blk
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
Current Bound
start f blk
view)
      }

  beforeKnownEnd ::
    Bound ->
    f blk ->
    HardForkLedgerView_ f (blk : blks)
  beforeKnownEnd :: forall (f :: * -> *).
Bound -> f blk -> HardForkLedgerView_ f (blk : blks)
beforeKnownEnd Bound
end f blk
view =
    HardForkLedgerView
      { hardForkLedgerViewTransition :: TransitionInfo
hardForkLedgerViewTransition =
          EpochNo -> TransitionInfo
TransitionKnown (Bound -> EpochNo
boundEpoch Bound
end)
      , hardForkLedgerViewPerEra :: HardForkState f (blk : blks)
hardForkLedgerViewPerEra =
          Telescope (K Past) (Current f) (blk : blks)
-> HardForkState f (blk : blks)
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState (Telescope (K Past) (Current f) (blk : blks)
 -> HardForkState f (blk : blks))
-> Telescope (K Past) (Current f) (blk : blks)
-> HardForkState f (blk : blks)
forall a b. (a -> b) -> a -> b
$
            Current f blk -> Telescope (K Past) (Current f) (blk : blks)
forall {k} (f :: k -> *) (x :: k) (g :: k -> *) (xs1 :: [k]).
f x -> Telescope g f (x : xs1)
TZ (Bound -> f blk -> Current f blk
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
Current Bound
start f blk
view)
      }

  afterKnownEnd ::
    Bound ->
    f blk' ->
    HardForkLedgerView_ f (blk : blk' : blks')
  afterKnownEnd :: forall (f :: * -> *) blk' (blks' :: [*]).
Bound -> f blk' -> HardForkLedgerView_ f (blk : blk' : blks')
afterKnownEnd Bound
end f blk'
view =
    HardForkLedgerView
      { hardForkLedgerViewTransition :: TransitionInfo
hardForkLedgerViewTransition =
          -- We assume that we only ever have to translate to the /next/ era
          -- (as opposed to /any/ subsequent era)
          TransitionInfo
TransitionImpossible
      , hardForkLedgerViewPerEra :: HardForkState f (blk : blk' : blks')
hardForkLedgerViewPerEra =
          Telescope (K Past) (Current f) (blk : blk' : blks')
-> HardForkState f (blk : blk' : blks')
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState (Telescope (K Past) (Current f) (blk : blk' : blks')
 -> HardForkState f (blk : blk' : blks'))
-> Telescope (K Past) (Current f) (blk : blk' : blks')
-> HardForkState f (blk : blk' : blks')
forall a b. (a -> b) -> a -> b
$
            K Past blk
-> Telescope (K Past) (Current f) (blk' : blks')
-> Telescope (K Past) (Current f) (blk : blk' : blks')
forall {k} (g :: k -> *) (x :: k) (f :: k -> *) (xs1 :: [k]).
g x -> Telescope g f xs1 -> Telescope g f (x : xs1)
TS (Past -> K Past blk
forall k a (b :: k). a -> K a b
K (Bound -> Bound -> Past
Past Bound
start Bound
end)) (Telescope (K Past) (Current f) (blk' : blks')
 -> Telescope (K Past) (Current f) (blk : blk' : blks'))
-> Telescope (K Past) (Current f) (blk' : blks')
-> Telescope (K Past) (Current f) (blk : blk' : blks')
forall a b. (a -> b) -> a -> b
$
              Current f blk' -> Telescope (K Past) (Current f) (blk' : blks')
forall {k} (f :: k -> *) (x :: k) (g :: k -> *) (xs1 :: [k]).
f x -> Telescope g f (x : xs1)
TZ (Bound -> f blk' -> Current f blk'
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
Current Bound
end f blk'
view)
      }

shiftView ::
  K Past blk ->
  HardForkLedgerView_ f blks ->
  HardForkLedgerView_ f (blk : blks)
shiftView :: forall blk (f :: * -> *) (blks :: [*]).
K Past blk
-> HardForkLedgerView_ f blks -> HardForkLedgerView_ f (blk : blks)
shiftView K Past blk
past HardForkLedgerView{TransitionInfo
HardForkState f blks
hardForkLedgerViewTransition :: forall (f :: * -> *) (xs :: [*]).
HardForkLedgerView_ f xs -> TransitionInfo
hardForkLedgerViewPerEra :: forall (f :: * -> *) (xs :: [*]).
HardForkLedgerView_ f xs -> HardForkState f xs
hardForkLedgerViewTransition :: TransitionInfo
hardForkLedgerViewPerEra :: HardForkState f blks
..} =
  HardForkLedgerView
    { hardForkLedgerViewTransition :: TransitionInfo
hardForkLedgerViewTransition = TransitionInfo
hardForkLedgerViewTransition
    , hardForkLedgerViewPerEra :: HardForkState f (blk : blks)
hardForkLedgerViewPerEra =
        Telescope (K Past) (Current f) (blk : blks)
-> HardForkState f (blk : blks)
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState
          (Telescope (K Past) (Current f) (blk : blks)
 -> HardForkState f (blk : blks))
-> (HardForkState f blks
    -> Telescope (K Past) (Current f) (blk : blks))
-> HardForkState f blks
-> HardForkState f (blk : blks)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K Past blk
-> Telescope (K Past) (Current f) blks
-> Telescope (K Past) (Current f) (blk : blks)
forall {k} (g :: k -> *) (x :: k) (f :: k -> *) (xs1 :: [k]).
g x -> Telescope g f xs1 -> Telescope g f (x : xs1)
TS K Past blk
past
          (Telescope (K Past) (Current f) blks
 -> Telescope (K Past) (Current f) (blk : blks))
-> (HardForkState f blks -> Telescope (K Past) (Current f) blks)
-> HardForkState f blks
-> Telescope (K Past) (Current f) (blk : blks)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkState f blks -> Telescope (K Past) (Current f) blks
forall (f :: * -> *) (xs :: [*]).
HardForkState f xs -> Telescope (K Past) (Current f) xs
getHardForkState
          (HardForkState f blks -> HardForkState f (blk : blks))
-> HardForkState f blks -> HardForkState f (blk : blks)
forall a b. (a -> b) -> a -> b
$ HardForkState f blks
hardForkLedgerViewPerEra
    }

{-------------------------------------------------------------------------------
  Inspection
-------------------------------------------------------------------------------}

data HardForkLedgerWarning xs
  = -- | Warning from the underlying era
    HardForkWarningInEra (OneEraLedgerWarning xs)
  | -- | The transition to the next era does not match the 'EraParams'
    --
    -- The 'EraParams' can specify a lower bound on when the transition to the
    -- next era will happen. If the actual transition, when confirmed, is
    -- /before/ this lower bound, the node is misconfigured and will likely
    -- not work correctly. This should be taken care of as soon as possible
    -- (before the transition happens).
    HardForkWarningTransitionMismatch (EraIndex xs) EraParams EpochNo
  | -- | Transition in the final era
    --
    -- The final era should never confirm any transitions. For clarity, we also
    -- record the index of that final era.
    HardForkWarningTransitionInFinalEra (EraIndex xs) EpochNo
  | -- | An already-confirmed transition got un-confirmed
    HardForkWarningTransitionUnconfirmed (EraIndex xs)
  | -- | An already-confirmed transition got changed
    --
    -- We record the indices of the era we are transitioning from and to,
    -- as well as the old and new 'EpochNo' of that transition, in that order.
    HardForkWarningTransitionReconfirmed (EraIndex xs) (EraIndex xs) EpochNo EpochNo

data HardForkLedgerUpdate xs
  = HardForkUpdateInEra (OneEraLedgerUpdate xs)
  | -- | Hard fork transition got confirmed
    HardForkUpdateTransitionConfirmed (EraIndex xs) (EraIndex xs) EpochNo
  | -- | Hard fork transition happened
    --
    -- We record the 'EpochNo' at the start of the era after the transition
    HardForkUpdateTransitionDone (EraIndex xs) (EraIndex xs) EpochNo
  | -- | The hard fork transition rolled back
    HardForkUpdateTransitionRolledBack (EraIndex xs) (EraIndex xs)

deriving instance CanHardFork xs => Show (HardForkLedgerWarning xs)
deriving instance CanHardFork xs => Eq (HardForkLedgerWarning xs)

deriving instance CanHardFork xs => Show (HardForkLedgerUpdate xs)
deriving instance CanHardFork xs => Eq (HardForkLedgerUpdate xs)

instance CanHardFork xs => Condense (HardForkLedgerUpdate xs) where
  condense :: HardForkLedgerUpdate xs -> String
condense (HardForkUpdateInEra (OneEraLedgerUpdate NS WrapLedgerUpdate xs
update)) =
    NS (K String) xs -> CollapseTo NS String
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K String) xs -> CollapseTo NS String)
-> NS (K String) xs -> CollapseTo NS String
forall a b. (a -> b) -> a -> b
$ Proxy SingleEraBlock
-> (forall a. SingleEraBlock a => WrapLedgerUpdate a -> K String a)
-> NS WrapLedgerUpdate xs
-> NS (K String) xs
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
hcmap Proxy SingleEraBlock
proxySingle (String -> K String a
forall k a (b :: k). a -> K a b
K (String -> K String a)
-> (WrapLedgerUpdate a -> String)
-> WrapLedgerUpdate a
-> K String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerUpdate a -> String
forall a. Condense a => a -> String
condense (LedgerUpdate a -> String)
-> (WrapLedgerUpdate a -> LedgerUpdate a)
-> WrapLedgerUpdate a
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapLedgerUpdate a -> LedgerUpdate a
forall blk. WrapLedgerUpdate blk -> LedgerUpdate blk
unwrapLedgerUpdate) NS WrapLedgerUpdate xs
update
  condense (HardForkUpdateTransitionConfirmed EraIndex xs
ix EraIndex xs
ix' EpochNo
t) =
    String
"confirmed " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (EraIndex xs, EraIndex xs, EpochNo) -> String
forall a. Condense a => a -> String
condense (EraIndex xs
ix, EraIndex xs
ix', EpochNo
t)
  condense (HardForkUpdateTransitionDone EraIndex xs
ix EraIndex xs
ix' EpochNo
e) =
    String
"done " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (EraIndex xs, EraIndex xs, EpochNo) -> String
forall a. Condense a => a -> String
condense (EraIndex xs
ix, EraIndex xs
ix', EpochNo
e)
  condense (HardForkUpdateTransitionRolledBack EraIndex xs
ix EraIndex xs
ix') =
    String
"rolled back " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (EraIndex xs, EraIndex xs) -> String
forall a. Condense a => a -> String
condense (EraIndex xs
ix, EraIndex xs
ix')

instance CanHardFork xs => InspectLedger (HardForkBlock xs) where
  type LedgerWarning (HardForkBlock xs) = HardForkLedgerWarning xs
  type LedgerUpdate (HardForkBlock xs) = HardForkLedgerUpdate xs

  inspectLedger :: forall (mk1 :: MapKind) (mk2 :: MapKind).
TopLevelConfig (HardForkBlock xs)
-> LedgerState (HardForkBlock xs) mk1
-> LedgerState (HardForkBlock xs) mk2
-> [LedgerEvent (HardForkBlock xs)]
inspectLedger
    TopLevelConfig (HardForkBlock xs)
cfg
    (HardForkLedgerState HardForkState (Flip LedgerState mk1) xs
before)
    (HardForkLedgerState HardForkState (Flip LedgerState mk2) xs
after) =
      NP WrapPartialLedgerConfig xs
-> NP (K EraParams) xs
-> NP TopLevelConfig xs
-> NS (Current (Flip LedgerState mk1)) xs
-> NS (Current (Flip LedgerState mk2)) xs
-> [LedgerEvent (HardForkBlock xs)]
forall (xs :: [*]) (mk1 :: MapKind) (mk2 :: MapKind).
CanHardFork xs =>
NP WrapPartialLedgerConfig xs
-> NP (K EraParams) xs
-> NP TopLevelConfig xs
-> NS (Current (Flip LedgerState mk1)) xs
-> NS (Current (Flip LedgerState mk2)) 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 (Flip LedgerState mk1)) xs
-> NS (Current (Flip LedgerState mk1)) xs
forall {k} (g :: k -> *) (f :: k -> *) (xs :: [k]).
Telescope g f xs -> NS f xs
Telescope.tip (HardForkState (Flip LedgerState mk1) xs
-> Telescope (K Past) (Current (Flip LedgerState mk1)) xs
forall (f :: * -> *) (xs :: [*]).
HardForkState f xs -> Telescope (K Past) (Current f) xs
getHardForkState HardForkState (Flip LedgerState mk1) xs
before))
        (Telescope (K Past) (Current (Flip LedgerState mk2)) xs
-> NS (Current (Flip LedgerState mk2)) xs
forall {k} (g :: k -> *) (f :: k -> *) (xs :: [k]).
Telescope g f xs -> NS f xs
Telescope.tip (HardForkState (Flip LedgerState mk2) xs
-> Telescope (K Past) (Current (Flip LedgerState mk2)) xs
forall (f :: * -> *) (xs :: [*]).
HardForkState f xs -> Telescope (K Past) (Current f) xs
getHardForkState HardForkState (Flip LedgerState mk2) xs
after))
     where
      HardForkLedgerConfig{Shape xs
PerEraLedgerConfig xs
hardForkLedgerConfigPerEra :: forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
hardForkLedgerConfigShape :: forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs
hardForkLedgerConfigShape :: Shape xs
hardForkLedgerConfigPerEra :: PerEraLedgerConfig xs
..} = TopLevelConfig (HardForkBlock xs)
-> LedgerConfig (HardForkBlock xs)
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig (HardForkBlock xs)
cfg

      pcfgs :: NP WrapPartialLedgerConfig xs
pcfgs = PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
forall (xs :: [*]).
PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
getPerEraLedgerConfig PerEraLedgerConfig xs
hardForkLedgerConfigPerEra
      shape :: Exactly xs EraParams
shape = Shape xs -> Exactly xs EraParams
forall (xs :: [*]). Shape xs -> Exactly xs EraParams
History.getShape Shape xs
hardForkLedgerConfigShape
      cfgs :: NP TopLevelConfig xs
cfgs = EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
forall (xs :: [*]).
All SingleEraBlock xs =>
EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
distribTopLevelConfig EpochInfo (Except PastHorizonException)
ei TopLevelConfig (HardForkBlock xs)
cfg
      ei :: EpochInfo (Except PastHorizonException)
ei = HardForkLedgerConfig xs
-> HardForkState (Flip LedgerState mk2) xs
-> EpochInfo (Except PastHorizonException)
forall (xs :: [*]) (mk :: MapKind).
All SingleEraBlock xs =>
HardForkLedgerConfig xs
-> HardForkState (Flip LedgerState mk) xs
-> EpochInfo (Except PastHorizonException)
State.epochInfoLedger (TopLevelConfig (HardForkBlock xs)
-> LedgerConfig (HardForkBlock xs)
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig (HardForkBlock xs)
cfg) HardForkState (Flip LedgerState mk2) xs
after

inspectHardForkLedger ::
  CanHardFork xs =>
  NP WrapPartialLedgerConfig xs ->
  NP (K EraParams) xs ->
  NP TopLevelConfig xs ->
  NS (Current (Flip LedgerState mk1)) xs ->
  NS (Current (Flip LedgerState mk2)) xs ->
  [LedgerEvent (HardForkBlock xs)]
inspectHardForkLedger :: forall (xs :: [*]) (mk1 :: MapKind) (mk2 :: MapKind).
CanHardFork xs =>
NP WrapPartialLedgerConfig xs
-> NP (K EraParams) xs
-> NP TopLevelConfig xs
-> NS (Current (Flip LedgerState mk1)) xs
-> NS (Current (Flip LedgerState mk2)) xs
-> [LedgerEvent (HardForkBlock xs)]
inspectHardForkLedger = NP WrapPartialLedgerConfig xs
-> NP (K EraParams) xs
-> NP TopLevelConfig xs
-> NS (Current (Flip LedgerState mk1)) xs
-> NS (Current (Flip LedgerState mk2)) xs
-> [LedgerEvent (HardForkBlock xs)]
forall (xs :: [*]) (mk1 :: MapKind) (mk2 :: MapKind).
All SingleEraBlock xs =>
NP WrapPartialLedgerConfig xs
-> NP (K EraParams) xs
-> NP TopLevelConfig xs
-> NS (Current (Flip LedgerState mk1)) xs
-> NS (Current (Flip LedgerState mk2)) xs
-> [LedgerEvent (HardForkBlock xs)]
go
 where
  go ::
    All SingleEraBlock xs =>
    NP WrapPartialLedgerConfig xs ->
    NP (K EraParams) xs ->
    NP TopLevelConfig xs ->
    NS (Current (Flip LedgerState mk1)) xs ->
    NS (Current (Flip LedgerState mk2)) xs ->
    [LedgerEvent (HardForkBlock xs)]

  go :: forall (xs :: [*]) (mk1 :: MapKind) (mk2 :: MapKind).
All SingleEraBlock xs =>
NP WrapPartialLedgerConfig xs
-> NP (K EraParams) xs
-> NP TopLevelConfig xs
-> NS (Current (Flip LedgerState mk1)) xs
-> NS (Current (Flip LedgerState mk2)) xs
-> [LedgerEvent (HardForkBlock xs)]
go (WrapPartialLedgerConfig x
pc :* NP WrapPartialLedgerConfig xs1
_) (K EraParams
ps :* NP (K EraParams) xs1
pss) (TopLevelConfig x
c :* NP TopLevelConfig xs1
_) (Z Current (Flip LedgerState mk1) x
before) (Z Current (Flip LedgerState mk2) x
after) =
    [[LedgerEvent (HardForkBlock xs)]]
-> [LedgerEvent (HardForkBlock xs)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ (LedgerEvent x -> LedgerEvent (HardForkBlock xs))
-> [LedgerEvent x] -> [LedgerEvent (HardForkBlock xs)]
forall a b. (a -> b) -> [a] -> [b]
map LedgerEvent x -> LedgerEvent (HardForkBlock xs)
LedgerEvent x -> LedgerEvent (HardForkBlock (x : xs1))
forall x (xs :: [*]).
LedgerEvent x -> LedgerEvent (HardForkBlock (x : xs))
liftEvent ([LedgerEvent x] -> [LedgerEvent (HardForkBlock xs)])
-> [LedgerEvent x] -> [LedgerEvent (HardForkBlock xs)]
forall a b. (a -> b) -> a -> b
$
          TopLevelConfig x
-> LedgerState x mk1 -> LedgerState x mk2 -> [LedgerEvent x]
forall blk (mk1 :: MapKind) (mk2 :: MapKind).
InspectLedger blk =>
TopLevelConfig blk
-> LedgerState blk mk1 -> LedgerState blk mk2 -> [LedgerEvent blk]
forall (mk1 :: MapKind) (mk2 :: MapKind).
TopLevelConfig x
-> LedgerState x mk1 -> LedgerState x mk2 -> [LedgerEvent x]
inspectLedger
            TopLevelConfig x
c
            (Flip LedgerState mk1 x -> LedgerState x mk1
forall x1 y1 (f :: x1 -> y1 -> *) (x2 :: y1) (y2 :: x1).
Flip f x2 y2 -> f y2 x2
unFlip (Flip LedgerState mk1 x -> LedgerState x mk1)
-> Flip LedgerState mk1 x -> LedgerState x mk1
forall a b. (a -> b) -> a -> b
$ Current (Flip LedgerState mk1) x -> Flip LedgerState mk1 x
forall (f :: * -> *) blk. Current f blk -> f blk
currentState Current (Flip LedgerState mk1) x
Current (Flip LedgerState mk1) x
before)
            (Flip LedgerState mk2 x -> LedgerState x mk2
forall x1 y1 (f :: x1 -> y1 -> *) (x2 :: y1) (y2 :: x1).
Flip f x2 y2 -> f y2 x2
unFlip (Flip LedgerState mk2 x -> LedgerState x mk2)
-> Flip LedgerState mk2 x -> LedgerState x mk2
forall a b. (a -> b) -> a -> b
$ Current (Flip LedgerState mk2) x -> Flip LedgerState mk2 x
forall (f :: * -> *) blk. Current f blk -> f blk
currentState Current (Flip LedgerState mk2) x
Current (Flip LedgerState mk2) x
after)
      , case (NP (K EraParams) xs1
pss, Maybe EpochNo
confirmedBefore, Maybe EpochNo
confirmedAfter) of
          (NP (K EraParams) xs1
_, Maybe EpochNo
Nothing, Maybe EpochNo
Nothing) ->
            []
          (NP (K EraParams) xs1
_, Just EpochNo
_, Maybe EpochNo
Nothing) ->
            -- TODO: This should be a warning, but this can currently happen
            -- in Byron.
            []
          -- return $ LedgerWarning $
          --   HardForkWarningTransitionUnconfirmed eraIndexZero
          (NP (K EraParams) xs1
Nil, Maybe EpochNo
Nothing, Just EpochNo
transition) ->
            LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerEvent (HardForkBlock xs)
 -> [LedgerEvent (HardForkBlock xs)])
-> LedgerEvent (HardForkBlock xs)
-> [LedgerEvent (HardForkBlock xs)]
forall a b. (a -> b) -> a -> b
$
              LedgerWarning (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs)
forall blk. LedgerWarning blk -> LedgerEvent blk
LedgerWarning (LedgerWarning (HardForkBlock xs)
 -> LedgerEvent (HardForkBlock xs))
-> LedgerWarning (HardForkBlock xs)
-> LedgerEvent (HardForkBlock xs)
forall a b. (a -> b) -> a -> b
$
                EraIndex '[x] -> EpochNo -> HardForkLedgerWarning '[x]
forall (xs :: [*]).
EraIndex xs -> EpochNo -> HardForkLedgerWarning xs
HardForkWarningTransitionInFinalEra EraIndex '[x]
forall x (xs :: [*]). EraIndex (x : xs)
eraIndexZero EpochNo
transition
          (NP (K EraParams) xs1
Nil, Just EpochNo
transition, Just EpochNo
transition') -> do
            -- Only warn if the transition has changed
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (EpochNo
transition EpochNo -> EpochNo -> Bool
forall a. Eq a => a -> a -> Bool
/= EpochNo
transition')
            LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerEvent (HardForkBlock xs)
 -> [LedgerEvent (HardForkBlock xs)])
-> LedgerEvent (HardForkBlock xs)
-> [LedgerEvent (HardForkBlock xs)]
forall a b. (a -> b) -> a -> b
$
              LedgerWarning (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs)
forall blk. LedgerWarning blk -> LedgerEvent blk
LedgerWarning (LedgerWarning (HardForkBlock xs)
 -> LedgerEvent (HardForkBlock xs))
-> LedgerWarning (HardForkBlock xs)
-> LedgerEvent (HardForkBlock xs)
forall a b. (a -> b) -> a -> b
$
                EraIndex '[x] -> EpochNo -> HardForkLedgerWarning '[x]
forall (xs :: [*]).
EraIndex xs -> EpochNo -> HardForkLedgerWarning xs
HardForkWarningTransitionInFinalEra EraIndex '[x]
forall x (xs :: [*]). EraIndex (x : xs)
eraIndexZero EpochNo
transition
          ((:*){}, Maybe EpochNo
Nothing, Just EpochNo
transition) ->
            LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerEvent (HardForkBlock xs)
 -> [LedgerEvent (HardForkBlock xs)])
-> LedgerEvent (HardForkBlock xs)
-> [LedgerEvent (HardForkBlock xs)]
forall a b. (a -> b) -> a -> b
$
              if SafeZone -> Bool
validLowerBound (EraParams -> SafeZone
History.eraSafeZone EraParams
ps)
                then
                  LedgerUpdate (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs)
forall blk. LedgerUpdate blk -> LedgerEvent blk
LedgerUpdate (LedgerUpdate (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs))
-> LedgerUpdate (HardForkBlock xs)
-> LedgerEvent (HardForkBlock xs)
forall a b. (a -> b) -> a -> b
$
                    EraIndex (x : x : xs1)
-> EraIndex (x : x : xs1)
-> EpochNo
-> HardForkLedgerUpdate (x : x : xs1)
forall (xs :: [*]).
EraIndex xs -> EraIndex xs -> EpochNo -> HardForkLedgerUpdate xs
HardForkUpdateTransitionConfirmed
                      EraIndex (x : x : xs1)
forall x (xs :: [*]). EraIndex (x : xs)
eraIndexZero
                      (EraIndex (x : xs1) -> EraIndex (x : x : xs1)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex (x : xs1)
forall x (xs :: [*]). EraIndex (x : xs)
eraIndexZero)
                      EpochNo
transition
                else
                  LedgerWarning (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs)
forall blk. LedgerWarning blk -> LedgerEvent blk
LedgerWarning (LedgerWarning (HardForkBlock xs)
 -> LedgerEvent (HardForkBlock xs))
-> LedgerWarning (HardForkBlock xs)
-> LedgerEvent (HardForkBlock xs)
forall a b. (a -> b) -> a -> b
$
                    EraIndex (x : x : xs1)
-> EraParams -> EpochNo -> HardForkLedgerWarning (x : x : xs1)
forall (xs :: [*]).
EraIndex xs -> EraParams -> EpochNo -> HardForkLedgerWarning xs
HardForkWarningTransitionMismatch
                      EraIndex (x : x : xs1)
forall x (xs :: [*]). EraIndex (x : xs)
eraIndexZero
                      EraParams
ps
                      EpochNo
transition
          ((:*){}, Just EpochNo
transition, Just EpochNo
transition') -> do
            Bool -> [()]
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (EpochNo
transition EpochNo -> EpochNo -> Bool
forall a. Eq a => a -> a -> Bool
/= EpochNo
transition')
            LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerEvent (HardForkBlock xs)
 -> [LedgerEvent (HardForkBlock xs)])
-> LedgerEvent (HardForkBlock xs)
-> [LedgerEvent (HardForkBlock xs)]
forall a b. (a -> b) -> a -> b
$
              LedgerWarning (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs)
forall blk. LedgerWarning blk -> LedgerEvent blk
LedgerWarning (LedgerWarning (HardForkBlock xs)
 -> LedgerEvent (HardForkBlock xs))
-> LedgerWarning (HardForkBlock xs)
-> LedgerEvent (HardForkBlock xs)
forall a b. (a -> b) -> a -> b
$
                EraIndex (x : x : xs1)
-> EraIndex (x : x : xs1)
-> EpochNo
-> EpochNo
-> HardForkLedgerWarning (x : x : xs1)
forall (xs :: [*]).
EraIndex xs
-> EraIndex xs -> EpochNo -> EpochNo -> HardForkLedgerWarning xs
HardForkWarningTransitionReconfirmed
                  EraIndex (x : x : xs1)
forall x (xs :: [*]). EraIndex (x : xs)
eraIndexZero
                  (EraIndex (x : xs1) -> EraIndex (x : x : xs1)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex (x : xs1)
forall x (xs :: [*]). EraIndex (x : xs)
eraIndexZero)
                  EpochNo
transition
                  EpochNo
transition'
      ]
   where
    confirmedBefore, confirmedAfter :: Maybe EpochNo
    confirmedBefore :: Maybe EpochNo
confirmedBefore =
      PartialLedgerConfig x
-> EraParams -> Bound -> LedgerState x mk1 -> Maybe EpochNo
forall blk (mk :: MapKind).
SingleEraBlock blk =>
PartialLedgerConfig blk
-> EraParams -> Bound -> LedgerState blk mk -> Maybe EpochNo
forall (mk :: MapKind).
PartialLedgerConfig x
-> EraParams -> Bound -> LedgerState x mk -> Maybe EpochNo
singleEraTransition
        (WrapPartialLedgerConfig x -> PartialLedgerConfig x
forall blk. WrapPartialLedgerConfig blk -> PartialLedgerConfig blk
unwrapPartialLedgerConfig WrapPartialLedgerConfig x
pc)
        EraParams
ps
        (Current (Flip LedgerState mk1) x -> Bound
forall (f :: * -> *) blk. Current f blk -> Bound
currentStart Current (Flip LedgerState mk1) x
before)
        (Flip LedgerState mk1 x -> LedgerState x mk1
forall x1 y1 (f :: x1 -> y1 -> *) (x2 :: y1) (y2 :: x1).
Flip f x2 y2 -> f y2 x2
unFlip (Flip LedgerState mk1 x -> LedgerState x mk1)
-> Flip LedgerState mk1 x -> LedgerState x mk1
forall a b. (a -> b) -> a -> b
$ Current (Flip LedgerState mk1) x -> Flip LedgerState mk1 x
forall (f :: * -> *) blk. Current f blk -> f blk
currentState Current (Flip LedgerState mk1) x
before)
    confirmedAfter :: Maybe EpochNo
confirmedAfter =
      PartialLedgerConfig x
-> EraParams -> Bound -> LedgerState x mk2 -> Maybe EpochNo
forall blk (mk :: MapKind).
SingleEraBlock blk =>
PartialLedgerConfig blk
-> EraParams -> Bound -> LedgerState blk mk -> Maybe EpochNo
forall (mk :: MapKind).
PartialLedgerConfig x
-> EraParams -> Bound -> LedgerState x mk -> Maybe EpochNo
singleEraTransition
        (WrapPartialLedgerConfig x -> PartialLedgerConfig x
forall blk. WrapPartialLedgerConfig blk -> PartialLedgerConfig blk
unwrapPartialLedgerConfig WrapPartialLedgerConfig x
pc)
        EraParams
ps
        (Current (Flip LedgerState mk2) x -> Bound
forall (f :: * -> *) blk. Current f blk -> Bound
currentStart Current (Flip LedgerState mk2) x
after)
        (Flip LedgerState mk2 x -> LedgerState x mk2
forall x1 y1 (f :: x1 -> y1 -> *) (x2 :: y1) (y2 :: x1).
Flip f x2 y2 -> f y2 x2
unFlip (Flip LedgerState mk2 x -> LedgerState x mk2)
-> Flip LedgerState mk2 x -> LedgerState x mk2
forall a b. (a -> b) -> a -> b
$ Current (Flip LedgerState mk2) x -> Flip LedgerState mk2 x
forall (f :: * -> *) blk. Current f blk -> f blk
currentState Current (Flip LedgerState mk2) x
after)
  go NP WrapPartialLedgerConfig xs
Nil NP (K EraParams) xs
_ NP TopLevelConfig xs
_ NS (Current (Flip LedgerState mk1)) xs
before NS (Current (Flip LedgerState mk2)) xs
_ =
    case NS (Current (Flip LedgerState mk1)) xs
before of {}
  go (WrapPartialLedgerConfig x
_ :* NP WrapPartialLedgerConfig xs1
pcs) (K EraParams x
_ :* NP (K EraParams) xs1
pss) (TopLevelConfig x
_ :* NP TopLevelConfig xs1
cs) (S NS (Current (Flip LedgerState mk1)) xs1
before) (S NS (Current (Flip LedgerState mk2)) xs1
after) =
    (LedgerEvent (HardForkBlock xs1) -> LedgerEvent (HardForkBlock xs))
-> [LedgerEvent (HardForkBlock xs1)]
-> [LedgerEvent (HardForkBlock xs)]
forall a b. (a -> b) -> [a] -> [b]
map LedgerEvent (HardForkBlock xs1) -> LedgerEvent (HardForkBlock xs)
LedgerEvent (HardForkBlock xs1)
-> LedgerEvent (HardForkBlock (x : xs1))
forall (xs :: [*]) x.
LedgerEvent (HardForkBlock xs)
-> LedgerEvent (HardForkBlock (x : xs))
shiftEvent ([LedgerEvent (HardForkBlock xs1)]
 -> [LedgerEvent (HardForkBlock xs)])
-> [LedgerEvent (HardForkBlock xs1)]
-> [LedgerEvent (HardForkBlock xs)]
forall a b. (a -> b) -> a -> b
$ NP WrapPartialLedgerConfig xs1
-> NP (K EraParams) xs1
-> NP TopLevelConfig xs1
-> NS (Current (Flip LedgerState mk1)) xs1
-> NS (Current (Flip LedgerState mk2)) xs1
-> [LedgerEvent (HardForkBlock xs1)]
forall (xs :: [*]) (mk1 :: MapKind) (mk2 :: MapKind).
All SingleEraBlock xs =>
NP WrapPartialLedgerConfig xs
-> NP (K EraParams) xs
-> NP TopLevelConfig xs
-> NS (Current (Flip LedgerState mk1)) xs
-> NS (Current (Flip LedgerState mk2)) xs
-> [LedgerEvent (HardForkBlock xs)]
go NP WrapPartialLedgerConfig xs1
pcs NP (K EraParams) xs1
NP (K EraParams) xs1
pss NP TopLevelConfig xs1
NP TopLevelConfig xs1
cs NS (Current (Flip LedgerState mk1)) xs1
NS (Current (Flip LedgerState mk1)) xs1
before NS (Current (Flip LedgerState mk2)) xs1
NS (Current (Flip LedgerState mk2)) xs1
after
  go NP WrapPartialLedgerConfig xs
_ NP (K EraParams) xs
_ NP TopLevelConfig xs
_ (Z Current (Flip LedgerState mk1) x
_) (S NS (Current (Flip LedgerState mk2)) xs1
after) =
    LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerEvent (HardForkBlock xs)
 -> [LedgerEvent (HardForkBlock xs)])
-> LedgerEvent (HardForkBlock xs)
-> [LedgerEvent (HardForkBlock xs)]
forall a b. (a -> b) -> a -> b
$
      LedgerUpdate (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs)
forall blk. LedgerUpdate blk -> LedgerEvent blk
LedgerUpdate (LedgerUpdate (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs))
-> LedgerUpdate (HardForkBlock xs)
-> LedgerEvent (HardForkBlock xs)
forall a b. (a -> b) -> a -> b
$
        EraIndex (x : xs1)
-> EraIndex (x : xs1) -> EpochNo -> HardForkLedgerUpdate (x : xs1)
forall (xs :: [*]).
EraIndex xs -> EraIndex xs -> EpochNo -> HardForkLedgerUpdate xs
HardForkUpdateTransitionDone
          EraIndex (x : xs1)
forall x (xs :: [*]). EraIndex (x : xs)
eraIndexZero
          (EraIndex xs1 -> EraIndex (x : xs1)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc (EraIndex xs1 -> EraIndex (x : xs1))
-> EraIndex xs1 -> EraIndex (x : xs1)
forall a b. (a -> b) -> a -> b
$ NS (Current (Flip LedgerState mk2)) xs1 -> EraIndex xs1
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
NS f xs -> EraIndex xs
eraIndexFromNS NS (Current (Flip LedgerState mk2)) xs1
after)
          (NS (K EpochNo) xs1 -> CollapseTo NS EpochNo
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K EpochNo) xs1 -> CollapseTo NS EpochNo)
-> NS (K EpochNo) xs1 -> CollapseTo NS EpochNo
forall a b. (a -> b) -> a -> b
$ (forall a. Current (Flip LedgerState mk2) a -> K EpochNo a)
-> NS (Current (Flip LedgerState mk2)) xs1 -> NS (K EpochNo) xs1
forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap (EpochNo -> K EpochNo a
forall k a (b :: k). a -> K a b
K (EpochNo -> K EpochNo a)
-> (Current (Flip LedgerState mk2) a -> EpochNo)
-> Current (Flip LedgerState mk2) a
-> K EpochNo a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bound -> EpochNo
boundEpoch (Bound -> EpochNo)
-> (Current (Flip LedgerState mk2) a -> Bound)
-> Current (Flip LedgerState mk2) a
-> EpochNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Current (Flip LedgerState mk2) a -> Bound
forall (f :: * -> *) blk. Current f blk -> Bound
currentStart) NS (Current (Flip LedgerState mk2)) xs1
after)
  go NP WrapPartialLedgerConfig xs
_ NP (K EraParams) xs
_ NP TopLevelConfig xs
_ (S NS (Current (Flip LedgerState mk1)) xs1
before) (Z Current (Flip LedgerState mk2) x
_) =
    LedgerEvent (HardForkBlock xs) -> [LedgerEvent (HardForkBlock xs)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerEvent (HardForkBlock xs)
 -> [LedgerEvent (HardForkBlock xs)])
-> LedgerEvent (HardForkBlock xs)
-> [LedgerEvent (HardForkBlock xs)]
forall a b. (a -> b) -> a -> b
$
      LedgerUpdate (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs)
forall blk. LedgerUpdate blk -> LedgerEvent blk
LedgerUpdate (LedgerUpdate (HardForkBlock xs) -> LedgerEvent (HardForkBlock xs))
-> LedgerUpdate (HardForkBlock xs)
-> LedgerEvent (HardForkBlock xs)
forall a b. (a -> b) -> a -> b
$
        EraIndex (x : xs1)
-> EraIndex (x : xs1) -> HardForkLedgerUpdate (x : xs1)
forall (xs :: [*]).
EraIndex xs -> EraIndex xs -> HardForkLedgerUpdate xs
HardForkUpdateTransitionRolledBack
          (EraIndex xs1 -> EraIndex (x : xs1)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc (EraIndex xs1 -> EraIndex (x : xs1))
-> EraIndex xs1 -> EraIndex (x : xs1)
forall a b. (a -> b) -> a -> b
$ NS (Current (Flip LedgerState mk1)) xs1 -> EraIndex xs1
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
NS f xs -> EraIndex xs
eraIndexFromNS NS (Current (Flip LedgerState mk1)) xs1
before)
          EraIndex (x : xs1)
forall x (xs :: [*]). EraIndex (x : xs)
eraIndexZero

  validLowerBound :: SafeZone -> Bool
  validLowerBound :: SafeZone -> Bool
validLowerBound (StandardSafeZone Word64
_) = Bool
True
  validLowerBound SafeZone
UnsafeIndefiniteSafeZone = Bool
False

{-------------------------------------------------------------------------------
  Internal auxiliary: lifting and shifting events
-------------------------------------------------------------------------------}

liftEvent ::
  LedgerEvent x ->
  LedgerEvent (HardForkBlock (x ': xs))
liftEvent :: forall x (xs :: [*]).
LedgerEvent x -> LedgerEvent (HardForkBlock (x : xs))
liftEvent (LedgerWarning LedgerWarning x
warning) = LedgerWarning (HardForkBlock (x : xs))
-> LedgerEvent (HardForkBlock (x : xs))
forall blk. LedgerWarning blk -> LedgerEvent blk
LedgerWarning (LedgerWarning (HardForkBlock (x : xs))
 -> LedgerEvent (HardForkBlock (x : xs)))
-> LedgerWarning (HardForkBlock (x : xs))
-> LedgerEvent (HardForkBlock (x : xs))
forall a b. (a -> b) -> a -> b
$ LedgerWarning x -> HardForkLedgerWarning (x : xs)
forall x (xs :: [*]).
LedgerWarning x -> HardForkLedgerWarning (x : xs)
liftWarning LedgerWarning x
warning
liftEvent (LedgerUpdate LedgerUpdate x
update) = LedgerUpdate (HardForkBlock (x : xs))
-> LedgerEvent (HardForkBlock (x : xs))
forall blk. LedgerUpdate blk -> LedgerEvent blk
LedgerUpdate (LedgerUpdate (HardForkBlock (x : xs))
 -> LedgerEvent (HardForkBlock (x : xs)))
-> LedgerUpdate (HardForkBlock (x : xs))
-> LedgerEvent (HardForkBlock (x : xs))
forall a b. (a -> b) -> a -> b
$ LedgerUpdate x -> HardForkLedgerUpdate (x : xs)
forall x (xs :: [*]).
LedgerUpdate x -> HardForkLedgerUpdate (x : xs)
liftUpdate LedgerUpdate x
update

liftWarning :: LedgerWarning x -> HardForkLedgerWarning (x ': xs)
liftWarning :: forall x (xs :: [*]).
LedgerWarning x -> HardForkLedgerWarning (x : xs)
liftWarning =
  OneEraLedgerWarning (x : xs) -> HardForkLedgerWarning (x : xs)
forall (xs :: [*]).
OneEraLedgerWarning xs -> HardForkLedgerWarning xs
HardForkWarningInEra
    (OneEraLedgerWarning (x : xs) -> HardForkLedgerWarning (x : xs))
-> (LedgerWarning x -> OneEraLedgerWarning (x : xs))
-> LedgerWarning x
-> HardForkLedgerWarning (x : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS WrapLedgerWarning (x : xs) -> OneEraLedgerWarning (x : xs)
forall (xs :: [*]).
NS WrapLedgerWarning xs -> OneEraLedgerWarning xs
OneEraLedgerWarning
    (NS WrapLedgerWarning (x : xs) -> OneEraLedgerWarning (x : xs))
-> (LedgerWarning x -> NS WrapLedgerWarning (x : xs))
-> LedgerWarning x
-> OneEraLedgerWarning (x : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapLedgerWarning x -> NS WrapLedgerWarning (x : xs)
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NS f (x : xs1)
Z
    (WrapLedgerWarning x -> NS WrapLedgerWarning (x : xs))
-> (LedgerWarning x -> WrapLedgerWarning x)
-> LedgerWarning x
-> NS WrapLedgerWarning (x : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerWarning x -> WrapLedgerWarning x
forall blk. LedgerWarning blk -> WrapLedgerWarning blk
WrapLedgerWarning

liftUpdate :: LedgerUpdate x -> HardForkLedgerUpdate (x ': xs)
liftUpdate :: forall x (xs :: [*]).
LedgerUpdate x -> HardForkLedgerUpdate (x : xs)
liftUpdate =
  OneEraLedgerUpdate (x : xs) -> HardForkLedgerUpdate (x : xs)
forall (xs :: [*]).
OneEraLedgerUpdate xs -> HardForkLedgerUpdate xs
HardForkUpdateInEra
    (OneEraLedgerUpdate (x : xs) -> HardForkLedgerUpdate (x : xs))
-> (LedgerUpdate x -> OneEraLedgerUpdate (x : xs))
-> LedgerUpdate x
-> HardForkLedgerUpdate (x : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS WrapLedgerUpdate (x : xs) -> OneEraLedgerUpdate (x : xs)
forall (xs :: [*]). NS WrapLedgerUpdate xs -> OneEraLedgerUpdate xs
OneEraLedgerUpdate
    (NS WrapLedgerUpdate (x : xs) -> OneEraLedgerUpdate (x : xs))
-> (LedgerUpdate x -> NS WrapLedgerUpdate (x : xs))
-> LedgerUpdate x
-> OneEraLedgerUpdate (x : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapLedgerUpdate x -> NS WrapLedgerUpdate (x : xs)
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NS f (x : xs1)
Z
    (WrapLedgerUpdate x -> NS WrapLedgerUpdate (x : xs))
-> (LedgerUpdate x -> WrapLedgerUpdate x)
-> LedgerUpdate x
-> NS WrapLedgerUpdate (x : xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerUpdate x -> WrapLedgerUpdate x
forall blk. LedgerUpdate blk -> WrapLedgerUpdate blk
WrapLedgerUpdate

shiftEvent ::
  LedgerEvent (HardForkBlock xs) ->
  LedgerEvent (HardForkBlock (x ': xs))
shiftEvent :: forall (xs :: [*]) x.
LedgerEvent (HardForkBlock xs)
-> LedgerEvent (HardForkBlock (x : xs))
shiftEvent (LedgerWarning LedgerWarning (HardForkBlock xs)
warning) = LedgerWarning (HardForkBlock (x : xs))
-> LedgerEvent (HardForkBlock (x : xs))
forall blk. LedgerWarning blk -> LedgerEvent blk
LedgerWarning (LedgerWarning (HardForkBlock (x : xs))
 -> LedgerEvent (HardForkBlock (x : xs)))
-> LedgerWarning (HardForkBlock (x : xs))
-> LedgerEvent (HardForkBlock (x : xs))
forall a b. (a -> b) -> a -> b
$ HardForkLedgerWarning xs -> HardForkLedgerWarning (x : xs)
forall (xs :: [*]) x.
HardForkLedgerWarning xs -> HardForkLedgerWarning (x : xs)
shiftWarning LedgerWarning (HardForkBlock xs)
HardForkLedgerWarning xs
warning
shiftEvent (LedgerUpdate LedgerUpdate (HardForkBlock xs)
update) = LedgerUpdate (HardForkBlock (x : xs))
-> LedgerEvent (HardForkBlock (x : xs))
forall blk. LedgerUpdate blk -> LedgerEvent blk
LedgerUpdate (LedgerUpdate (HardForkBlock (x : xs))
 -> LedgerEvent (HardForkBlock (x : xs)))
-> LedgerUpdate (HardForkBlock (x : xs))
-> LedgerEvent (HardForkBlock (x : xs))
forall a b. (a -> b) -> a -> b
$ HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x : xs)
forall (xs :: [*]) x.
HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x : xs)
shiftUpdate LedgerUpdate (HardForkBlock xs)
HardForkLedgerUpdate xs
update

shiftWarning :: HardForkLedgerWarning xs -> HardForkLedgerWarning (x ': xs)
shiftWarning :: forall (xs :: [*]) x.
HardForkLedgerWarning xs -> HardForkLedgerWarning (x : xs)
shiftWarning = HardForkLedgerWarning xs -> HardForkLedgerWarning (x : xs)
forall (xs :: [*]) x.
HardForkLedgerWarning xs -> HardForkLedgerWarning (x : xs)
go
 where
  go :: HardForkLedgerWarning xs1 -> HardForkLedgerWarning (x : xs1)
go (HardForkWarningInEra (OneEraLedgerWarning NS WrapLedgerWarning xs1
warning)) =
    OneEraLedgerWarning (x : xs1) -> HardForkLedgerWarning (x : xs1)
forall (xs :: [*]).
OneEraLedgerWarning xs -> HardForkLedgerWarning xs
HardForkWarningInEra
      (NS WrapLedgerWarning (x : xs1) -> OneEraLedgerWarning (x : xs1)
forall (xs :: [*]).
NS WrapLedgerWarning xs -> OneEraLedgerWarning xs
OneEraLedgerWarning (NS WrapLedgerWarning xs1 -> NS WrapLedgerWarning (x : xs1)
forall {k} (f :: k -> *) (xs1 :: [k]) (x :: k).
NS f xs1 -> NS f (x : xs1)
S NS WrapLedgerWarning xs1
warning))
  go (HardForkWarningTransitionMismatch EraIndex xs1
ix EraParams
ps EpochNo
t) =
    EraIndex (x : xs1)
-> EraParams -> EpochNo -> HardForkLedgerWarning (x : xs1)
forall (xs :: [*]).
EraIndex xs -> EraParams -> EpochNo -> HardForkLedgerWarning xs
HardForkWarningTransitionMismatch
      (EraIndex xs1 -> EraIndex (x : xs1)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex xs1
ix)
      EraParams
ps
      EpochNo
t
  go (HardForkWarningTransitionInFinalEra EraIndex xs1
ix EpochNo
t) =
    EraIndex (x : xs1) -> EpochNo -> HardForkLedgerWarning (x : xs1)
forall (xs :: [*]).
EraIndex xs -> EpochNo -> HardForkLedgerWarning xs
HardForkWarningTransitionInFinalEra
      (EraIndex xs1 -> EraIndex (x : xs1)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex xs1
ix)
      EpochNo
t
  go (HardForkWarningTransitionUnconfirmed EraIndex xs1
ix) =
    EraIndex (x : xs1) -> HardForkLedgerWarning (x : xs1)
forall (xs :: [*]). EraIndex xs -> HardForkLedgerWarning xs
HardForkWarningTransitionUnconfirmed
      (EraIndex xs1 -> EraIndex (x : xs1)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex xs1
ix)
  go (HardForkWarningTransitionReconfirmed EraIndex xs1
ix EraIndex xs1
ix' EpochNo
t EpochNo
t') =
    EraIndex (x : xs1)
-> EraIndex (x : xs1)
-> EpochNo
-> EpochNo
-> HardForkLedgerWarning (x : xs1)
forall (xs :: [*]).
EraIndex xs
-> EraIndex xs -> EpochNo -> EpochNo -> HardForkLedgerWarning xs
HardForkWarningTransitionReconfirmed
      (EraIndex xs1 -> EraIndex (x : xs1)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex xs1
ix)
      (EraIndex xs1 -> EraIndex (x : xs1)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex xs1
ix')
      EpochNo
t
      EpochNo
t'

shiftUpdate :: HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x ': xs)
shiftUpdate :: forall (xs :: [*]) x.
HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x : xs)
shiftUpdate = HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x : xs)
forall (xs :: [*]) x.
HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x : xs)
go
 where
  go :: HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x ': xs)
  go :: forall (xs :: [*]) x.
HardForkLedgerUpdate xs -> HardForkLedgerUpdate (x : xs)
go (HardForkUpdateInEra (OneEraLedgerUpdate NS WrapLedgerUpdate xs
update)) =
    OneEraLedgerUpdate (x : xs) -> HardForkLedgerUpdate (x : xs)
forall (xs :: [*]).
OneEraLedgerUpdate xs -> HardForkLedgerUpdate xs
HardForkUpdateInEra
      (NS WrapLedgerUpdate (x : xs) -> OneEraLedgerUpdate (x : xs)
forall (xs :: [*]). NS WrapLedgerUpdate xs -> OneEraLedgerUpdate xs
OneEraLedgerUpdate (NS WrapLedgerUpdate xs -> NS WrapLedgerUpdate (x : xs)
forall {k} (f :: k -> *) (xs1 :: [k]) (x :: k).
NS f xs1 -> NS f (x : xs1)
S NS WrapLedgerUpdate xs
update))
  go (HardForkUpdateTransitionConfirmed EraIndex xs
ix EraIndex xs
ix' EpochNo
t) =
    EraIndex (x : xs)
-> EraIndex (x : xs) -> EpochNo -> HardForkLedgerUpdate (x : xs)
forall (xs :: [*]).
EraIndex xs -> EraIndex xs -> EpochNo -> HardForkLedgerUpdate xs
HardForkUpdateTransitionConfirmed
      (EraIndex xs -> EraIndex (x : xs)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex xs
ix)
      (EraIndex xs -> EraIndex (x : xs)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex xs
ix')
      EpochNo
t
  go (HardForkUpdateTransitionDone EraIndex xs
ix EraIndex xs
ix' EpochNo
e) =
    EraIndex (x : xs)
-> EraIndex (x : xs) -> EpochNo -> HardForkLedgerUpdate (x : xs)
forall (xs :: [*]).
EraIndex xs -> EraIndex xs -> EpochNo -> HardForkLedgerUpdate xs
HardForkUpdateTransitionDone
      (EraIndex xs -> EraIndex (x : xs)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex xs
ix)
      (EraIndex xs -> EraIndex (x : xs)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex xs
ix')
      EpochNo
e
  go (HardForkUpdateTransitionRolledBack EraIndex xs
ix EraIndex xs
ix') =
    EraIndex (x : xs)
-> EraIndex (x : xs) -> HardForkLedgerUpdate (x : xs)
forall (xs :: [*]).
EraIndex xs -> EraIndex xs -> HardForkLedgerUpdate xs
HardForkUpdateTransitionRolledBack
      (EraIndex xs -> EraIndex (x : xs)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex xs
ix)
      (EraIndex xs -> EraIndex (x : xs)
forall (xs :: [*]) x. EraIndex xs -> EraIndex (x : xs)
eraIndexSucc EraIndex xs
ix')

{-------------------------------------------------------------------------------
  Auxiliary
-------------------------------------------------------------------------------}

ledgerInfo ::
  forall blk mk.
  SingleEraBlock blk =>
  Current (FlipTickedLedgerState mk) blk -> LedgerEraInfo blk
ledgerInfo :: forall blk (mk :: MapKind).
SingleEraBlock blk =>
Current (FlipTickedLedgerState mk) blk -> LedgerEraInfo blk
ledgerInfo Current (FlipTickedLedgerState mk) blk
_ = SingleEraInfo blk -> LedgerEraInfo blk
forall blk. SingleEraInfo blk -> LedgerEraInfo blk
LedgerEraInfo (SingleEraInfo blk -> LedgerEraInfo blk)
-> SingleEraInfo blk -> LedgerEraInfo blk
forall a b. (a -> b) -> a -> b
$ Proxy blk -> SingleEraInfo blk
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
forall (proxy :: * -> *). proxy blk -> SingleEraInfo blk
singleEraInfo (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)

ledgerViewInfo ::
  forall blk f.
  SingleEraBlock blk =>
  f blk -> LedgerEraInfo blk
ledgerViewInfo :: forall blk (f :: * -> *).
SingleEraBlock blk =>
f blk -> LedgerEraInfo blk
ledgerViewInfo f blk
_ = SingleEraInfo blk -> LedgerEraInfo blk
forall blk. SingleEraInfo blk -> LedgerEraInfo blk
LedgerEraInfo (SingleEraInfo blk -> LedgerEraInfo blk)
-> SingleEraInfo blk -> LedgerEraInfo blk
forall a b. (a -> b) -> a -> b
$ Proxy blk -> SingleEraInfo blk
forall blk (proxy :: * -> *).
SingleEraBlock blk =>
proxy blk -> SingleEraInfo blk
forall (proxy :: * -> *). proxy blk -> SingleEraInfo blk
singleEraInfo (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk)

injectLedgerError :: SListI xs => Index xs blk -> LedgerError blk -> HardForkLedgerError xs
injectLedgerError :: forall (xs :: [*]) blk.
SListI xs =>
Index xs blk -> LedgerError blk -> HardForkLedgerError xs
injectLedgerError Index xs blk
index =
  OneEraLedgerError xs -> HardForkLedgerError xs
forall (xs :: [*]). OneEraLedgerError xs -> HardForkLedgerError xs
HardForkLedgerErrorFromEra
    (OneEraLedgerError xs -> HardForkLedgerError xs)
-> (LedgerErr (LedgerState blk) -> OneEraLedgerError xs)
-> LedgerErr (LedgerState blk)
-> HardForkLedgerError xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS WrapLedgerErr xs -> OneEraLedgerError xs
forall (xs :: [*]). NS WrapLedgerErr xs -> OneEraLedgerError xs
OneEraLedgerError
    (NS WrapLedgerErr xs -> OneEraLedgerError xs)
-> (LedgerErr (LedgerState blk) -> NS WrapLedgerErr xs)
-> LedgerErr (LedgerState blk)
-> OneEraLedgerError xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index xs blk -> WrapLedgerErr blk -> NS WrapLedgerErr xs
forall {k} (f :: k -> *) (x :: k) (xs :: [k]).
All Top xs =>
Index xs x -> f x -> NS f xs
injectNS Index xs blk
index
    (WrapLedgerErr blk -> NS WrapLedgerErr xs)
-> (LedgerErr (LedgerState blk) -> WrapLedgerErr blk)
-> LedgerErr (LedgerState blk)
-> NS WrapLedgerErr xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerErr (LedgerState blk) -> WrapLedgerErr blk
forall blk. LedgerError blk -> WrapLedgerErr blk
WrapLedgerErr

injectLedgerEvent ::
  SListI xs => Index xs blk -> AuxLedgerEvent (LedgerState blk) -> OneEraLedgerEvent xs
injectLedgerEvent :: forall (xs :: [*]) blk.
SListI xs =>
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]).
All Top xs =>
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

{-------------------------------------------------------------------------------
  Ledger Tables for the Nary HardForkBlock
-------------------------------------------------------------------------------}

-- | Warning: 'projectLedgerTables' and 'withLedgerTables' are prohibitively
-- expensive when using big tables or when used multiple times. See the 'TxOut'
-- instance for the 'HardForkBlock' for more information.
instance
  ( CanHardFork xs
  , HasCanonicalTxIn xs
  , HasHardForkTxOut xs
  ) =>
  HasLedgerTables (LedgerState (HardForkBlock xs))
  where
  projectLedgerTables ::
    forall mk.
    (CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
    LedgerState (HardForkBlock xs) mk ->
    LedgerTables (LedgerState (HardForkBlock xs)) mk
  projectLedgerTables :: forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState (HardForkBlock xs) mk
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
projectLedgerTables (HardForkLedgerState HardForkState (Flip LedgerState mk) xs
st) =
    HardForkState
  (K (LedgerTables (LedgerState (HardForkBlock xs)) mk)) xs
-> CollapseTo
     HardForkState (LedgerTables (LedgerState (HardForkBlock xs)) mk)
forall (xs :: [*]) a.
SListIN HardForkState xs =>
HardForkState (K a) xs -> CollapseTo HardForkState a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (HardForkState
   (K (LedgerTables (LedgerState (HardForkBlock xs)) mk)) xs
 -> CollapseTo
      HardForkState (LedgerTables (LedgerState (HardForkBlock xs)) mk))
-> HardForkState
     (K (LedgerTables (LedgerState (HardForkBlock xs)) mk)) xs
-> CollapseTo
     HardForkState (LedgerTables (LedgerState (HardForkBlock xs)) mk)
forall a b. (a -> b) -> a -> b
$
      Proxy (Compose HasLedgerTables LedgerState)
-> (forall a.
    Compose HasLedgerTables LedgerState a =>
    Index xs a
    -> Flip LedgerState mk a
    -> K (LedgerTables (LedgerState (HardForkBlock xs)) mk) a)
-> HardForkState (Flip LedgerState mk) xs
-> HardForkState
     (K (LedgerTables (LedgerState (HardForkBlock xs)) mk)) xs
forall {k} (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint)
       (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *)
       (f2 :: k -> *).
(HAp h, All c xs, Prod h ~ NP) =>
proxy c
-> (forall (a :: k). c a => Index xs a -> f1 a -> f2 a)
-> h f1 xs
-> h f2 xs
hcimap (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @(Compose HasLedgerTables LedgerState)) Index xs a
-> Flip LedgerState mk a
-> K (LedgerTables (LedgerState (HardForkBlock xs)) mk) a
forall a.
Compose HasLedgerTables LedgerState a =>
Index xs a
-> Flip LedgerState mk a
-> K (LedgerTables (LedgerState (HardForkBlock xs)) mk) a
projectOne HardForkState (Flip LedgerState mk) xs
st
   where
    projectOne ::
      Compose HasLedgerTables LedgerState x =>
      Index xs x ->
      Flip LedgerState mk x ->
      K (LedgerTables (LedgerState (HardForkBlock xs)) mk) x
    projectOne :: forall a.
Compose HasLedgerTables LedgerState a =>
Index xs a
-> Flip LedgerState mk a
-> K (LedgerTables (LedgerState (HardForkBlock xs)) mk) a
projectOne Index xs x
i Flip LedgerState mk x
l =
      LedgerTables (LedgerState (HardForkBlock xs)) mk
-> K (LedgerTables (LedgerState (HardForkBlock xs)) mk) x
forall k a (b :: k). a -> K a b
K (LedgerTables (LedgerState (HardForkBlock xs)) mk
 -> K (LedgerTables (LedgerState (HardForkBlock xs)) mk) x)
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
-> K (LedgerTables (LedgerState (HardForkBlock xs)) mk) x
forall a b. (a -> b) -> a -> b
$
        Index xs x
-> LedgerTables (LedgerState x) mk
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
forall (xs :: [*]) x (mk :: MapKind).
(CanMapKeysMK mk, CanMapMK mk, HasCanonicalTxIn xs,
 HasHardForkTxOut xs) =>
Index xs x
-> LedgerTables (LedgerState x) mk
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
injectLedgerTables Index xs x
i (LedgerTables (LedgerState x) mk
 -> LedgerTables (LedgerState (HardForkBlock xs)) mk)
-> LedgerTables (LedgerState x) mk
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
forall a b. (a -> b) -> a -> b
$
          LedgerState x mk -> LedgerTables (LedgerState x) mk
forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState x mk -> LedgerTables (LedgerState x) mk
forall (l :: LedgerStateKind) (mk :: MapKind).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l mk -> LedgerTables l mk
projectLedgerTables (LedgerState x mk -> LedgerTables (LedgerState x) mk)
-> LedgerState x mk -> LedgerTables (LedgerState x) mk
forall a b. (a -> b) -> a -> b
$
            Flip LedgerState mk x -> LedgerState x mk
forall x1 y1 (f :: x1 -> y1 -> *) (x2 :: y1) (y2 :: x1).
Flip f x2 y2 -> f y2 x2
unFlip Flip LedgerState mk x
l

  withLedgerTables ::
    forall mk any.
    (CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
    LedgerState (HardForkBlock xs) any ->
    LedgerTables (LedgerState (HardForkBlock xs)) mk ->
    LedgerState (HardForkBlock xs) mk
  withLedgerTables :: forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState (HardForkBlock xs) any
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
-> LedgerState (HardForkBlock xs) mk
withLedgerTables (HardForkLedgerState HardForkState (Flip LedgerState any) xs
st) LedgerTables (LedgerState (HardForkBlock xs)) mk
tables =
    HardForkState (Flip LedgerState mk) xs
-> LedgerState (HardForkBlock xs) mk
forall (xs :: [*]) (mk :: MapKind).
HardForkState (Flip LedgerState mk) xs
-> LedgerState (HardForkBlock xs) mk
HardForkLedgerState (HardForkState (Flip LedgerState mk) xs
 -> LedgerState (HardForkBlock xs) mk)
-> HardForkState (Flip LedgerState mk) xs
-> LedgerState (HardForkBlock xs) mk
forall a b. (a -> b) -> a -> b
$
      Proxy (Compose HasLedgerTables LedgerState)
-> (forall a.
    Compose HasLedgerTables LedgerState a =>
    Index xs a -> Flip LedgerState any a -> Flip LedgerState mk a)
-> HardForkState (Flip LedgerState any) xs
-> HardForkState (Flip LedgerState mk) xs
forall {k} (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint)
       (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *)
       (f2 :: k -> *).
(HAp h, All c xs, Prod h ~ NP) =>
proxy c
-> (forall (a :: k). c a => Index xs a -> f1 a -> f2 a)
-> h f1 xs
-> h f2 xs
hcimap (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @(Compose HasLedgerTables LedgerState)) Index xs a -> Flip LedgerState any a -> Flip LedgerState mk a
forall a.
Compose HasLedgerTables LedgerState a =>
Index xs a -> Flip LedgerState any a -> Flip LedgerState mk a
withLedgerTablesOne HardForkState (Flip LedgerState any) xs
st
   where
    withLedgerTablesOne ::
      Compose HasLedgerTables LedgerState x =>
      Index xs x ->
      Flip LedgerState any x ->
      Flip LedgerState mk x
    withLedgerTablesOne :: forall a.
Compose HasLedgerTables LedgerState a =>
Index xs a -> Flip LedgerState any a -> Flip LedgerState mk a
withLedgerTablesOne Index xs x
i Flip LedgerState any x
l =
      LedgerState x mk -> Flip LedgerState mk x
forall x y (f :: x -> y -> *) (x1 :: y) (y1 :: x).
f y1 x1 -> Flip f x1 y1
Flip (LedgerState x mk -> Flip LedgerState mk x)
-> LedgerState x mk -> Flip LedgerState mk x
forall a b. (a -> b) -> a -> b
$
        LedgerState x any
-> LedgerTables (LedgerState x) mk -> LedgerState x mk
forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
LedgerState x any
-> LedgerTables (LedgerState x) mk -> LedgerState x mk
forall (l :: LedgerStateKind) (mk :: MapKind) (any :: MapKind).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
withLedgerTables (Flip LedgerState any x -> LedgerState x any
forall x1 y1 (f :: x1 -> y1 -> *) (x2 :: y1) (y2 :: x1).
Flip f x2 y2 -> f y2 x2
unFlip Flip LedgerState any x
l) (LedgerTables (LedgerState x) mk -> LedgerState x mk)
-> LedgerTables (LedgerState x) mk -> LedgerState x mk
forall a b. (a -> b) -> a -> b
$
          Index xs x
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
-> LedgerTables (LedgerState x) mk
forall (xs :: [*]) x (mk :: MapKind).
(CanMapKeysMK mk, Ord (TxIn (LedgerState x)), HasCanonicalTxIn xs,
 CanMapMK mk, HasHardForkTxOut xs) =>
Index xs x
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
-> LedgerTables (LedgerState x) mk
ejectLedgerTables Index xs x
i LedgerTables (LedgerState (HardForkBlock xs)) mk
tables

instance
  ( CanHardFork xs
  , HasCanonicalTxIn xs
  , HasHardForkTxOut xs
  ) =>
  HasLedgerTables (Ticked (LedgerState (HardForkBlock xs)))
  where
  projectLedgerTables ::
    forall mk.
    (CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
    Ticked (LedgerState (HardForkBlock xs)) mk ->
    LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk
  projectLedgerTables :: forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
Ticked (LedgerState (HardForkBlock xs)) mk
-> LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk
projectLedgerTables Ticked (LedgerState (HardForkBlock xs)) mk
st =
    HardForkState
  (K (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk)) xs
-> CollapseTo
     HardForkState
     (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk)
forall (xs :: [*]) a.
SListIN HardForkState xs =>
HardForkState (K a) xs -> CollapseTo HardForkState a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (HardForkState
   (K (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk)) xs
 -> CollapseTo
      HardForkState
      (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk))
-> HardForkState
     (K (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk)) xs
-> CollapseTo
     HardForkState
     (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk)
forall a b. (a -> b) -> a -> b
$
      Proxy (Compose HasTickedLedgerTables LedgerState)
-> (forall a.
    Compose HasTickedLedgerTables LedgerState a =>
    Index xs a
    -> FlipTickedLedgerState mk a
    -> K (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk) a)
-> HardForkState (FlipTickedLedgerState mk) xs
-> HardForkState
     (K (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk)) xs
forall {k} (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint)
       (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *)
       (f2 :: k -> *).
(HAp h, All c xs, Prod h ~ NP) =>
proxy c
-> (forall (a :: k). c a => Index xs a -> f1 a -> f2 a)
-> h f1 xs
-> h f2 xs
hcimap
        (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @(Compose HasTickedLedgerTables LedgerState))
        Index xs a
-> FlipTickedLedgerState mk a
-> K (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk) a
forall a.
Compose HasTickedLedgerTables LedgerState a =>
Index xs a
-> FlipTickedLedgerState mk a
-> K (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk) a
projectOne
        (Ticked (LedgerState (HardForkBlock xs)) mk
-> HardForkState (FlipTickedLedgerState mk) xs
forall (xs :: [*]) (mk :: MapKind).
Ticked (LedgerState (HardForkBlock xs)) mk
-> HardForkState (FlipTickedLedgerState mk) xs
tickedHardForkLedgerStatePerEra Ticked (LedgerState (HardForkBlock xs)) mk
st)
   where
    projectOne ::
      Compose HasTickedLedgerTables LedgerState x =>
      Index xs x ->
      FlipTickedLedgerState mk x ->
      K (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk) x
    projectOne :: forall a.
Compose HasTickedLedgerTables LedgerState a =>
Index xs a
-> FlipTickedLedgerState mk a
-> K (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk) a
projectOne Index xs x
i FlipTickedLedgerState mk x
l =
      LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk
-> K (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk) x
forall k a (b :: k). a -> K a b
K (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk
 -> K (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk) x)
-> LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk
-> K (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk) x
forall a b. (a -> b) -> a -> b
$
        LedgerTables (LedgerState (HardForkBlock xs)) mk
-> LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: MapKind).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables (LedgerTables (LedgerState (HardForkBlock xs)) mk
 -> LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk)
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
-> LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk
forall a b. (a -> b) -> a -> b
$
          Index xs x
-> LedgerTables (LedgerState x) mk
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
forall (xs :: [*]) x (mk :: MapKind).
(CanMapKeysMK mk, CanMapMK mk, HasCanonicalTxIn xs,
 HasHardForkTxOut xs) =>
Index xs x
-> LedgerTables (LedgerState x) mk
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
injectLedgerTables Index xs x
i (LedgerTables (LedgerState x) mk
 -> LedgerTables (LedgerState (HardForkBlock xs)) mk)
-> LedgerTables (LedgerState x) mk
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
forall a b. (a -> b) -> a -> b
$
            LedgerTables (Ticked (LedgerState x)) mk
-> LedgerTables (LedgerState x) mk
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: MapKind).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables (LedgerTables (Ticked (LedgerState x)) mk
 -> LedgerTables (LedgerState x) mk)
-> LedgerTables (Ticked (LedgerState x)) mk
-> LedgerTables (LedgerState x) mk
forall a b. (a -> b) -> a -> b
$
              Ticked (LedgerState x) mk
-> LedgerTables (Ticked (LedgerState x)) mk
forall (mk :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
Ticked (LedgerState x) mk
-> LedgerTables (Ticked (LedgerState x)) mk
forall (l :: LedgerStateKind) (mk :: MapKind).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l mk -> LedgerTables l mk
projectLedgerTables (Ticked (LedgerState x) mk
 -> LedgerTables (Ticked (LedgerState x)) mk)
-> Ticked (LedgerState x) mk
-> LedgerTables (Ticked (LedgerState x)) mk
forall a b. (a -> b) -> a -> b
$
                FlipTickedLedgerState mk x -> Ticked (LedgerState x) mk
forall (mk :: MapKind) blk.
FlipTickedLedgerState mk blk -> Ticked (LedgerState blk) mk
getFlipTickedLedgerState FlipTickedLedgerState mk x
l

  withLedgerTables ::
    forall mk any.
    (CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
    Ticked (LedgerState (HardForkBlock xs)) any ->
    LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk ->
    Ticked (LedgerState (HardForkBlock xs)) mk
  withLedgerTables :: forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
Ticked (LedgerState (HardForkBlock xs)) any
-> LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk
-> Ticked (LedgerState (HardForkBlock xs)) mk
withLedgerTables Ticked (LedgerState (HardForkBlock xs)) any
st LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk
tables =
    Ticked (LedgerState (HardForkBlock xs)) any
st
      { tickedHardForkLedgerStatePerEra =
          hcimap
            (Proxy @(Compose HasTickedLedgerTables LedgerState))
            withLedgerTablesOne
            (tickedHardForkLedgerStatePerEra st)
      }
   where
    withLedgerTablesOne ::
      Compose HasTickedLedgerTables LedgerState x =>
      Index xs x ->
      FlipTickedLedgerState any x ->
      FlipTickedLedgerState mk x
    withLedgerTablesOne :: forall a.
Compose HasTickedLedgerTables LedgerState a =>
Index xs a
-> FlipTickedLedgerState any a -> FlipTickedLedgerState mk a
withLedgerTablesOne Index xs x
i FlipTickedLedgerState any x
l =
      Ticked (LedgerState x) mk -> FlipTickedLedgerState mk x
forall (mk :: MapKind) blk.
Ticked (LedgerState blk) mk -> FlipTickedLedgerState mk blk
FlipTickedLedgerState (Ticked (LedgerState x) mk -> FlipTickedLedgerState mk x)
-> Ticked (LedgerState x) mk -> FlipTickedLedgerState mk x
forall a b. (a -> b) -> a -> b
$
        Ticked (LedgerState x) any
-> LedgerTables (Ticked (LedgerState x)) mk
-> Ticked (LedgerState x) mk
forall (mk :: MapKind) (any :: MapKind).
(CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
Ticked (LedgerState x) any
-> LedgerTables (Ticked (LedgerState x)) mk
-> Ticked (LedgerState x) mk
forall (l :: LedgerStateKind) (mk :: MapKind) (any :: MapKind).
(HasLedgerTables l, CanMapMK mk, CanMapKeysMK mk, ZeroableMK mk) =>
l any -> LedgerTables l mk -> l mk
withLedgerTables (FlipTickedLedgerState any x -> Ticked (LedgerState x) any
forall (mk :: MapKind) blk.
FlipTickedLedgerState mk blk -> Ticked (LedgerState blk) mk
getFlipTickedLedgerState FlipTickedLedgerState any x
l) (LedgerTables (Ticked (LedgerState x)) mk
 -> Ticked (LedgerState x) mk)
-> LedgerTables (Ticked (LedgerState x)) mk
-> Ticked (LedgerState x) mk
forall a b. (a -> b) -> a -> b
$
          LedgerTables (LedgerState x) mk
-> LedgerTables (Ticked (LedgerState x)) mk
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: MapKind).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables (LedgerTables (LedgerState x) mk
 -> LedgerTables (Ticked (LedgerState x)) mk)
-> LedgerTables (LedgerState x) mk
-> LedgerTables (Ticked (LedgerState x)) mk
forall a b. (a -> b) -> a -> b
$
            Index xs x
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
-> LedgerTables (LedgerState x) mk
forall (xs :: [*]) x (mk :: MapKind).
(CanMapKeysMK mk, Ord (TxIn (LedgerState x)), HasCanonicalTxIn xs,
 CanMapMK mk, HasHardForkTxOut xs) =>
Index xs x
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
-> LedgerTables (LedgerState x) mk
ejectLedgerTables Index xs x
i (LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
forall (l :: LedgerStateKind) (l' :: LedgerStateKind)
       (mk :: MapKind).
SameUtxoTypes l l' =>
LedgerTables l mk -> LedgerTables l' mk
castLedgerTables LedgerTables (Ticked (LedgerState (HardForkBlock xs))) mk
tables)

instance
  All (Compose CanStowLedgerTables LedgerState) xs =>
  CanStowLedgerTables (LedgerState (HardForkBlock xs))
  where
  stowLedgerTables ::
    LedgerState (HardForkBlock xs) ValuesMK ->
    LedgerState (HardForkBlock xs) EmptyMK
  stowLedgerTables :: LedgerState (HardForkBlock xs) ValuesMK
-> LedgerState (HardForkBlock xs) EmptyMK
stowLedgerTables (HardForkLedgerState HardForkState (Flip LedgerState ValuesMK) xs
st) =
    HardForkState (Flip LedgerState EmptyMK) xs
-> LedgerState (HardForkBlock xs) EmptyMK
forall (xs :: [*]) (mk :: MapKind).
HardForkState (Flip LedgerState mk) xs
-> LedgerState (HardForkBlock xs) mk
HardForkLedgerState (HardForkState (Flip LedgerState EmptyMK) xs
 -> LedgerState (HardForkBlock xs) EmptyMK)
-> HardForkState (Flip LedgerState EmptyMK) xs
-> LedgerState (HardForkBlock xs) EmptyMK
forall a b. (a -> b) -> a -> b
$
      Proxy (Compose CanStowLedgerTables LedgerState)
-> (forall a.
    Compose CanStowLedgerTables LedgerState a =>
    Flip LedgerState ValuesMK a -> Flip LedgerState EmptyMK a)
-> HardForkState (Flip LedgerState ValuesMK) xs
-> HardForkState (Flip LedgerState EmptyMK) 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 (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @(Compose CanStowLedgerTables LedgerState)) Flip LedgerState ValuesMK a -> Flip LedgerState EmptyMK a
forall a.
Compose CanStowLedgerTables LedgerState a =>
Flip LedgerState ValuesMK a -> Flip LedgerState EmptyMK a
stowOne HardForkState (Flip LedgerState ValuesMK) xs
st
   where
    stowOne ::
      Compose CanStowLedgerTables LedgerState x =>
      Flip LedgerState ValuesMK x ->
      Flip LedgerState EmptyMK x
    stowOne :: forall a.
Compose CanStowLedgerTables LedgerState a =>
Flip LedgerState ValuesMK a -> Flip LedgerState EmptyMK a
stowOne = LedgerState x EmptyMK -> Flip LedgerState EmptyMK x
forall x y (f :: x -> y -> *) (x1 :: y) (y1 :: x).
f y1 x1 -> Flip f x1 y1
Flip (LedgerState x EmptyMK -> Flip LedgerState EmptyMK x)
-> (Flip LedgerState ValuesMK x -> LedgerState x EmptyMK)
-> Flip LedgerState ValuesMK x
-> Flip LedgerState EmptyMK x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState x ValuesMK -> LedgerState x EmptyMK
forall (l :: LedgerStateKind).
CanStowLedgerTables l =>
l ValuesMK -> l EmptyMK
stowLedgerTables (LedgerState x ValuesMK -> LedgerState x EmptyMK)
-> (Flip LedgerState ValuesMK x -> LedgerState x ValuesMK)
-> Flip LedgerState ValuesMK x
-> LedgerState x EmptyMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flip LedgerState ValuesMK x -> LedgerState x ValuesMK
forall x1 y1 (f :: x1 -> y1 -> *) (x2 :: y1) (y2 :: x1).
Flip f x2 y2 -> f y2 x2
unFlip

  unstowLedgerTables ::
    LedgerState (HardForkBlock xs) EmptyMK ->
    LedgerState (HardForkBlock xs) ValuesMK
  unstowLedgerTables :: LedgerState (HardForkBlock xs) EmptyMK
-> LedgerState (HardForkBlock xs) ValuesMK
unstowLedgerTables (HardForkLedgerState HardForkState (Flip LedgerState EmptyMK) xs
st) =
    HardForkState (Flip LedgerState ValuesMK) xs
-> LedgerState (HardForkBlock xs) ValuesMK
forall (xs :: [*]) (mk :: MapKind).
HardForkState (Flip LedgerState mk) xs
-> LedgerState (HardForkBlock xs) mk
HardForkLedgerState (HardForkState (Flip LedgerState ValuesMK) xs
 -> LedgerState (HardForkBlock xs) ValuesMK)
-> HardForkState (Flip LedgerState ValuesMK) xs
-> LedgerState (HardForkBlock xs) ValuesMK
forall a b. (a -> b) -> a -> b
$
      Proxy (Compose CanStowLedgerTables LedgerState)
-> (forall a.
    Compose CanStowLedgerTables LedgerState a =>
    Flip LedgerState EmptyMK a -> Flip LedgerState ValuesMK a)
-> HardForkState (Flip LedgerState EmptyMK) xs
-> HardForkState (Flip LedgerState ValuesMK) 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 (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @(Compose CanStowLedgerTables LedgerState)) Flip LedgerState EmptyMK a -> Flip LedgerState ValuesMK a
forall a.
Compose CanStowLedgerTables LedgerState a =>
Flip LedgerState EmptyMK a -> Flip LedgerState ValuesMK a
unstowOne HardForkState (Flip LedgerState EmptyMK) xs
st
   where
    unstowOne ::
      Compose CanStowLedgerTables LedgerState x =>
      Flip LedgerState EmptyMK x ->
      Flip LedgerState ValuesMK x
    unstowOne :: forall a.
Compose CanStowLedgerTables LedgerState a =>
Flip LedgerState EmptyMK a -> Flip LedgerState ValuesMK a
unstowOne = LedgerState x ValuesMK -> Flip LedgerState ValuesMK x
forall x y (f :: x -> y -> *) (x1 :: y) (y1 :: x).
f y1 x1 -> Flip f x1 y1
Flip (LedgerState x ValuesMK -> Flip LedgerState ValuesMK x)
-> (Flip LedgerState EmptyMK x -> LedgerState x ValuesMK)
-> Flip LedgerState EmptyMK x
-> Flip LedgerState ValuesMK x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState x EmptyMK -> LedgerState x ValuesMK
forall (l :: LedgerStateKind).
CanStowLedgerTables l =>
l EmptyMK -> l ValuesMK
unstowLedgerTables (LedgerState x EmptyMK -> LedgerState x ValuesMK)
-> (Flip LedgerState EmptyMK x -> LedgerState x EmptyMK)
-> Flip LedgerState EmptyMK x
-> LedgerState x ValuesMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flip LedgerState EmptyMK x -> LedgerState x EmptyMK
forall x1 y1 (f :: x1 -> y1 -> *) (x2 :: y1) (y2 :: x1).
Flip f x2 y2 -> f y2 x2
unFlip

injectLedgerTables ::
  forall xs x mk.
  ( CanMapKeysMK mk
  , CanMapMK mk
  , HasCanonicalTxIn xs
  , HasHardForkTxOut xs
  ) =>
  Index xs x ->
  LedgerTables (LedgerState x) mk ->
  LedgerTables (LedgerState (HardForkBlock xs)) mk
injectLedgerTables :: forall (xs :: [*]) x (mk :: MapKind).
(CanMapKeysMK mk, CanMapMK mk, HasCanonicalTxIn xs,
 HasHardForkTxOut xs) =>
Index xs x
-> LedgerTables (LedgerState x) mk
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
injectLedgerTables Index xs x
idx =
  (TxIn (LedgerState x) -> TxIn (LedgerState (HardForkBlock xs)))
-> (TxOut (LedgerState x)
    -> TxOut (LedgerState (HardForkBlock xs)))
-> LedgerTables (LedgerState x) mk
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
forall (x :: LedgerStateKind) (y :: LedgerStateKind)
       (mk :: MapKind).
(CanMapKeysMK mk, CanMapMK mk, Ord (TxIn y)) =>
(TxIn x -> TxIn y)
-> (TxOut x -> TxOut y) -> LedgerTables x mk -> LedgerTables y mk
bimapLedgerTables (Index xs x -> TxIn (LedgerState x) -> CanonicalTxIn xs
forall (xs :: [*]) x.
HasCanonicalTxIn xs =>
Index xs x -> TxIn (LedgerState x) -> CanonicalTxIn xs
forall x. Index xs x -> TxIn (LedgerState x) -> CanonicalTxIn xs
injectCanonicalTxIn Index xs x
idx) (Index xs x -> TxOut (LedgerState x) -> HardForkTxOut xs
forall (xs :: [*]) x.
HasHardForkTxOut xs =>
Index xs x -> TxOut (LedgerState x) -> HardForkTxOut xs
forall x. Index xs x -> TxOut (LedgerState x) -> HardForkTxOut xs
injectHardForkTxOut Index xs x
idx)

ejectLedgerTables ::
  forall xs x mk.
  ( CanMapKeysMK mk
  , Ord (TxIn (LedgerState x))
  , HasCanonicalTxIn xs
  , CanMapMK mk
  , HasHardForkTxOut xs
  ) =>
  Index xs x ->
  LedgerTables (LedgerState (HardForkBlock xs)) mk ->
  LedgerTables (LedgerState x) mk
ejectLedgerTables :: forall (xs :: [*]) x (mk :: MapKind).
(CanMapKeysMK mk, Ord (TxIn (LedgerState x)), HasCanonicalTxIn xs,
 CanMapMK mk, HasHardForkTxOut xs) =>
Index xs x
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
-> LedgerTables (LedgerState x) mk
ejectLedgerTables Index xs x
idx =
  (TxIn (LedgerState (HardForkBlock xs)) -> TxIn (LedgerState x))
-> (TxOut (LedgerState (HardForkBlock xs))
    -> TxOut (LedgerState x))
-> LedgerTables (LedgerState (HardForkBlock xs)) mk
-> LedgerTables (LedgerState x) mk
forall (x :: LedgerStateKind) (y :: LedgerStateKind)
       (mk :: MapKind).
(CanMapKeysMK mk, CanMapMK mk, Ord (TxIn y)) =>
(TxIn x -> TxIn y)
-> (TxOut x -> TxOut y) -> LedgerTables x mk -> LedgerTables y mk
bimapLedgerTables (Index xs x -> CanonicalTxIn xs -> TxIn (LedgerState x)
forall (xs :: [*]) x.
HasCanonicalTxIn xs =>
Index xs x -> CanonicalTxIn xs -> TxIn (LedgerState x)
forall x. Index xs x -> CanonicalTxIn xs -> TxIn (LedgerState x)
ejectCanonicalTxIn Index xs x
idx) (Index xs x -> HardForkTxOut xs -> TxOut (LedgerState x)
forall (xs :: [*]) x.
HasHardForkTxOut xs =>
Index xs x -> HardForkTxOut xs -> TxOut (LedgerState x)
forall x. Index xs x -> HardForkTxOut xs -> TxOut (LedgerState x)
ejectHardForkTxOut Index xs x
idx)

{-------------------------------------------------------------------------------
  HardForkTxIn
-------------------------------------------------------------------------------}

-- | Must be the 'CannonicalTxIn' type, but this will probably change in the
-- future to @NS 'WrapTxIn' xs@. See 'HasCanonicalTxIn'.
type instance TxIn (LedgerState (HardForkBlock xs)) = CanonicalTxIn xs

-- | Canonical TxIn
--
-- The Ledger and Consensus team discussed the fact that we need to be able to
-- reach the TxIn key for an entry from any era, regardless of the era in which
-- it was created, therefore we need to have a "canonical" serialization that
-- doesn't change between eras. For now we are requiring that a 'HardForkBlock'
-- has only one associated 'TxIn' type as a stop-gap, but Ledger will provide a
-- serialization function into something more efficient.
type HasCanonicalTxIn :: [Type] -> Constraint
class
  ( Show (CanonicalTxIn xs)
  , Ord (CanonicalTxIn xs)
  , NoThunks (CanonicalTxIn xs)
  , MemPack (CanonicalTxIn xs)
  ) =>
  HasCanonicalTxIn xs
  where
  data CanonicalTxIn (xs :: [Type]) :: Type

  -- | Inject an era-specific 'TxIn' into a 'TxIn' for a 'HardForkBlock'.
  injectCanonicalTxIn ::
    Index xs x ->
    TxIn (LedgerState x) ->
    CanonicalTxIn xs

  -- | Distribute a 'TxIn' for a 'HardForkBlock' to an era-specific 'TxIn'.
  ejectCanonicalTxIn ::
    Index xs x ->
    CanonicalTxIn xs ->
    TxIn (LedgerState x)

{-------------------------------------------------------------------------------
  HardForkTxOut
-------------------------------------------------------------------------------}

-- | Must be the 'HardForkTxOut' type
type instance TxOut (LedgerState (HardForkBlock xs)) = HardForkTxOut xs

-- | This choice for 'HardForkTxOut' imposes some complications on the code.
--
-- We deliberately chose not to have all values in the tables be
-- @'Cardano.Ledger.Core.TxOut' era@ because this would require us to traverse
-- and translate the whole UTxO set on era boundaries. To avoid this, we are
-- holding a @'NS' 'WrapTxOut' xs@ instead.
--
-- Whenever we are carrying a @'LedgerState' ('HardForkBlock' xs) mk@ (or
-- 'Ouroboros.Consensus.Ledger.Extended.ExtLedgerState'), the tables are the
-- ones inside the particular ledger state in the 'Telescope' of the
-- 'HardForkState'.
--
-- <<docs/haddocks/hard-fork-tables-per-block.svg>>
--
-- However, when we are carrying @'LedgerTables' ('HardForkBlock' xs) mk@ we are
-- instead carrying these tables, where the 'TxOut' is an 'NS'. This means that
-- whenever we are extracting these tables, we are effectively duplicating the
-- UTxO set ('Data.Map.Map') inside, to create an identical one where every
-- element has been translated to the most recent era and unwrapped from the
-- 'NS'.
--
-- <<docs/haddocks/hard-fork-tables.svg>>
--
-- To prevent memory explosion, try to only perform one of this transformations,
-- for example:
--
-- * when applying blocks, inject the tables for the transactions only once, and
--     extract them only once.
--
-- * when performing queries on the tables (that use
--     'Ouroboros.Consensus.Ledger.Query.QFTraverseTables'), operate with the
--     tables at the hard fork level until the very end, when you have to
--     promote them to some specific era.
--
-- = __(image code)__
--
-- >>> :{
-- >>> either (error . show) pure =<<
-- >>>  renderToFile "docs/haddocks/hard-fork-tables.svg" defaultEnv (tikz ["positioning", "arrows"]) "\\node at (4.5,4.8) {\\small{LedgerTables (LedgerState (HardForkBlock xs))}};\
-- >>> \ \\draw (0,0) rectangle (9,5);\
-- >>> \ \\node (rect) at (1.5,4) [draw,minimum width=1cm,minimum height=0.5cm] {TxIn};\
-- >>> \ \\node (oneOf) at (3.5,4) [draw=none] {NS};\
-- >>> \ \\draw (rect) -> (oneOf);\
-- >>> \ \\node (sh) at (6.5,4) [draw,minimum width=1cm,minimum height=0.5cm] {BlockATxOut};\
-- >>> \ \\node (al) at (6.5,3) [draw,minimum width=1cm,minimum height=0.5cm] {BlockBTxOut};\
-- >>> \ \\node (my) at (6.5,2) [draw=none,minimum width=1cm,minimum height=0.5cm] {...};\
-- >>> \ \\node (ba) at (6.5,1) [draw,minimum width=1cm,minimum height=0.5cm] {BlockNTxOut};\
-- >>> \ \\draw (oneOf) -> (sh);\
-- >>> \ \\draw (oneOf) -> (al);\
-- >>> \ \\draw (oneOf) -> (ba);\
-- >>> \ \\draw (3,0.5) rectangle (8,4.5);"
-- >>> :}
--
-- >>> :{
-- >>> either (error . show) pure =<<
-- >>>  renderToFile "docs/haddocks/hard-fork-tables-per-block.svg" defaultEnv (tikz ["positioning", "arrows"]) "\\node at (5,4.8) {\\small{LedgerState (HardForkBlock xs)}};\
-- >>> \ \\draw (0,0) rectangle (10,5);\
-- >>> \ \\node (oneOf2) at (2,4) [draw=none] {HardForkState};\
-- >>> \ \\node (bb) at (5,4) [draw,minimum width=1cm,minimum height=0.5cm] {BlockAState};\
-- >>> \ \\node (bt) at (8,4) [draw,minimum width=1cm,minimum height=0.5cm] {BlockATables};\
-- >>> \ \\node (sb) at (5,3) [draw,minimum width=1cm,minimum height=0.5cm] {BlockBState};\
-- >>> \ \\node (st) at (8,3) [draw,minimum width=1cm,minimum height=0.5cm] {BlockBTables};\
-- >>> \ \\node (db) at (5,2) [draw=none,minimum width=1cm,minimum height=0.5cm] {...};\
-- >>> \ \\node (dt) at (8,2) [draw=none,minimum width=1cm,minimum height=0.5cm] {...};\
-- >>> \ \\node (bab) at (5,1) [draw,minimum width=1cm,minimum height=0.5cm] {BlockNState};\
-- >>> \ \\node (bat) at (8,1) [draw,minimum width=1cm,minimum height=0.5cm] {BlockNTables};\
-- >>> \ \\draw (oneOf2) -> (bb);\
-- >>> \ \\draw (bb) -> (bt);\
-- >>> \ \\draw (oneOf2) -> (sb);\
-- >>> \ \\draw (sb) -> (st);\
-- >>> \ \\draw (oneOf2) -> (bab);\
-- >>> \ \\draw (bab) -> (bat);"
-- >>> :}
type DefaultHardForkTxOut xs = NS WrapTxOut xs

class
  ( Show (HardForkTxOut xs)
  , Eq (HardForkTxOut xs)
  , NoThunks (HardForkTxOut xs)
  , IndexedMemPack (LedgerState (HardForkBlock xs) EmptyMK) (HardForkTxOut xs)
  , SerializeTablesWithHint (LedgerState (HardForkBlock xs))
  ) =>
  HasHardForkTxOut xs
  where
  type HardForkTxOut xs :: Type
  type HardForkTxOut xs = DefaultHardForkTxOut xs

  injectHardForkTxOut :: Index xs x -> TxOut (LedgerState x) -> HardForkTxOut xs
  ejectHardForkTxOut :: Index xs x -> HardForkTxOut xs -> TxOut (LedgerState x)

  -- | This method is a null-arity method in a typeclass to make it a CAF, such
  -- that we only compute it once, then it is cached for the duration of the
  -- program, as we will use it very often when converting from the
  -- HardForkBlock to the particular @blk@.
  --
  -- This particular method is useful when our HardForkBlock uses
  -- DefaultHardForkTxOut, so that we can implement inject and project.
  txOutEjections :: NP (K (NS WrapTxOut xs) -.-> WrapTxOut) xs
  default txOutEjections :: CanHardFork xs => NP (K (NS WrapTxOut xs) -.-> WrapTxOut) xs
  txOutEjections = InPairs TranslateTxOut xs
-> NP (K (NS WrapTxOut xs) -.-> WrapTxOut) xs
forall (xs :: [*]).
SListI xs =>
InPairs TranslateTxOut xs
-> NP (K (NS WrapTxOut xs) -.-> WrapTxOut) xs
composeTxOutTranslations (InPairs TranslateTxOut xs
 -> NP (K (NS WrapTxOut xs) -.-> WrapTxOut) xs)
-> InPairs TranslateTxOut xs
-> NP (K (NS WrapTxOut xs) -.-> WrapTxOut) xs
forall a b. (a -> b) -> a -> b
$ EraTranslation xs -> InPairs TranslateTxOut xs
forall (xs :: [*]).
All Top xs =>
EraTranslation xs -> InPairs TranslateTxOut xs
ipTranslateTxOut EraTranslation xs
forall (xs :: [*]). CanHardFork xs => EraTranslation xs
hardForkEraTranslation

  -- | This method is a null-arity method in a typeclass to make it a CAF, such
  -- that we only compute it once, then it is cached for the duration of the
  -- program, as we will use it very often when converting from the
  -- HardForkBlock to the particular @blk@.
  txOutTranslations :: Tails (InPairs.Fn2 WrapTxOut) xs
  default txOutTranslations :: CanHardFork xs => Tails (InPairs.Fn2 WrapTxOut) xs
  txOutTranslations =
    InPairs (Fn2 WrapTxOut) xs -> Tails (Fn2 WrapTxOut) xs
forall {k} (f :: k -> *) (xs :: [k]).
All Top xs =>
InPairs (Fn2 f) xs -> Tails (Fn2 f) xs
Tails.inPairsToTails (InPairs (Fn2 WrapTxOut) xs -> Tails (Fn2 WrapTxOut) xs)
-> InPairs (Fn2 WrapTxOut) xs -> Tails (Fn2 WrapTxOut) xs
forall a b. (a -> b) -> a -> b
$
      (forall x y. TranslateLedgerTables x y -> Fn2 WrapTxOut x y)
-> InPairs TranslateLedgerTables xs -> InPairs (Fn2 WrapTxOut) xs
forall {k} (xs :: [k]) (f :: k -> k -> *) (g :: k -> k -> *).
SListI xs =>
(forall (x :: k) (y :: k). f x y -> g x y)
-> InPairs f xs -> InPairs g xs
InPairs.hmap
        (\TranslateLedgerTables x y
translator -> (WrapTxOut x -> WrapTxOut y) -> Fn2 WrapTxOut x y
forall {k} (f :: k -> *) (x :: k) (y :: k).
(f x -> f y) -> Fn2 f x y
InPairs.Fn2 ((WrapTxOut x -> WrapTxOut y) -> Fn2 WrapTxOut x y)
-> (WrapTxOut x -> WrapTxOut y) -> Fn2 WrapTxOut x y
forall a b. (a -> b) -> a -> b
$ TxOut (LedgerState y) -> WrapTxOut y
forall blk. TxOut (LedgerState blk) -> WrapTxOut blk
WrapTxOut (TxOut (LedgerState y) -> WrapTxOut y)
-> (WrapTxOut x -> TxOut (LedgerState y))
-> WrapTxOut x
-> WrapTxOut y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranslateLedgerTables x y
-> TxOut (LedgerState x) -> TxOut (LedgerState y)
forall x y.
TranslateLedgerTables x y
-> TxOut (LedgerState x) -> TxOut (LedgerState y)
translateTxOutWith TranslateLedgerTables x y
translator (TxOut (LedgerState x) -> TxOut (LedgerState y))
-> (WrapTxOut x -> TxOut (LedgerState x))
-> WrapTxOut x
-> TxOut (LedgerState y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTxOut x -> TxOut (LedgerState x)
forall blk. WrapTxOut blk -> TxOut (LedgerState blk)
unwrapTxOut)
        (EraTranslation xs -> InPairs TranslateLedgerTables xs
forall (xs :: [*]).
EraTranslation xs -> InPairs TranslateLedgerTables xs
translateLedgerTables (forall (xs :: [*]). CanHardFork xs => EraTranslation xs
hardForkEraTranslation @xs))

instance
  (CanHardFork xs, HasHardForkTxOut xs) =>
  CanUpgradeLedgerTables (LedgerState (HardForkBlock xs))
  where
  upgradeTables :: forall (mk1 :: MapKind) (mk2 :: MapKind).
LedgerState (HardForkBlock xs) mk1
-> LedgerState (HardForkBlock xs) mk2
-> LedgerTables (LedgerState (HardForkBlock xs)) ValuesMK
-> LedgerTables (LedgerState (HardForkBlock xs)) ValuesMK
upgradeTables
    (HardForkLedgerState (HardForkState Telescope (K Past) (Current (Flip LedgerState mk1)) xs
hs0))
    (HardForkLedgerState (HardForkState Telescope (K Past) (Current (Flip LedgerState mk2)) xs
hs1))
    orig :: LedgerTables (LedgerState (HardForkBlock xs)) ValuesMK
orig@(LedgerTables (ValuesMK Map
  (TxIn (LedgerState (HardForkBlock xs)))
  (TxOut (LedgerState (HardForkBlock xs)))
vs)) =
      if Maybe
  (Mismatch
     (Current (Flip LedgerState mk1))
     (Current (Flip LedgerState mk2))
     xs)
-> Bool
forall a. Maybe a -> Bool
isJust (Maybe
   (Mismatch
      (Current (Flip LedgerState mk1))
      (Current (Flip LedgerState mk2))
      xs)
 -> Bool)
-> Maybe
     (Mismatch
        (Current (Flip LedgerState mk1))
        (Current (Flip LedgerState mk2))
        xs)
-> Bool
forall a b. (a -> b) -> a -> b
$ Telescope (K Past) (Current (Flip LedgerState mk1)) xs
-> Telescope (K Past) (Current (Flip LedgerState mk2)) xs
-> Maybe
     (Mismatch
        (Current (Flip LedgerState mk1))
        (Current (Flip LedgerState mk2))
        xs)
forall {k} (a :: k -> *) (b :: k -> *) (xs :: [k]) (g :: k -> *)
       (f :: k -> *).
Telescope a b xs -> Telescope g f xs -> Maybe (Mismatch b f xs)
Match.telescopesMismatch Telescope (K Past) (Current (Flip LedgerState mk1)) xs
hs0 Telescope (K Past) (Current (Flip LedgerState mk2)) xs
hs1
        then ValuesMK
  (TxIn (LedgerState (HardForkBlock xs)))
  (TxOut (LedgerState (HardForkBlock xs)))
-> LedgerTables (LedgerState (HardForkBlock xs)) ValuesMK
forall (l :: LedgerStateKind) (mk :: MapKind).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables (ValuesMK
   (TxIn (LedgerState (HardForkBlock xs)))
   (TxOut (LedgerState (HardForkBlock xs)))
 -> LedgerTables (LedgerState (HardForkBlock xs)) ValuesMK)
-> ValuesMK
     (TxIn (LedgerState (HardForkBlock xs)))
     (TxOut (LedgerState (HardForkBlock xs)))
-> LedgerTables (LedgerState (HardForkBlock xs)) ValuesMK
forall a b. (a -> b) -> a -> b
$ Map
  (TxIn (LedgerState (HardForkBlock xs)))
  (TxOut (LedgerState (HardForkBlock xs)))
-> ValuesMK
     (TxIn (LedgerState (HardForkBlock xs)))
     (TxOut (LedgerState (HardForkBlock xs)))
forall k v. Map k v -> ValuesMK k v
ValuesMK (Map
   (TxIn (LedgerState (HardForkBlock xs)))
   (TxOut (LedgerState (HardForkBlock xs)))
 -> ValuesMK
      (TxIn (LedgerState (HardForkBlock xs)))
      (TxOut (LedgerState (HardForkBlock xs))))
-> Map
     (TxIn (LedgerState (HardForkBlock xs)))
     (TxOut (LedgerState (HardForkBlock xs)))
-> ValuesMK
     (TxIn (LedgerState (HardForkBlock xs)))
     (TxOut (LedgerState (HardForkBlock xs)))
forall a b. (a -> b) -> a -> b
$ NS (K ()) xs
-> Map
     (TxIn (LedgerState (HardForkBlock xs)))
     (TxOut (LedgerState (HardForkBlock xs)))
-> Map
     (TxIn (LedgerState (HardForkBlock xs)))
     (TxOut (LedgerState (HardForkBlock xs)))
forall (xs :: [*]).
(CanHardFork xs, HasHardForkTxOut xs) =>
NS (K ()) xs
-> Map
     (TxIn (LedgerState (HardForkBlock xs)))
     (TxOut (LedgerState (HardForkBlock xs)))
-> Map
     (TxIn (LedgerState (HardForkBlock xs)))
     (TxOut (LedgerState (HardForkBlock xs)))
extendTables ((forall a. Current (Flip LedgerState mk2) a -> K () a)
-> NS (Current (Flip LedgerState mk2)) xs -> NS (K ()) 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 (K () a -> Current (Flip LedgerState mk2) a -> K () a
forall a b. a -> b -> a
const (() -> K () a
forall k a (b :: k). a -> K a b
K ())) NS (Current (Flip LedgerState mk2)) xs
t1) Map
  (TxIn (LedgerState (HardForkBlock xs)))
  (TxOut (LedgerState (HardForkBlock xs)))
vs
        else LedgerTables (LedgerState (HardForkBlock xs)) ValuesMK
orig
     where
      t1 :: NS (Current (Flip LedgerState mk2)) xs
t1 = Telescope (K Past) (Current (Flip LedgerState mk2)) xs
-> NS (Current (Flip LedgerState mk2)) xs
forall {k} (g :: k -> *) (f :: k -> *) (xs :: [k]).
Telescope g f xs -> NS f xs
Telescope.tip Telescope (K Past) (Current (Flip LedgerState mk2)) xs
hs1

extendTables ::
  forall xs.
  (CanHardFork xs, HasHardForkTxOut xs) =>
  NS (K ()) xs ->
  Map.Map
    (TxIn (LedgerState (HardForkBlock xs)))
    (TxOut (LedgerState (HardForkBlock xs))) ->
  Map.Map
    (TxIn (LedgerState (HardForkBlock xs)))
    (TxOut (LedgerState (HardForkBlock xs)))
extendTables :: forall (xs :: [*]).
(CanHardFork xs, HasHardForkTxOut xs) =>
NS (K ()) xs
-> Map
     (TxIn (LedgerState (HardForkBlock xs)))
     (TxOut (LedgerState (HardForkBlock xs)))
-> Map
     (TxIn (LedgerState (HardForkBlock xs)))
     (TxOut (LedgerState (HardForkBlock xs)))
extendTables NS (K ()) xs
st =
  (HardForkTxOut xs -> HardForkTxOut xs)
-> Map (CanonicalTxIn xs) (HardForkTxOut xs)
-> Map (CanonicalTxIn xs) (HardForkTxOut xs)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map
    ( \HardForkTxOut xs
txout ->
        NS (K (HardForkTxOut xs)) xs -> CollapseTo NS (HardForkTxOut xs)
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (NS (K (HardForkTxOut xs)) xs -> CollapseTo NS (HardForkTxOut xs))
-> NS (K (HardForkTxOut xs)) xs -> CollapseTo NS (HardForkTxOut xs)
forall a b. (a -> b) -> a -> b
$
          Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    Index xs a -> K () a -> K (HardForkTxOut xs) a)
-> NS (K ()) xs
-> NS (K (HardForkTxOut xs)) xs
forall {k} (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint)
       (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *)
       (f2 :: k -> *).
(HAp h, All c xs, Prod h ~ NP) =>
proxy c
-> (forall (a :: k). c a => Index xs a -> f1 a -> f2 a)
-> h f1 xs
-> h f2 xs
hcimap
            Proxy SingleEraBlock
proxySingle
            ( \Index xs a
idxTarget (K ()) ->
                HardForkTxOut xs -> K (HardForkTxOut xs) a
forall k a (b :: k). a -> K a b
K
                  (HardForkTxOut xs -> K (HardForkTxOut xs) a)
-> (HardForkTxOut xs -> HardForkTxOut xs)
-> HardForkTxOut xs
-> K (HardForkTxOut xs) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index xs a -> TxOut (LedgerState a) -> HardForkTxOut xs
forall (xs :: [*]) x.
HasHardForkTxOut xs =>
Index xs x -> TxOut (LedgerState x) -> HardForkTxOut xs
forall x. Index xs x -> TxOut (LedgerState x) -> HardForkTxOut xs
injectHardForkTxOut Index xs a
idxTarget
                  (TxOut (LedgerState a) -> HardForkTxOut xs)
-> (HardForkTxOut xs -> TxOut (LedgerState a))
-> HardForkTxOut xs
-> HardForkTxOut xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index xs a -> HardForkTxOut xs -> TxOut (LedgerState a)
forall (xs :: [*]) x.
HasHardForkTxOut xs =>
Index xs x -> HardForkTxOut xs -> TxOut (LedgerState x)
forall x. Index xs x -> HardForkTxOut xs -> TxOut (LedgerState x)
ejectHardForkTxOut Index xs a
idxTarget
                  (HardForkTxOut xs -> K (HardForkTxOut xs) a)
-> HardForkTxOut xs -> K (HardForkTxOut xs) a
forall a b. (a -> b) -> a -> b
$ HardForkTxOut xs
txout
            )
            NS (K ()) xs
st
    )

injectHardForkTxOutDefault ::
  SListI xs =>
  Index xs x ->
  TxOut (LedgerState x) ->
  DefaultHardForkTxOut xs
injectHardForkTxOutDefault :: forall (xs :: [*]) x.
SListI xs =>
Index xs x -> TxOut (LedgerState x) -> DefaultHardForkTxOut xs
injectHardForkTxOutDefault Index xs x
idx = Index xs x -> WrapTxOut x -> DefaultHardForkTxOut xs
forall {k} (f :: k -> *) (x :: k) (xs :: [k]).
All Top xs =>
Index xs x -> f x -> NS f xs
injectNS Index xs x
idx (WrapTxOut x -> DefaultHardForkTxOut xs)
-> (TxOut (LedgerState x) -> WrapTxOut x)
-> TxOut (LedgerState x)
-> DefaultHardForkTxOut xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut (LedgerState x) -> WrapTxOut x
forall blk. TxOut (LedgerState blk) -> WrapTxOut blk
WrapTxOut

ejectHardForkTxOutDefault ::
  SListI xs =>
  HasHardForkTxOut xs =>
  Index xs x ->
  DefaultHardForkTxOut xs ->
  TxOut (LedgerState x)
ejectHardForkTxOutDefault :: forall (xs :: [*]) x.
(SListI xs, HasHardForkTxOut xs) =>
Index xs x -> DefaultHardForkTxOut xs -> TxOut (LedgerState x)
ejectHardForkTxOutDefault Index xs x
idx =
  WrapTxOut x -> TxOut (LedgerState x)
forall blk. WrapTxOut blk -> TxOut (LedgerState blk)
unwrapTxOut
    (WrapTxOut x -> TxOut (LedgerState x))
-> (DefaultHardForkTxOut xs -> WrapTxOut x)
-> DefaultHardForkTxOut xs
-> TxOut (LedgerState x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (-.->) (K (DefaultHardForkTxOut xs)) WrapTxOut x
-> K (DefaultHardForkTxOut xs) x -> WrapTxOut x
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
(-.->) f g a -> f a -> g a
apFn (Index xs x
-> NP (K (DefaultHardForkTxOut xs) -.-> WrapTxOut) xs
-> (-.->) (K (DefaultHardForkTxOut xs)) WrapTxOut x
forall {k} (xs :: [k]) (x :: k) (f :: k -> *).
All Top xs =>
Index xs x -> NP f xs -> f x
projectNP Index xs x
idx NP (K (DefaultHardForkTxOut xs) -.-> WrapTxOut) xs
forall (xs :: [*]).
HasHardForkTxOut xs =>
NP (K (NS WrapTxOut xs) -.-> WrapTxOut) xs
txOutEjections)
    (K (DefaultHardForkTxOut xs) x -> WrapTxOut x)
-> (DefaultHardForkTxOut xs -> K (DefaultHardForkTxOut xs) x)
-> DefaultHardForkTxOut xs
-> WrapTxOut x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DefaultHardForkTxOut xs -> K (DefaultHardForkTxOut xs) x
forall k a (b :: k). a -> K a b
K

composeTxOutTranslations ::
  SListI xs =>
  InPairs TranslateTxOut xs ->
  NP (K (NS WrapTxOut xs) -.-> WrapTxOut) xs
composeTxOutTranslations :: forall (xs :: [*]).
SListI xs =>
InPairs TranslateTxOut xs
-> NP (K (NS WrapTxOut xs) -.-> WrapTxOut) xs
composeTxOutTranslations = \case
  InPairs TranslateTxOut xs
PNil ->
    (K (NS WrapTxOut xs) x -> WrapTxOut x)
-> (-.->) (K (NS WrapTxOut xs)) WrapTxOut x
forall {k} (f :: k -> *) (a :: k) (f' :: k -> *).
(f a -> f' a) -> (-.->) f f' a
fn (NS WrapTxOut '[x] -> WrapTxOut x
forall {k} (f :: k -> *) (x :: k). NS f '[x] -> f x
unZ (NS WrapTxOut '[x] -> WrapTxOut x)
-> (K (NS WrapTxOut xs) x -> NS WrapTxOut '[x])
-> K (NS WrapTxOut xs) x
-> WrapTxOut x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K (NS WrapTxOut xs) x -> NS WrapTxOut xs
K (NS WrapTxOut xs) x -> NS WrapTxOut '[x]
forall {k} a (b :: k). K a b -> a
unK) (-.->) (K (NS WrapTxOut xs)) WrapTxOut x
-> NP (K (NS WrapTxOut xs) -.-> WrapTxOut) '[]
-> NP (K (NS WrapTxOut xs) -.-> WrapTxOut) '[x]
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* NP (K (NS WrapTxOut xs) -.-> WrapTxOut) '[]
forall {k} (f :: k -> *). NP f '[]
Nil
  PCons (TranslateTxOut TxOut (LedgerState x) -> TxOut (LedgerState y)
t) InPairs TranslateTxOut (y : zs)
ts ->
    (K (NS WrapTxOut xs) x -> WrapTxOut x)
-> (-.->) (K (NS WrapTxOut xs)) WrapTxOut x
forall {k} (f :: k -> *) (a :: k) (f' :: k -> *).
(f a -> f' a) -> (-.->) f f' a
fn
      ( (WrapTxOut x -> WrapTxOut x)
-> (NS WrapTxOut (y : zs) -> WrapTxOut x)
-> NS WrapTxOut (x : y : zs)
-> WrapTxOut x
forall (f :: * -> *) x c (xs :: [*]).
(f x -> c) -> (NS f xs -> c) -> NS f (x : xs) -> c
eitherNS
          WrapTxOut x -> WrapTxOut x
forall a. a -> a
id
          (String -> NS WrapTxOut (y : zs) -> WrapTxOut x
forall a. HasCallStack => String -> a
error String
"composeTranslations: anachrony")
          (NS WrapTxOut (x : y : zs) -> WrapTxOut x)
-> (K (NS WrapTxOut xs) x -> NS WrapTxOut (x : y : zs))
-> K (NS WrapTxOut xs) x
-> WrapTxOut x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K (NS WrapTxOut xs) x -> NS WrapTxOut xs
K (NS WrapTxOut xs) x -> NS WrapTxOut (x : y : zs)
forall {k} a (b :: k). K a b -> a
unK
      )
      (-.->) (K (NS WrapTxOut xs)) WrapTxOut x
-> NP (K (NS WrapTxOut xs) -.-> WrapTxOut) (y : zs)
-> NP (K (NS WrapTxOut xs) -.-> WrapTxOut) (x : y : zs)
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NP f xs1 -> NP f (x : xs1)
:* (forall a.
 (-.->) (K (NS WrapTxOut (y : zs))) WrapTxOut a
 -> (-.->) (K (NS WrapTxOut xs)) WrapTxOut a)
-> NP (K (NS WrapTxOut (y : zs)) -.-> WrapTxOut) (y : zs)
-> NP (K (NS WrapTxOut xs) -.-> WrapTxOut) (y : zs)
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
        ( \(-.->) (K (NS WrapTxOut (y : zs))) WrapTxOut a
innerf ->
            (K (NS WrapTxOut xs) a -> WrapTxOut a)
-> (-.->) (K (NS WrapTxOut xs)) WrapTxOut a
forall {k} (f :: k -> *) (a :: k) (f' :: k -> *).
(f a -> f' a) -> (-.->) f f' a
fn ((K (NS WrapTxOut xs) a -> WrapTxOut a)
 -> (-.->) (K (NS WrapTxOut xs)) WrapTxOut a)
-> (K (NS WrapTxOut xs) a -> WrapTxOut a)
-> (-.->) (K (NS WrapTxOut xs)) WrapTxOut a
forall a b. (a -> b) -> a -> b
$
              (-.->) (K (NS WrapTxOut (y : zs))) WrapTxOut a
-> K (NS WrapTxOut (y : zs)) a -> WrapTxOut a
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
(-.->) f g a -> f a -> g a
apFn (-.->) (K (NS WrapTxOut (y : zs))) WrapTxOut a
innerf
                (K (NS WrapTxOut (y : zs)) a -> WrapTxOut a)
-> (K (NS WrapTxOut xs) a -> K (NS WrapTxOut (y : zs)) a)
-> K (NS WrapTxOut xs) a
-> WrapTxOut a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS WrapTxOut (y : zs) -> K (NS WrapTxOut (y : zs)) a
forall k a (b :: k). a -> K a b
K
                (NS WrapTxOut (y : zs) -> K (NS WrapTxOut (y : zs)) a)
-> (K (NS WrapTxOut xs) a -> NS WrapTxOut (y : zs))
-> K (NS WrapTxOut xs) a
-> K (NS WrapTxOut (y : zs)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (WrapTxOut x -> NS WrapTxOut (y : zs))
-> (NS WrapTxOut (y : zs) -> NS WrapTxOut (y : zs))
-> NS WrapTxOut (x : y : zs)
-> NS WrapTxOut (y : zs)
forall (f :: * -> *) x c (xs :: [*]).
(f x -> c) -> (NS f xs -> c) -> NS f (x : xs) -> c
eitherNS
                  (WrapTxOut y -> NS WrapTxOut (y : zs)
forall {k} (f :: k -> *) (x :: k) (xs1 :: [k]).
f x -> NS f (x : xs1)
Z (WrapTxOut y -> NS WrapTxOut (y : zs))
-> (WrapTxOut x -> WrapTxOut y)
-> WrapTxOut x
-> NS WrapTxOut (y : zs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut (LedgerState y) -> WrapTxOut y
forall blk. TxOut (LedgerState blk) -> WrapTxOut blk
WrapTxOut (TxOut (LedgerState y) -> WrapTxOut y)
-> (WrapTxOut x -> TxOut (LedgerState y))
-> WrapTxOut x
-> WrapTxOut y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut (LedgerState x) -> TxOut (LedgerState y)
t (TxOut (LedgerState x) -> TxOut (LedgerState y))
-> (WrapTxOut x -> TxOut (LedgerState x))
-> WrapTxOut x
-> TxOut (LedgerState y)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTxOut x -> TxOut (LedgerState x)
forall blk. WrapTxOut blk -> TxOut (LedgerState blk)
unwrapTxOut)
                  NS WrapTxOut (y : zs) -> NS WrapTxOut (y : zs)
forall a. a -> a
id
                (NS WrapTxOut (x : y : zs) -> NS WrapTxOut (y : zs))
-> (K (NS WrapTxOut xs) a -> NS WrapTxOut (x : y : zs))
-> K (NS WrapTxOut xs) a
-> NS WrapTxOut (y : zs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. K (NS WrapTxOut xs) a -> NS WrapTxOut xs
K (NS WrapTxOut xs) a -> NS WrapTxOut (x : y : zs)
forall {k} a (b :: k). K a b -> a
unK
        )
        (InPairs TranslateTxOut (y : zs)
-> NP (K (NS WrapTxOut (y : zs)) -.-> WrapTxOut) (y : zs)
forall (xs :: [*]).
SListI xs =>
InPairs TranslateTxOut xs
-> NP (K (NS WrapTxOut xs) -.-> WrapTxOut) xs
composeTxOutTranslations InPairs TranslateTxOut (y : zs)
ts)
 where
  eitherNS :: (f x -> c) -> (NS f xs -> c) -> NS f (x ': xs) -> c
  eitherNS :: forall (f :: * -> *) x c (xs :: [*]).
(f x -> c) -> (NS f xs -> c) -> NS f (x : xs) -> c
eitherNS f x -> c
l NS f xs -> c
r = \case
    Z f x
x -> f x -> c
l f x
f x
x
    S NS f xs1
x -> NS f xs -> c
r NS f xs
NS f xs1
x

class MemPack (TxOut (LedgerState x)) => MemPackTxOut x
instance MemPack (TxOut (LedgerState x)) => MemPackTxOut x

instance
  (All MemPackTxOut xs, Typeable xs) =>
  MemPack (DefaultHardForkTxOut xs)
  where
  packM :: forall s. DefaultHardForkTxOut xs -> Pack s ()
packM =
    NS (K (Pack s ())) xs -> Pack s ()
NS (K (Pack s ())) xs -> CollapseTo NS (Pack s ())
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse
      (NS (K (Pack s ())) xs -> Pack s ())
-> (DefaultHardForkTxOut xs -> NS (K (Pack s ())) xs)
-> DefaultHardForkTxOut xs
-> Pack s ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy MemPackTxOut
-> (forall a.
    MemPackTxOut a =>
    Index xs a -> WrapTxOut a -> K (Pack s ()) a)
-> DefaultHardForkTxOut xs
-> NS (K (Pack s ())) xs
forall {k} (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint)
       (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *)
       (f2 :: k -> *).
(HAp h, All c xs, Prod h ~ NP) =>
proxy c
-> (forall (a :: k). c a => Index xs a -> f1 a -> f2 a)
-> h f1 xs
-> h f2 xs
hcimap
        (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @MemPackTxOut)
        ( \Index xs a
idx (WrapTxOut TxOut (LedgerState a)
txout) -> Pack s () -> K (Pack s ()) a
forall k a (b :: k). a -> K a b
K (Pack s () -> K (Pack s ()) a) -> Pack s () -> K (Pack s ()) a
forall a b. (a -> b) -> a -> b
$ do
            Word8 -> Pack s ()
forall s. Word8 -> Pack s ()
forall a s. MemPack a => a -> Pack s ()
packM (Index xs a -> Word8
forall {k} (xs :: [k]) (x :: k). Index xs x -> Word8
toWord8 Index xs a
idx)
            TxOut (LedgerState a) -> Pack s ()
forall a s. MemPack a => a -> Pack s ()
forall s. TxOut (LedgerState a) -> Pack s ()
packM TxOut (LedgerState a)
txout
        )

  packedByteCount :: DefaultHardForkTxOut xs -> Int
packedByteCount DefaultHardForkTxOut xs
txout =
    Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ NS (K Int) xs -> CollapseTo NS Int
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse (Proxy MemPackTxOut
-> (forall a. MemPackTxOut a => WrapTxOut a -> K Int a)
-> DefaultHardForkTxOut xs
-> NS (K Int) 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 (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @MemPackTxOut) (Int -> K Int a
forall k a (b :: k). a -> K a b
K (Int -> K Int a) -> (WrapTxOut a -> Int) -> WrapTxOut a -> K Int a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxOut (LedgerState a) -> Int
forall a. MemPack a => a -> Int
packedByteCount (TxOut (LedgerState a) -> Int)
-> (WrapTxOut a -> TxOut (LedgerState a)) -> WrapTxOut a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapTxOut a -> TxOut (LedgerState a)
forall blk. WrapTxOut blk -> TxOut (LedgerState blk)
unwrapTxOut) DefaultHardForkTxOut xs
txout)

  unpackM :: forall b. Buffer b => Unpack b (DefaultHardForkTxOut xs)
unpackM = do
    idx <- Unpack b Word8
forall b. Buffer b => Unpack b Word8
forall a b. (MemPack a, Buffer b) => Unpack b a
unpackM
    hsequence'
      $ hcmap
        (Proxy @MemPackTxOut)
        (const $ Comp $ WrapTxOut <$> unpackM)
      $ fromMaybe (error "Unknown tag") (nsFromIndex idx)