{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.HardFork.Combinator.Mempool
  ( GenTx (..)
  , HardForkApplyTxErr (..)
  , TxId (..)
  , Validated (..)
  , hardForkApplyTxErrFromEither
  , hardForkApplyTxErrToEither
  ) where

import Control.Arrow (first, (+++))
import Control.Monad.Except
import Data.Functor.Identity
import Data.Functor.Product
import Data.Kind (Type)
import qualified Data.Measure as Measure
import Data.SOP.BasicFunctors
import Data.SOP.Constraint
import Data.SOP.Functors
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 qualified Data.SOP.Telescope as Tele
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.HardFork.Combinator.Abstract
import Ouroboros.Consensus.HardFork.Combinator.AcrossEras
import Ouroboros.Consensus.HardFork.Combinator.Basics
import Ouroboros.Consensus.HardFork.Combinator.Info
import Ouroboros.Consensus.HardFork.Combinator.InjectTxs
import Ouroboros.Consensus.HardFork.Combinator.Ledger
import Ouroboros.Consensus.HardFork.Combinator.PartialConfig
import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.TypeFamilyWrappers
import Ouroboros.Consensus.Util

data HardForkApplyTxErr xs
  = -- | Validation error from one of the eras
    HardForkApplyTxErrFromEra !(OneEraApplyTxErr xs)
  | -- | We tried to apply a block from the wrong era
    HardForkApplyTxErrWrongEra !(MismatchEraInfo xs)
  deriving (forall x. HardForkApplyTxErr xs -> Rep (HardForkApplyTxErr xs) x)
-> (forall x.
    Rep (HardForkApplyTxErr xs) x -> HardForkApplyTxErr xs)
-> Generic (HardForkApplyTxErr xs)
forall (xs :: [*]) x.
Rep (HardForkApplyTxErr xs) x -> HardForkApplyTxErr xs
forall (xs :: [*]) x.
HardForkApplyTxErr xs -> Rep (HardForkApplyTxErr xs) x
forall x. Rep (HardForkApplyTxErr xs) x -> HardForkApplyTxErr xs
forall x. HardForkApplyTxErr xs -> Rep (HardForkApplyTxErr xs) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (xs :: [*]) x.
HardForkApplyTxErr xs -> Rep (HardForkApplyTxErr xs) x
from :: forall x. HardForkApplyTxErr xs -> Rep (HardForkApplyTxErr xs) x
$cto :: forall (xs :: [*]) x.
Rep (HardForkApplyTxErr xs) x -> HardForkApplyTxErr xs
to :: forall x. Rep (HardForkApplyTxErr xs) x -> HardForkApplyTxErr xs
Generic

instance Typeable xs => ShowProxy (HardForkApplyTxErr xs)

hardForkApplyTxErrToEither ::
  HardForkApplyTxErr xs ->
  Either (MismatchEraInfo xs) (OneEraApplyTxErr xs)
hardForkApplyTxErrToEither :: forall (xs :: [*]).
HardForkApplyTxErr xs
-> Either (MismatchEraInfo xs) (OneEraApplyTxErr xs)
hardForkApplyTxErrToEither (HardForkApplyTxErrFromEra OneEraApplyTxErr xs
err) = OneEraApplyTxErr xs
-> Either (MismatchEraInfo xs) (OneEraApplyTxErr xs)
forall a b. b -> Either a b
Right OneEraApplyTxErr xs
err
hardForkApplyTxErrToEither (HardForkApplyTxErrWrongEra MismatchEraInfo xs
err) = MismatchEraInfo xs
-> Either (MismatchEraInfo xs) (OneEraApplyTxErr xs)
forall a b. a -> Either a b
Left MismatchEraInfo xs
err

hardForkApplyTxErrFromEither ::
  Either (MismatchEraInfo xs) (OneEraApplyTxErr xs) ->
  HardForkApplyTxErr xs
hardForkApplyTxErrFromEither :: forall (xs :: [*]).
Either (MismatchEraInfo xs) (OneEraApplyTxErr xs)
-> HardForkApplyTxErr xs
hardForkApplyTxErrFromEither (Right OneEraApplyTxErr xs
err) = OneEraApplyTxErr xs -> HardForkApplyTxErr xs
forall (xs :: [*]). OneEraApplyTxErr xs -> HardForkApplyTxErr xs
HardForkApplyTxErrFromEra OneEraApplyTxErr xs
err
hardForkApplyTxErrFromEither (Left MismatchEraInfo xs
err) = MismatchEraInfo xs -> HardForkApplyTxErr xs
forall (xs :: [*]). MismatchEraInfo xs -> HardForkApplyTxErr xs
HardForkApplyTxErrWrongEra MismatchEraInfo xs
err

deriving stock instance CanHardFork xs => Show (HardForkApplyTxErr xs)

deriving stock instance CanHardFork xs => Eq (HardForkApplyTxErr xs)

newtype instance GenTx (HardForkBlock xs) = HardForkGenTx
  { forall (xs :: [*]). GenTx (HardForkBlock xs) -> OneEraGenTx xs
getHardForkGenTx :: OneEraGenTx xs
  }
  deriving (GenTx (HardForkBlock xs) -> GenTx (HardForkBlock xs) -> Bool
(GenTx (HardForkBlock xs) -> GenTx (HardForkBlock xs) -> Bool)
-> (GenTx (HardForkBlock xs) -> GenTx (HardForkBlock xs) -> Bool)
-> Eq (GenTx (HardForkBlock xs))
forall (xs :: [*]).
CanHardFork xs =>
GenTx (HardForkBlock xs) -> GenTx (HardForkBlock xs) -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall (xs :: [*]).
CanHardFork xs =>
GenTx (HardForkBlock xs) -> GenTx (HardForkBlock xs) -> Bool
== :: GenTx (HardForkBlock xs) -> GenTx (HardForkBlock xs) -> Bool
$c/= :: forall (xs :: [*]).
CanHardFork xs =>
GenTx (HardForkBlock xs) -> GenTx (HardForkBlock xs) -> Bool
/= :: GenTx (HardForkBlock xs) -> GenTx (HardForkBlock xs) -> Bool
Eq, (forall x.
 GenTx (HardForkBlock xs) -> Rep (GenTx (HardForkBlock xs)) x)
-> (forall x.
    Rep (GenTx (HardForkBlock xs)) x -> GenTx (HardForkBlock xs))
-> Generic (GenTx (HardForkBlock xs))
forall (xs :: [*]) x.
Rep (GenTx (HardForkBlock xs)) x -> GenTx (HardForkBlock xs)
forall (xs :: [*]) x.
GenTx (HardForkBlock xs) -> Rep (GenTx (HardForkBlock xs)) x
forall x.
Rep (GenTx (HardForkBlock xs)) x -> GenTx (HardForkBlock xs)
forall x.
GenTx (HardForkBlock xs) -> Rep (GenTx (HardForkBlock xs)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (xs :: [*]) x.
GenTx (HardForkBlock xs) -> Rep (GenTx (HardForkBlock xs)) x
from :: forall x.
GenTx (HardForkBlock xs) -> Rep (GenTx (HardForkBlock xs)) x
$cto :: forall (xs :: [*]) x.
Rep (GenTx (HardForkBlock xs)) x -> GenTx (HardForkBlock xs)
to :: forall x.
Rep (GenTx (HardForkBlock xs)) x -> GenTx (HardForkBlock xs)
Generic, Int -> GenTx (HardForkBlock xs) -> ShowS
[GenTx (HardForkBlock xs)] -> ShowS
GenTx (HardForkBlock xs) -> String
(Int -> GenTx (HardForkBlock xs) -> ShowS)
-> (GenTx (HardForkBlock xs) -> String)
-> ([GenTx (HardForkBlock xs)] -> ShowS)
-> Show (GenTx (HardForkBlock xs))
forall (xs :: [*]).
CanHardFork xs =>
Int -> GenTx (HardForkBlock xs) -> ShowS
forall (xs :: [*]).
CanHardFork xs =>
[GenTx (HardForkBlock xs)] -> ShowS
forall (xs :: [*]).
CanHardFork xs =>
GenTx (HardForkBlock xs) -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (xs :: [*]).
CanHardFork xs =>
Int -> GenTx (HardForkBlock xs) -> ShowS
showsPrec :: Int -> GenTx (HardForkBlock xs) -> ShowS
$cshow :: forall (xs :: [*]).
CanHardFork xs =>
GenTx (HardForkBlock xs) -> String
show :: GenTx (HardForkBlock xs) -> String
$cshowList :: forall (xs :: [*]).
CanHardFork xs =>
[GenTx (HardForkBlock xs)] -> ShowS
showList :: [GenTx (HardForkBlock xs)] -> ShowS
Show)
  deriving anyclass Context -> GenTx (HardForkBlock xs) -> IO (Maybe ThunkInfo)
Proxy (GenTx (HardForkBlock xs)) -> String
(Context -> GenTx (HardForkBlock xs) -> IO (Maybe ThunkInfo))
-> (Context -> GenTx (HardForkBlock xs) -> IO (Maybe ThunkInfo))
-> (Proxy (GenTx (HardForkBlock xs)) -> String)
-> NoThunks (GenTx (HardForkBlock xs))
forall (xs :: [*]).
CanHardFork xs =>
Context -> GenTx (HardForkBlock xs) -> IO (Maybe ThunkInfo)
forall (xs :: [*]).
CanHardFork xs =>
Proxy (GenTx (HardForkBlock 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 -> GenTx (HardForkBlock xs) -> IO (Maybe ThunkInfo)
noThunks :: Context -> GenTx (HardForkBlock xs) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context -> GenTx (HardForkBlock xs) -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> GenTx (HardForkBlock xs) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (xs :: [*]).
CanHardFork xs =>
Proxy (GenTx (HardForkBlock xs)) -> String
showTypeOf :: Proxy (GenTx (HardForkBlock xs)) -> String
NoThunks

newtype instance Validated (GenTx (HardForkBlock xs)) = HardForkValidatedGenTx
  { forall (xs :: [*]).
Validated (GenTx (HardForkBlock xs)) -> OneEraValidatedGenTx xs
getHardForkValidatedGenTx :: OneEraValidatedGenTx xs
  }
  deriving (Validated (GenTx (HardForkBlock xs))
-> Validated (GenTx (HardForkBlock xs)) -> Bool
(Validated (GenTx (HardForkBlock xs))
 -> Validated (GenTx (HardForkBlock xs)) -> Bool)
-> (Validated (GenTx (HardForkBlock xs))
    -> Validated (GenTx (HardForkBlock xs)) -> Bool)
-> Eq (Validated (GenTx (HardForkBlock xs)))
forall (xs :: [*]).
CanHardFork xs =>
Validated (GenTx (HardForkBlock xs))
-> Validated (GenTx (HardForkBlock xs)) -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall (xs :: [*]).
CanHardFork xs =>
Validated (GenTx (HardForkBlock xs))
-> Validated (GenTx (HardForkBlock xs)) -> Bool
== :: Validated (GenTx (HardForkBlock xs))
-> Validated (GenTx (HardForkBlock xs)) -> Bool
$c/= :: forall (xs :: [*]).
CanHardFork xs =>
Validated (GenTx (HardForkBlock xs))
-> Validated (GenTx (HardForkBlock xs)) -> Bool
/= :: Validated (GenTx (HardForkBlock xs))
-> Validated (GenTx (HardForkBlock xs)) -> Bool
Eq, (forall x.
 Validated (GenTx (HardForkBlock xs))
 -> Rep (Validated (GenTx (HardForkBlock xs))) x)
-> (forall x.
    Rep (Validated (GenTx (HardForkBlock xs))) x
    -> Validated (GenTx (HardForkBlock xs)))
-> Generic (Validated (GenTx (HardForkBlock xs)))
forall (xs :: [*]) x.
Rep (Validated (GenTx (HardForkBlock xs))) x
-> Validated (GenTx (HardForkBlock xs))
forall (xs :: [*]) x.
Validated (GenTx (HardForkBlock xs))
-> Rep (Validated (GenTx (HardForkBlock xs))) x
forall x.
Rep (Validated (GenTx (HardForkBlock xs))) x
-> Validated (GenTx (HardForkBlock xs))
forall x.
Validated (GenTx (HardForkBlock xs))
-> Rep (Validated (GenTx (HardForkBlock xs))) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (xs :: [*]) x.
Validated (GenTx (HardForkBlock xs))
-> Rep (Validated (GenTx (HardForkBlock xs))) x
from :: forall x.
Validated (GenTx (HardForkBlock xs))
-> Rep (Validated (GenTx (HardForkBlock xs))) x
$cto :: forall (xs :: [*]) x.
Rep (Validated (GenTx (HardForkBlock xs))) x
-> Validated (GenTx (HardForkBlock xs))
to :: forall x.
Rep (Validated (GenTx (HardForkBlock xs))) x
-> Validated (GenTx (HardForkBlock xs))
Generic, Int -> Validated (GenTx (HardForkBlock xs)) -> ShowS
[Validated (GenTx (HardForkBlock xs))] -> ShowS
Validated (GenTx (HardForkBlock xs)) -> String
(Int -> Validated (GenTx (HardForkBlock xs)) -> ShowS)
-> (Validated (GenTx (HardForkBlock xs)) -> String)
-> ([Validated (GenTx (HardForkBlock xs))] -> ShowS)
-> Show (Validated (GenTx (HardForkBlock xs)))
forall (xs :: [*]).
CanHardFork xs =>
Int -> Validated (GenTx (HardForkBlock xs)) -> ShowS
forall (xs :: [*]).
CanHardFork xs =>
[Validated (GenTx (HardForkBlock xs))] -> ShowS
forall (xs :: [*]).
CanHardFork xs =>
Validated (GenTx (HardForkBlock xs)) -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (xs :: [*]).
CanHardFork xs =>
Int -> Validated (GenTx (HardForkBlock xs)) -> ShowS
showsPrec :: Int -> Validated (GenTx (HardForkBlock xs)) -> ShowS
$cshow :: forall (xs :: [*]).
CanHardFork xs =>
Validated (GenTx (HardForkBlock xs)) -> String
show :: Validated (GenTx (HardForkBlock xs)) -> String
$cshowList :: forall (xs :: [*]).
CanHardFork xs =>
[Validated (GenTx (HardForkBlock xs))] -> ShowS
showList :: [Validated (GenTx (HardForkBlock xs))] -> ShowS
Show)
  deriving anyclass Context
-> Validated (GenTx (HardForkBlock xs)) -> IO (Maybe ThunkInfo)
Proxy (Validated (GenTx (HardForkBlock xs))) -> String
(Context
 -> Validated (GenTx (HardForkBlock xs)) -> IO (Maybe ThunkInfo))
-> (Context
    -> Validated (GenTx (HardForkBlock xs)) -> IO (Maybe ThunkInfo))
-> (Proxy (Validated (GenTx (HardForkBlock xs))) -> String)
-> NoThunks (Validated (GenTx (HardForkBlock xs)))
forall (xs :: [*]).
CanHardFork xs =>
Context
-> Validated (GenTx (HardForkBlock xs)) -> IO (Maybe ThunkInfo)
forall (xs :: [*]).
CanHardFork xs =>
Proxy (Validated (GenTx (HardForkBlock 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
-> Validated (GenTx (HardForkBlock xs)) -> IO (Maybe ThunkInfo)
noThunks :: Context
-> Validated (GenTx (HardForkBlock xs)) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context
-> Validated (GenTx (HardForkBlock xs)) -> IO (Maybe ThunkInfo)
wNoThunks :: Context
-> Validated (GenTx (HardForkBlock xs)) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (xs :: [*]).
CanHardFork xs =>
Proxy (Validated (GenTx (HardForkBlock xs))) -> String
showTypeOf :: Proxy (Validated (GenTx (HardForkBlock xs))) -> String
NoThunks

instance Typeable xs => ShowProxy (GenTx (HardForkBlock xs))

type instance ApplyTxErr (HardForkBlock xs) = HardForkApplyTxErr xs

-- | Just to discharge cognitive load, this is equivalent to:
--
-- > ([invalidTxs, ...], [validTxs, ...], st)
--
-- Where @invalidTxs@ and @validTxs@ are hard-fork transactions, and only @st@
-- depends on a particular @blk@.
--
-- We do not define this as a new data type to reuse the @Applicative@ and
-- friends instances of these type constructors, which are useful to
-- @hsequence'@ a @HardForkState@ of this.
--
-- This is also isomorphic to
-- @'Ouroboros.Consensus.Ledger.SupportsMempool.ReapplyTxsResult' (HardForkBlock xs)@
type DecomposedReapplyTxsResult extra xs =
  (,,)
    [Invalidated (HardForkBlock xs)]
    [(Validated (GenTx (HardForkBlock xs)), extra)]
    :.: FlipTickedLedgerState TrackingMK

instance
  ( CanHardFork xs
  , HasCanonicalTxIn xs
  , HasHardForkTxOut xs
  ) =>
  LedgerSupportsMempool (HardForkBlock xs)
  where
  applyTx :: LedgerConfig (HardForkBlock xs)
-> WhetherToIntervene
-> SlotNo
-> GenTx (HardForkBlock xs)
-> TickedLedgerState (HardForkBlock xs) ValuesMK
-> Except
     (ApplyTxErr (HardForkBlock xs))
     (TickedLedgerState (HardForkBlock xs) DiffMK,
      Validated (GenTx (HardForkBlock xs)))
applyTx = ApplyHelperMode GenTx
-> ComputeDiffs
-> LedgerConfig (HardForkBlock xs)
-> WhetherToIntervene
-> SlotNo
-> GenTx (HardForkBlock xs)
-> TickedLedgerState (HardForkBlock xs) ValuesMK
-> Except
     (HardForkApplyTxErr xs)
     (TickedLedgerState
        (HardForkBlock xs) (ApplyMK (ApplyHelperMode GenTx)),
      Validated (GenTx (HardForkBlock xs)))
forall (xs :: [*]) (txIn :: * -> *).
CanHardFork xs =>
ApplyHelperMode txIn
-> ComputeDiffs
-> LedgerConfig (HardForkBlock xs)
-> WhetherToIntervene
-> SlotNo
-> txIn (HardForkBlock xs)
-> TickedLedgerState (HardForkBlock xs) ValuesMK
-> Except
     (HardForkApplyTxErr xs)
     (TickedLedgerState
        (HardForkBlock xs) (ApplyMK (ApplyHelperMode txIn)),
      Validated (GenTx (HardForkBlock xs)))
applyHelper ApplyHelperMode GenTx
ModeApply ComputeDiffs
ComputeDiffs

  reapplyTx :: HasCallStack =>
ComputeDiffs
-> LedgerConfig (HardForkBlock xs)
-> SlotNo
-> Validated (GenTx (HardForkBlock xs))
-> TickedLedgerState (HardForkBlock xs) ValuesMK
-> Except
     (ApplyTxErr (HardForkBlock xs))
     (TickedLedgerState (HardForkBlock xs) TrackingMK)
reapplyTx ComputeDiffs
doDiffs LedgerConfig (HardForkBlock xs)
cfg SlotNo
slot Validated (GenTx (HardForkBlock xs))
vtx TickedLedgerState (HardForkBlock xs) ValuesMK
tls =
    (TickedLedgerState (HardForkBlock xs) TrackingMK,
 Validated (GenTx (HardForkBlock xs)))
-> TickedLedgerState (HardForkBlock xs) TrackingMK
forall a b. (a, b) -> a
fst
      ((TickedLedgerState (HardForkBlock xs) TrackingMK,
  Validated (GenTx (HardForkBlock xs)))
 -> TickedLedgerState (HardForkBlock xs) TrackingMK)
-> ExceptT
     (HardForkApplyTxErr xs)
     Identity
     (TickedLedgerState (HardForkBlock xs) TrackingMK,
      Validated (GenTx (HardForkBlock xs)))
-> ExceptT
     (HardForkApplyTxErr xs)
     Identity
     (TickedLedgerState (HardForkBlock xs) TrackingMK)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ApplyHelperMode WrapValidatedGenTx
-> ComputeDiffs
-> LedgerConfig (HardForkBlock xs)
-> WhetherToIntervene
-> SlotNo
-> WrapValidatedGenTx (HardForkBlock xs)
-> TickedLedgerState (HardForkBlock xs) ValuesMK
-> Except
     (HardForkApplyTxErr xs)
     (TickedLedgerState
        (HardForkBlock xs) (ApplyMK (ApplyHelperMode WrapValidatedGenTx)),
      Validated (GenTx (HardForkBlock xs)))
forall (xs :: [*]) (txIn :: * -> *).
CanHardFork xs =>
ApplyHelperMode txIn
-> ComputeDiffs
-> LedgerConfig (HardForkBlock xs)
-> WhetherToIntervene
-> SlotNo
-> txIn (HardForkBlock xs)
-> TickedLedgerState (HardForkBlock xs) ValuesMK
-> Except
     (HardForkApplyTxErr xs)
     (TickedLedgerState
        (HardForkBlock xs) (ApplyMK (ApplyHelperMode txIn)),
      Validated (GenTx (HardForkBlock xs)))
applyHelper
        ApplyHelperMode WrapValidatedGenTx
ModeReapply
        ComputeDiffs
doDiffs
        LedgerConfig (HardForkBlock xs)
cfg
        WhetherToIntervene
DoNotIntervene
        SlotNo
slot
        (Validated (GenTx (HardForkBlock xs))
-> WrapValidatedGenTx (HardForkBlock xs)
forall blk. Validated (GenTx blk) -> WrapValidatedGenTx blk
WrapValidatedGenTx Validated (GenTx (HardForkBlock xs))
vtx)
        TickedLedgerState (HardForkBlock xs) ValuesMK
tls

  reapplyTxs ::
    forall extra.
    ComputeDiffs ->
    LedgerConfig (HardForkBlock xs) ->
    SlotNo ->
    -- \^ Slot number of the block containing the tx
    [(Validated (GenTx (HardForkBlock xs)), extra)] ->
    TickedLedgerState (HardForkBlock xs) ValuesMK ->
    ReapplyTxsResult extra (HardForkBlock xs)
  reapplyTxs :: forall extra.
ComputeDiffs
-> LedgerConfig (HardForkBlock xs)
-> SlotNo
-> [(Validated (GenTx (HardForkBlock xs)), extra)]
-> TickedLedgerState (HardForkBlock xs) ValuesMK
-> ReapplyTxsResult extra (HardForkBlock xs)
reapplyTxs
    ComputeDiffs
doDiffs
    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
    [(Validated (GenTx (HardForkBlock xs)), extra)]
vtxs
    (TickedHardForkLedgerState TransitionInfo
transition HardForkState (FlipTickedLedgerState ValuesMK) xs
hardForkState) =
      ( \([Invalidated (HardForkBlock xs)]
err, [(Validated (GenTx (HardForkBlock xs)), extra)]
val, HardForkState (FlipTickedLedgerState TrackingMK) xs
st') ->
          [Invalidated (HardForkBlock xs)]
-> [(Validated (GenTx (HardForkBlock xs)), extra)]
-> TickedLedgerState (HardForkBlock xs) TrackingMK
-> ReapplyTxsResult extra (HardForkBlock xs)
forall extra blk.
[Invalidated blk]
-> [(Validated (GenTx blk), extra)]
-> TickedLedgerState blk TrackingMK
-> ReapplyTxsResult extra blk
ReapplyTxsResult ([Invalidated (HardForkBlock xs)]
mismatched' [Invalidated (HardForkBlock xs)]
-> [Invalidated (HardForkBlock xs)]
-> [Invalidated (HardForkBlock xs)]
forall a. [a] -> [a] -> [a]
++ [Invalidated (HardForkBlock xs)]
err) [(Validated (GenTx (HardForkBlock xs)), extra)]
val (TransitionInfo
-> HardForkState (FlipTickedLedgerState TrackingMK) xs
-> TickedLedgerState (HardForkBlock xs) TrackingMK
forall (xs :: [*]) (mk :: MapKind).
TransitionInfo
-> HardForkState (FlipTickedLedgerState mk) xs
-> Ticked (LedgerState (HardForkBlock xs)) mk
TickedHardForkLedgerState TransitionInfo
transition HardForkState (FlipTickedLedgerState TrackingMK) xs
st')
      )
        (([Invalidated (HardForkBlock xs)],
  [(Validated (GenTx (HardForkBlock xs)), extra)],
  HardForkState (FlipTickedLedgerState TrackingMK) xs)
 -> ReapplyTxsResult extra (HardForkBlock xs))
-> (HardForkState
      ((,,)
         [Invalidated (HardForkBlock xs)]
         [(Validated (GenTx (HardForkBlock xs)), extra)]
       :.: FlipTickedLedgerState TrackingMK)
      xs
    -> ([Invalidated (HardForkBlock xs)],
        [(Validated (GenTx (HardForkBlock xs)), extra)],
        HardForkState (FlipTickedLedgerState TrackingMK) xs))
-> HardForkState
     ((,,)
        [Invalidated (HardForkBlock xs)]
        [(Validated (GenTx (HardForkBlock xs)), extra)]
      :.: FlipTickedLedgerState TrackingMK)
     xs
-> ReapplyTxsResult extra (HardForkBlock xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkState
  ((,,)
     [Invalidated (HardForkBlock xs)]
     [(Validated (GenTx (HardForkBlock xs)), extra)]
   :.: FlipTickedLedgerState TrackingMK)
  xs
-> ([Invalidated (HardForkBlock xs)],
    [(Validated (GenTx (HardForkBlock xs)), extra)],
    HardForkState (FlipTickedLedgerState TrackingMK) 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
   ((,,)
      [Invalidated (HardForkBlock xs)]
      [(Validated (GenTx (HardForkBlock xs)), extra)]
    :.: FlipTickedLedgerState TrackingMK)
   xs
 -> ReapplyTxsResult extra (HardForkBlock xs))
-> HardForkState
     ((,,)
        [Invalidated (HardForkBlock xs)]
        [(Validated (GenTx (HardForkBlock xs)), extra)]
      :.: FlipTickedLedgerState TrackingMK)
     xs
-> ReapplyTxsResult extra (HardForkBlock xs)
forall a b. (a -> b) -> a -> b
$ Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    Index xs a
    -> WrapLedgerConfig a
    -> Product
         (FlipTickedLedgerState ValuesMK)
         ([] :.: ((,) extra :.: WrapValidatedGenTx))
         a
    -> (:.:)
         ((,,)
            [Invalidated (HardForkBlock xs)]
            [(Validated (GenTx (HardForkBlock xs)), extra)])
         (FlipTickedLedgerState TrackingMK)
         a)
-> NP WrapLedgerConfig xs
-> HardForkState
     (Product
        (FlipTickedLedgerState ValuesMK)
        ([] :.: ((,) extra :.: WrapValidatedGenTx)))
     xs
-> HardForkState
     ((,,)
        [Invalidated (HardForkBlock xs)]
        [(Validated (GenTx (HardForkBlock xs)), extra)]
      :.: FlipTickedLedgerState TrackingMK)
     xs
forall {k} (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint)
       (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *)
       (f2 :: k -> *) (f3 :: k -> *).
(HAp h, All c xs, Prod h ~ NP) =>
proxy c
-> (forall (a :: k). c a => Index xs a -> f1 a -> f2 a -> f3 a)
-> NP f1 xs
-> h f2 xs
-> h f3 xs
hcizipWith
          Proxy SingleEraBlock
proxySingle
          Index xs a
-> WrapLedgerConfig a
-> Product
     (FlipTickedLedgerState ValuesMK)
     ([] :.: ((,) extra :.: WrapValidatedGenTx))
     a
-> DecomposedReapplyTxsResult extra xs a
forall a.
SingleEraBlock a =>
Index xs a
-> WrapLedgerConfig a
-> Product
     (FlipTickedLedgerState ValuesMK)
     ([] :.: ((,) extra :.: WrapValidatedGenTx))
     a
-> (:.:)
     ((,,)
        [Invalidated (HardForkBlock xs)]
        [(Validated (GenTx (HardForkBlock xs)), extra)])
     (FlipTickedLedgerState TrackingMK)
     a
modeApplyCurrent
          NP WrapLedgerConfig xs
cfgs
          (Telescope
  (K Past)
  (Current
     (Product
        (FlipTickedLedgerState ValuesMK)
        ([] :.: ((,) extra :.: WrapValidatedGenTx))))
  xs
-> HardForkState
     (Product
        (FlipTickedLedgerState ValuesMK)
        ([] :.: ((,) extra :.: WrapValidatedGenTx)))
     xs
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
State.HardForkState (Telescope
   (K Past)
   (Current
      (Product
         (FlipTickedLedgerState ValuesMK)
         ([] :.: ((,) extra :.: WrapValidatedGenTx))))
   xs
 -> HardForkState
      (Product
         (FlipTickedLedgerState ValuesMK)
         ([] :.: ((,) extra :.: WrapValidatedGenTx)))
      xs)
-> Telescope
     (K Past)
     (Current
        (Product
           (FlipTickedLedgerState ValuesMK)
           ([] :.: ((,) extra :.: WrapValidatedGenTx))))
     xs
-> HardForkState
     (Product
        (FlipTickedLedgerState ValuesMK)
        ([] :.: ((,) extra :.: WrapValidatedGenTx)))
     xs
forall a b. (a -> b) -> a -> b
$ (forall a.
 Product
   (Current (FlipTickedLedgerState ValuesMK))
   ([] :.: ((,) extra :.: WrapValidatedGenTx))
   a
 -> Current
      (Product
         (FlipTickedLedgerState ValuesMK)
         ([] :.: ((,) extra :.: WrapValidatedGenTx)))
      a)
-> Telescope
     (K Past)
     (Product
        (Current (FlipTickedLedgerState ValuesMK))
        ([] :.: ((,) extra :.: WrapValidatedGenTx)))
     xs
-> Telescope
     (K Past)
     (Current
        (Product
           (FlipTickedLedgerState ValuesMK)
           ([] :.: ((,) extra :.: WrapValidatedGenTx))))
     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 Product
  (Current (FlipTickedLedgerState ValuesMK))
  ([] :.: ((,) extra :.: WrapValidatedGenTx))
  a
-> Current
     (Product
        (FlipTickedLedgerState ValuesMK)
        ([] :.: ((,) extra :.: WrapValidatedGenTx)))
     a
forall a.
Product
  (Current (FlipTickedLedgerState ValuesMK))
  ([] :.: ((,) extra :.: WrapValidatedGenTx))
  a
-> Current
     (Product
        (FlipTickedLedgerState ValuesMK)
        ([] :.: ((,) extra :.: WrapValidatedGenTx)))
     a
forall {f :: * -> *} {g :: * -> *} {blk}.
Product (Current f) g blk -> Current (Product f g) blk
flipCurrentAndProduct Telescope
  (K Past)
  (Product
     (Current (FlipTickedLedgerState ValuesMK))
     ([] :.: ((,) extra :.: WrapValidatedGenTx)))
  xs
matched)
     where
      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
      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
          Shape xs
hardForkLedgerConfigShape
          TransitionInfo
transition
          HardForkState (FlipTickedLedgerState ValuesMK) xs
hardForkState

      flipCurrentAndProduct :: Product (Current f) g blk -> Current (Product f g) blk
flipCurrentAndProduct (Pair (State.Current Bound
c f blk
s) g blk
b) = Bound -> Product f g blk -> Current (Product f g) blk
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
State.Current Bound
c (f blk -> g blk -> Product f g blk
forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair f blk
s g blk
b)

      -- Transactions are unwrapped into the particular era transactions.
      ([(NS ((,) extra :.: WrapValidatedGenTx) xs,
  Mismatch
    ((,) extra :.: WrapValidatedGenTx)
    (Current (FlipTickedLedgerState ValuesMK))
    xs)]
mismatched, Telescope
  (K Past)
  (Product
     (Current (FlipTickedLedgerState ValuesMK))
     ([] :.: ((,) extra :.: WrapValidatedGenTx)))
  xs
matched) =
        InPairs (InjectPolyTx ((,) extra :.: WrapValidatedGenTx)) xs
-> Telescope (K Past) (Current (FlipTickedLedgerState ValuesMK)) xs
-> [NS ((,) extra :.: WrapValidatedGenTx) xs]
-> ([(NS ((,) extra :.: WrapValidatedGenTx) xs,
      Mismatch
        ((,) extra :.: WrapValidatedGenTx)
        (Current (FlipTickedLedgerState ValuesMK))
        xs)],
    Telescope
      (K Past)
      (Product
         (Current (FlipTickedLedgerState ValuesMK))
         ([] :.: ((,) extra :.: WrapValidatedGenTx)))
      xs)
forall (tx :: * -> *) (g :: * -> *) (f :: * -> *) (xs :: [*]).
SListI xs =>
InPairs (InjectPolyTx tx) xs
-> Telescope g f xs
-> [NS tx xs]
-> ([(NS tx xs, Mismatch tx f xs)],
    Telescope g (Product f ([] :.: tx)) xs)
matchPolyTxsTele
          -- How to translate txs to later eras
          ( (forall x y.
 Product2 InjectTx InjectValidatedTx x y
 -> InjectPolyTx ((,) extra :.: WrapValidatedGenTx) x y)
-> InPairs (Product2 InjectTx InjectValidatedTx) xs
-> InPairs (InjectPolyTx ((,) extra :.: WrapValidatedGenTx)) 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
              (\(Pair2 InjectTx x y
_ (InjectPolyTx WrapValidatedGenTx x -> Maybe (WrapValidatedGenTx y)
w)) -> ((:.:) ((,) extra) WrapValidatedGenTx x
 -> Maybe ((:.:) ((,) extra) WrapValidatedGenTx y))
-> InjectPolyTx ((,) extra :.: WrapValidatedGenTx) x y
forall (tx :: * -> *) blk blk'.
(tx blk -> Maybe (tx blk')) -> InjectPolyTx tx blk blk'
InjectPolyTx (\(Comp (extra
ex, WrapValidatedGenTx x
tx)) -> (extra, WrapValidatedGenTx y)
-> (:.:) ((,) extra) WrapValidatedGenTx y
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp ((extra, WrapValidatedGenTx y)
 -> (:.:) ((,) extra) WrapValidatedGenTx y)
-> (WrapValidatedGenTx y -> (extra, WrapValidatedGenTx y))
-> WrapValidatedGenTx y
-> (:.:) ((,) extra) WrapValidatedGenTx y
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (extra
ex,) (WrapValidatedGenTx y -> (:.:) ((,) extra) WrapValidatedGenTx y)
-> Maybe (WrapValidatedGenTx y)
-> Maybe ((:.:) ((,) extra) WrapValidatedGenTx y)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> WrapValidatedGenTx x -> Maybe (WrapValidatedGenTx y)
w WrapValidatedGenTx x
tx))
              (NP WrapLedgerConfig xs
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (Product2 InjectTx InjectValidatedTx))
     xs
-> InPairs (Product2 InjectTx InjectValidatedTx) 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 (Product2 InjectTx InjectValidatedTx))
  xs
forall (xs :: [*]).
CanHardFork xs =>
InPairs
  (RequiringBoth
     WrapLedgerConfig (Product2 InjectTx InjectValidatedTx))
  xs
hardForkInjectTxs)
          )
          (HardForkState (FlipTickedLedgerState ValuesMK) xs
-> Telescope (K Past) (Current (FlipTickedLedgerState ValuesMK)) xs
forall (f :: * -> *) (xs :: [*]).
HardForkState f xs -> Telescope (K Past) (Current f) xs
State.getHardForkState HardForkState (FlipTickedLedgerState ValuesMK) xs
hardForkState)
          ( ((Validated (GenTx (HardForkBlock xs)), extra)
 -> NS ((,) extra :.: WrapValidatedGenTx) xs)
-> [(Validated (GenTx (HardForkBlock xs)), extra)]
-> [NS ((,) extra :.: WrapValidatedGenTx) xs]
forall a b. (a -> b) -> [a] -> [b]
map
              (\(Validated (GenTx (HardForkBlock xs))
tx, extra
extra) -> (forall a.
 WrapValidatedGenTx a -> (:.:) ((,) extra) WrapValidatedGenTx a)
-> NS WrapValidatedGenTx xs
-> NS ((,) extra :.: WrapValidatedGenTx) 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 ((extra, WrapValidatedGenTx a)
-> (:.:) ((,) extra) WrapValidatedGenTx a
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp ((extra, WrapValidatedGenTx a)
 -> (:.:) ((,) extra) WrapValidatedGenTx a)
-> (WrapValidatedGenTx a -> (extra, WrapValidatedGenTx a))
-> WrapValidatedGenTx a
-> (:.:) ((,) extra) WrapValidatedGenTx a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (extra
extra,)) (NS WrapValidatedGenTx xs
 -> NS ((,) extra :.: WrapValidatedGenTx) xs)
-> (Validated (GenTx (HardForkBlock xs))
    -> NS WrapValidatedGenTx xs)
-> Validated (GenTx (HardForkBlock xs))
-> NS ((,) extra :.: WrapValidatedGenTx) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs
forall (xs :: [*]).
OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs
getOneEraValidatedGenTx (OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs)
-> (Validated (GenTx (HardForkBlock xs))
    -> OneEraValidatedGenTx xs)
-> Validated (GenTx (HardForkBlock xs))
-> NS WrapValidatedGenTx xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx (HardForkBlock xs)) -> OneEraValidatedGenTx xs
forall (xs :: [*]).
Validated (GenTx (HardForkBlock xs)) -> OneEraValidatedGenTx xs
getHardForkValidatedGenTx (Validated (GenTx (HardForkBlock xs))
 -> NS ((,) extra :.: WrapValidatedGenTx) xs)
-> Validated (GenTx (HardForkBlock xs))
-> NS ((,) extra :.: WrapValidatedGenTx) xs
forall a b. (a -> b) -> a -> b
$ Validated (GenTx (HardForkBlock xs))
tx)
              [(Validated (GenTx (HardForkBlock xs)), extra)]
vtxs
          )

      mismatched' :: [Invalidated (HardForkBlock xs)]
      mismatched' :: [Invalidated (HardForkBlock xs)]
mismatched' =
        ((NS ((,) extra :.: WrapValidatedGenTx) xs,
  Mismatch
    ((,) extra :.: WrapValidatedGenTx)
    (Current (FlipTickedLedgerState ValuesMK))
    xs)
 -> Invalidated (HardForkBlock xs))
-> [(NS ((,) extra :.: WrapValidatedGenTx) xs,
     Mismatch
       ((,) extra :.: WrapValidatedGenTx)
       (Current (FlipTickedLedgerState ValuesMK))
       xs)]
-> [Invalidated (HardForkBlock xs)]
forall a b. (a -> b) -> [a] -> [b]
map
          ( \(NS ((,) extra :.: WrapValidatedGenTx) xs,
 Mismatch
   ((,) extra :.: WrapValidatedGenTx)
   (Current (FlipTickedLedgerState ValuesMK))
   xs)
x ->
              (Validated (GenTx (HardForkBlock xs))
 -> HardForkApplyTxErr xs -> Invalidated (HardForkBlock xs))
-> HardForkApplyTxErr xs
-> Validated (GenTx (HardForkBlock xs))
-> Invalidated (HardForkBlock xs)
forall a b c. (a -> b -> c) -> b -> a -> c
flip
                Validated (GenTx (HardForkBlock xs))
-> ApplyTxErr (HardForkBlock xs) -> Invalidated (HardForkBlock xs)
Validated (GenTx (HardForkBlock xs))
-> HardForkApplyTxErr xs -> Invalidated (HardForkBlock xs)
forall blk.
Validated (GenTx blk) -> ApplyTxErr blk -> Invalidated blk
Invalidated
                ( MismatchEraInfo xs -> HardForkApplyTxErr xs
forall (xs :: [*]). MismatchEraInfo xs -> HardForkApplyTxErr xs
HardForkApplyTxErrWrongEra (MismatchEraInfo xs -> HardForkApplyTxErr xs)
-> MismatchEraInfo xs -> HardForkApplyTxErr xs
forall a b. (a -> b) -> a -> b
$
                    Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
forall (xs :: [*]).
Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
MismatchEraInfo (Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs)
-> Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs
forall a b. (a -> b) -> a -> b
$
                      Proxy SingleEraBlock
-> (forall x.
    SingleEraBlock x =>
    (:.:) ((,) extra) WrapValidatedGenTx x -> SingleEraInfo x)
-> (forall x.
    SingleEraBlock x =>
    Current (FlipTickedLedgerState ValuesMK) x -> LedgerEraInfo x)
-> Mismatch
     ((,) extra :.: WrapValidatedGenTx)
     (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 (:.:) ((,) extra) WrapValidatedGenTx x -> SingleEraInfo x
forall x.
SingleEraBlock x =>
(:.:) ((,) extra) WrapValidatedGenTx 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
   ((,) extra :.: WrapValidatedGenTx)
   (Current (FlipTickedLedgerState ValuesMK))
   xs
 -> Mismatch SingleEraInfo LedgerEraInfo xs)
-> Mismatch
     ((,) extra :.: WrapValidatedGenTx)
     (Current (FlipTickedLedgerState ValuesMK))
     xs
-> Mismatch SingleEraInfo LedgerEraInfo xs
forall a b. (a -> b) -> a -> b
$
                        (NS ((,) extra :.: WrapValidatedGenTx) xs,
 Mismatch
   ((,) extra :.: WrapValidatedGenTx)
   (Current (FlipTickedLedgerState ValuesMK))
   xs)
-> Mismatch
     ((,) extra :.: WrapValidatedGenTx)
     (Current (FlipTickedLedgerState ValuesMK))
     xs
forall a b. (a, b) -> b
snd (NS ((,) extra :.: WrapValidatedGenTx) xs,
 Mismatch
   ((,) extra :.: WrapValidatedGenTx)
   (Current (FlipTickedLedgerState ValuesMK))
   xs)
x
                )
                (Validated (GenTx (HardForkBlock xs))
 -> Invalidated (HardForkBlock xs))
-> ((NS ((,) extra :.: WrapValidatedGenTx) xs,
     Mismatch
       ((,) extra :.: WrapValidatedGenTx)
       (Current (FlipTickedLedgerState ValuesMK))
       xs)
    -> Validated (GenTx (HardForkBlock xs)))
-> (NS ((,) extra :.: WrapValidatedGenTx) xs,
    Mismatch
      ((,) extra :.: WrapValidatedGenTx)
      (Current (FlipTickedLedgerState ValuesMK))
      xs)
-> Invalidated (HardForkBlock xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneEraValidatedGenTx xs -> Validated (GenTx (HardForkBlock xs))
forall (xs :: [*]).
OneEraValidatedGenTx xs -> Validated (GenTx (HardForkBlock xs))
HardForkValidatedGenTx
                (OneEraValidatedGenTx xs -> Validated (GenTx (HardForkBlock xs)))
-> ((NS ((,) extra :.: WrapValidatedGenTx) xs,
     Mismatch
       ((,) extra :.: WrapValidatedGenTx)
       (Current (FlipTickedLedgerState ValuesMK))
       xs)
    -> OneEraValidatedGenTx xs)
-> (NS ((,) extra :.: WrapValidatedGenTx) xs,
    Mismatch
      ((,) extra :.: WrapValidatedGenTx)
      (Current (FlipTickedLedgerState ValuesMK))
      xs)
-> Validated (GenTx (HardForkBlock xs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS WrapValidatedGenTx xs -> OneEraValidatedGenTx xs
forall (xs :: [*]).
NS WrapValidatedGenTx xs -> OneEraValidatedGenTx xs
OneEraValidatedGenTx
                (NS WrapValidatedGenTx xs -> OneEraValidatedGenTx xs)
-> ((NS ((,) extra :.: WrapValidatedGenTx) xs,
     Mismatch
       ((,) extra :.: WrapValidatedGenTx)
       (Current (FlipTickedLedgerState ValuesMK))
       xs)
    -> NS WrapValidatedGenTx xs)
-> (NS ((,) extra :.: WrapValidatedGenTx) xs,
    Mismatch
      ((,) extra :.: WrapValidatedGenTx)
      (Current (FlipTickedLedgerState ValuesMK))
      xs)
-> OneEraValidatedGenTx xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a.
 (:.:) ((,) extra) WrapValidatedGenTx a -> WrapValidatedGenTx a)
-> NS ((,) extra :.: WrapValidatedGenTx) xs
-> NS WrapValidatedGenTx 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 ((extra, WrapValidatedGenTx a) -> WrapValidatedGenTx a
forall a b. (a, b) -> b
snd ((extra, WrapValidatedGenTx a) -> WrapValidatedGenTx a)
-> ((:.:) ((,) extra) WrapValidatedGenTx a
    -> (extra, WrapValidatedGenTx a))
-> (:.:) ((,) extra) WrapValidatedGenTx a
-> WrapValidatedGenTx a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:.:) ((,) extra) WrapValidatedGenTx a
-> (extra, WrapValidatedGenTx a)
forall {l} {k} (f :: l -> *) (g :: k -> l) (p :: k).
(:.:) f g p -> f (g p)
unComp)
                (NS ((,) extra :.: WrapValidatedGenTx) xs
 -> NS WrapValidatedGenTx xs)
-> ((NS ((,) extra :.: WrapValidatedGenTx) xs,
     Mismatch
       ((,) extra :.: WrapValidatedGenTx)
       (Current (FlipTickedLedgerState ValuesMK))
       xs)
    -> NS ((,) extra :.: WrapValidatedGenTx) xs)
-> (NS ((,) extra :.: WrapValidatedGenTx) xs,
    Mismatch
      ((,) extra :.: WrapValidatedGenTx)
      (Current (FlipTickedLedgerState ValuesMK))
      xs)
-> NS WrapValidatedGenTx xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NS ((,) extra :.: WrapValidatedGenTx) xs,
 Mismatch
   ((,) extra :.: WrapValidatedGenTx)
   (Current (FlipTickedLedgerState ValuesMK))
   xs)
-> NS ((,) extra :.: WrapValidatedGenTx) xs
forall a b. (a, b) -> a
fst
                ((NS ((,) extra :.: WrapValidatedGenTx) xs,
  Mismatch
    ((,) extra :.: WrapValidatedGenTx)
    (Current (FlipTickedLedgerState ValuesMK))
    xs)
 -> Invalidated (HardForkBlock xs))
-> (NS ((,) extra :.: WrapValidatedGenTx) xs,
    Mismatch
      ((,) extra :.: WrapValidatedGenTx)
      (Current (FlipTickedLedgerState ValuesMK))
      xs)
-> Invalidated (HardForkBlock xs)
forall a b. (a -> b) -> a -> b
$ (NS ((,) extra :.: WrapValidatedGenTx) xs,
 Mismatch
   ((,) extra :.: WrapValidatedGenTx)
   (Current (FlipTickedLedgerState ValuesMK))
   xs)
x
          )
          [(NS ((,) extra :.: WrapValidatedGenTx) xs,
  Mismatch
    ((,) extra :.: WrapValidatedGenTx)
    (Current (FlipTickedLedgerState ValuesMK))
    xs)]
mismatched

      modeApplyCurrent ::
        forall blk.
        SingleEraBlock blk =>
        Index xs blk ->
        WrapLedgerConfig blk ->
        Product
          (FlipTickedLedgerState ValuesMK)
          ([] :.: (,) extra :.: WrapValidatedGenTx)
          blk ->
        DecomposedReapplyTxsResult extra xs blk
      modeApplyCurrent :: forall a.
SingleEraBlock a =>
Index xs a
-> WrapLedgerConfig a
-> Product
     (FlipTickedLedgerState ValuesMK)
     ([] :.: ((,) extra :.: WrapValidatedGenTx))
     a
-> (:.:)
     ((,,)
        [Invalidated (HardForkBlock xs)]
        [(Validated (GenTx (HardForkBlock xs)), extra)])
     (FlipTickedLedgerState TrackingMK)
     a
modeApplyCurrent Index xs blk
index WrapLedgerConfig blk
cfg (Pair (FlipTickedLedgerState Ticked (LedgerState blk) ValuesMK
st) (:.:) [] ((,) extra :.: WrapValidatedGenTx) blk
txs) =
        let ReapplyTxsResult [Invalidated blk]
err [(Validated (GenTx blk), extra)]
val TickedLedgerState blk TrackingMK
st' =
              ComputeDiffs
-> LedgerConfig blk
-> SlotNo
-> [(Validated (GenTx blk), extra)]
-> Ticked (LedgerState blk) ValuesMK
-> ReapplyTxsResult extra blk
forall blk extra.
LedgerSupportsMempool blk =>
ComputeDiffs
-> LedgerConfig blk
-> SlotNo
-> [(Validated (GenTx blk), extra)]
-> TickedLedgerState blk ValuesMK
-> ReapplyTxsResult extra blk
forall extra.
ComputeDiffs
-> LedgerConfig blk
-> SlotNo
-> [(Validated (GenTx blk), extra)]
-> Ticked (LedgerState blk) ValuesMK
-> ReapplyTxsResult extra blk
reapplyTxs
                ComputeDiffs
doDiffs
                (WrapLedgerConfig blk -> LedgerConfig blk
forall blk. WrapLedgerConfig blk -> LedgerConfig blk
unwrapLedgerConfig WrapLedgerConfig blk
cfg)
                SlotNo
slot
                [(WrapValidatedGenTx blk -> Validated (GenTx blk)
forall blk. WrapValidatedGenTx blk -> Validated (GenTx blk)
unwrapValidatedGenTx WrapValidatedGenTx blk
tx, extra
tk) | (Comp (extra
tk, WrapValidatedGenTx blk
tx)) <- (:.:) [] ((,) extra :.: WrapValidatedGenTx) blk
-> [(:.:) ((,) extra) WrapValidatedGenTx blk]
forall {l} {k} (f :: l -> *) (g :: k -> l) (p :: k).
(:.:) f g p -> f (g p)
unComp (:.:) [] ((,) extra :.: WrapValidatedGenTx) blk
txs]
                Ticked (LedgerState blk) ValuesMK
st
         in ([Invalidated (HardForkBlock xs)],
 [(Validated (GenTx (HardForkBlock xs)), extra)],
 FlipTickedLedgerState TrackingMK blk)
-> (:.:)
     ((,,)
        [Invalidated (HardForkBlock xs)]
        [(Validated (GenTx (HardForkBlock xs)), extra)])
     (FlipTickedLedgerState TrackingMK)
     blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp
              ( [ Index xs blk
-> Validated (GenTx blk) -> Validated (GenTx (HardForkBlock xs))
forall (xs :: [*]) blk.
SListI xs =>
Index xs blk
-> Validated (GenTx blk) -> Validated (GenTx (HardForkBlock xs))
injectValidatedGenTx Index xs blk
index (Invalidated blk -> Validated (GenTx blk)
forall blk. Invalidated blk -> Validated (GenTx blk)
getInvalidated Invalidated blk
x) Validated (GenTx (HardForkBlock xs))
-> ApplyTxErr (HardForkBlock xs) -> Invalidated (HardForkBlock xs)
forall blk.
Validated (GenTx blk) -> ApplyTxErr blk -> Invalidated blk
`Invalidated` Index xs blk -> ApplyTxErr blk -> HardForkApplyTxErr xs
forall (xs :: [*]) blk.
SListI xs =>
Index xs blk -> ApplyTxErr blk -> HardForkApplyTxErr xs
injectApplyTxErr Index xs blk
index (Invalidated blk -> ApplyTxErr blk
forall blk. Invalidated blk -> ApplyTxErr blk
getReason Invalidated blk
x)
                | Invalidated blk
x <- [Invalidated blk]
err
                ]
              , ((Validated (GenTx blk), extra)
 -> (Validated (GenTx (HardForkBlock xs)), extra))
-> [(Validated (GenTx blk), extra)]
-> [(Validated (GenTx (HardForkBlock xs)), extra)]
forall a b. (a -> b) -> [a] -> [b]
map
                  ((Validated (GenTx blk) -> Validated (GenTx (HardForkBlock xs)))
-> (Validated (GenTx blk), extra)
-> (Validated (GenTx (HardForkBlock xs)), extra)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: MapKind) b c d. Arrow a => a b c -> a (b, d) (c, d)
first (OneEraValidatedGenTx xs -> Validated (GenTx (HardForkBlock xs))
forall (xs :: [*]).
OneEraValidatedGenTx xs -> Validated (GenTx (HardForkBlock xs))
HardForkValidatedGenTx (OneEraValidatedGenTx xs -> Validated (GenTx (HardForkBlock xs)))
-> (Validated (GenTx blk) -> OneEraValidatedGenTx xs)
-> Validated (GenTx blk)
-> Validated (GenTx (HardForkBlock xs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS WrapValidatedGenTx xs -> OneEraValidatedGenTx xs
forall (xs :: [*]).
NS WrapValidatedGenTx xs -> OneEraValidatedGenTx xs
OneEraValidatedGenTx (NS WrapValidatedGenTx xs -> OneEraValidatedGenTx xs)
-> (Validated (GenTx blk) -> NS WrapValidatedGenTx xs)
-> Validated (GenTx blk)
-> OneEraValidatedGenTx xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index xs blk -> WrapValidatedGenTx blk -> NS WrapValidatedGenTx 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 (WrapValidatedGenTx blk -> NS WrapValidatedGenTx xs)
-> (Validated (GenTx blk) -> WrapValidatedGenTx blk)
-> Validated (GenTx blk)
-> NS WrapValidatedGenTx xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx blk) -> WrapValidatedGenTx blk
forall blk. Validated (GenTx blk) -> WrapValidatedGenTx blk
WrapValidatedGenTx))
                  [(Validated (GenTx blk), extra)]
val
              , TickedLedgerState blk TrackingMK
-> FlipTickedLedgerState TrackingMK blk
forall (mk :: MapKind) blk.
Ticked (LedgerState blk) mk -> FlipTickedLedgerState mk blk
FlipTickedLedgerState TickedLedgerState blk TrackingMK
st'
              )

  txForgetValidated :: Validated (GenTx (HardForkBlock xs)) -> GenTx (HardForkBlock xs)
txForgetValidated =
    OneEraGenTx xs -> GenTx (HardForkBlock xs)
forall (xs :: [*]). OneEraGenTx xs -> GenTx (HardForkBlock xs)
HardForkGenTx
      (OneEraGenTx xs -> GenTx (HardForkBlock xs))
-> (Validated (GenTx (HardForkBlock xs)) -> OneEraGenTx xs)
-> Validated (GenTx (HardForkBlock xs))
-> GenTx (HardForkBlock xs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS GenTx xs -> OneEraGenTx xs
forall (xs :: [*]). NS GenTx xs -> OneEraGenTx xs
OneEraGenTx
      (NS GenTx xs -> OneEraGenTx xs)
-> (Validated (GenTx (HardForkBlock xs)) -> NS GenTx xs)
-> Validated (GenTx (HardForkBlock xs))
-> OneEraGenTx xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy SingleEraBlock
-> (forall a. SingleEraBlock a => WrapValidatedGenTx a -> GenTx a)
-> NS WrapValidatedGenTx xs
-> NS GenTx 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 (Validated (GenTx a) -> GenTx a
forall blk.
LedgerSupportsMempool blk =>
Validated (GenTx blk) -> GenTx blk
txForgetValidated (Validated (GenTx a) -> GenTx a)
-> (WrapValidatedGenTx a -> Validated (GenTx a))
-> WrapValidatedGenTx a
-> GenTx a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapValidatedGenTx a -> Validated (GenTx a)
forall blk. WrapValidatedGenTx blk -> Validated (GenTx blk)
unwrapValidatedGenTx)
      (NS WrapValidatedGenTx xs -> NS GenTx xs)
-> (Validated (GenTx (HardForkBlock xs))
    -> NS WrapValidatedGenTx xs)
-> Validated (GenTx (HardForkBlock xs))
-> NS GenTx xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs
forall (xs :: [*]).
OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs
getOneEraValidatedGenTx
      (OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs)
-> (Validated (GenTx (HardForkBlock xs))
    -> OneEraValidatedGenTx xs)
-> Validated (GenTx (HardForkBlock xs))
-> NS WrapValidatedGenTx xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx (HardForkBlock xs)) -> OneEraValidatedGenTx xs
forall (xs :: [*]).
Validated (GenTx (HardForkBlock xs)) -> OneEraValidatedGenTx xs
getHardForkValidatedGenTx

  getTransactionKeySets :: GenTx (HardForkBlock xs)
-> LedgerTables (LedgerState (HardForkBlock xs)) KeysMK
getTransactionKeySets (HardForkGenTx (OneEraGenTx NS GenTx 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
    -> GenTx a
    -> K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK) a)
-> NS GenTx 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
-> GenTx a
-> K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK) a
forall a.
SingleEraBlock a =>
Index xs a
-> GenTx a
-> K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK) a
f NS GenTx xs
ns
   where
    f ::
      SingleEraBlock x =>
      Index xs x ->
      GenTx x ->
      K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK) x
    f :: forall a.
SingleEraBlock a =>
Index xs a
-> GenTx a
-> K (LedgerTables (LedgerState (HardForkBlock xs)) KeysMK) a
f Index xs x
idx GenTx x
tx = 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
$ GenTx x -> LedgerTables (LedgerState x) KeysMK
forall blk.
LedgerSupportsMempool blk =>
GenTx blk -> LedgerTables (LedgerState blk) KeysMK
getTransactionKeySets GenTx x
tx

  -- This optimization is worthwile because we can save the projection and
  -- injection of ledger tables.
  --
  -- These operations are used when adding new transactions to the mempool,
  -- which is _not_ in the critical path for the forging loop but still will
  -- make adoption of new transactions faster. As adding a transaction takes a
  -- TMVar, it is interesting to hold it for as short of a time as possible.
  prependMempoolDiffs :: TickedLedgerState (HardForkBlock xs) DiffMK
-> TickedLedgerState (HardForkBlock xs) DiffMK
-> TickedLedgerState (HardForkBlock xs) DiffMK
prependMempoolDiffs
    (TickedHardForkLedgerState TransitionInfo
_ (State.HardForkState Telescope (K Past) (Current (FlipTickedLedgerState DiffMK)) xs
st1))
    (TickedHardForkLedgerState TransitionInfo
tr (State.HardForkState Telescope (K Past) (Current (FlipTickedLedgerState DiffMK)) xs
st2)) =
      TransitionInfo
-> HardForkState (FlipTickedLedgerState DiffMK) xs
-> TickedLedgerState (HardForkBlock xs) DiffMK
forall (xs :: [*]) (mk :: MapKind).
TransitionInfo
-> HardForkState (FlipTickedLedgerState mk) xs
-> Ticked (LedgerState (HardForkBlock xs)) mk
TickedHardForkLedgerState
        TransitionInfo
tr
        (HardForkState (FlipTickedLedgerState DiffMK) xs
 -> TickedLedgerState (HardForkBlock xs) DiffMK)
-> HardForkState (FlipTickedLedgerState DiffMK) xs
-> TickedLedgerState (HardForkBlock xs) DiffMK
forall a b. (a -> b) -> a -> b
$ Telescope (K Past) (Current (FlipTickedLedgerState DiffMK)) xs
-> HardForkState (FlipTickedLedgerState DiffMK) xs
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
State.HardForkState
        (Telescope (K Past) (Current (FlipTickedLedgerState DiffMK)) xs
 -> HardForkState (FlipTickedLedgerState DiffMK) xs)
-> Telescope (K Past) (Current (FlipTickedLedgerState DiffMK)) xs
-> HardForkState (FlipTickedLedgerState DiffMK) xs
forall a b. (a -> b) -> a -> b
$ Identity
  (Telescope (K Past) (Current (FlipTickedLedgerState DiffMK)) xs)
-> Telescope (K Past) (Current (FlipTickedLedgerState DiffMK)) xs
forall a. Identity a -> a
runIdentity
          ( InPairs
  (Requiring
     (K Past)
     (Extend
        Identity (K Past) (Current (FlipTickedLedgerState DiffMK))))
  xs
-> NP
     (Current (FlipTickedLedgerState DiffMK)
      -.-> (Current (FlipTickedLedgerState DiffMK)
            -.-> Current (FlipTickedLedgerState DiffMK)))
     xs
-> Telescope (K Past) (Current (FlipTickedLedgerState DiffMK)) xs
-> Telescope (K Past) (Current (FlipTickedLedgerState DiffMK)) xs
-> Identity
     (Telescope (K Past) (Current (FlipTickedLedgerState DiffMK)) xs)
forall {k} (m :: * -> *) (g' :: k -> *) (g :: k -> *) (f :: k -> *)
       (xs :: [k]) (f' :: k -> *) (f'' :: k -> *).
(Monad m, HasCallStack) =>
InPairs (Requiring g' (Extend m g f)) xs
-> NP (f' -.-> (f -.-> f'')) xs
-> Telescope g' f' xs
-> Telescope g f xs
-> m (Telescope g f'' xs)
Tele.alignExtend
              ( (forall x y.
 Requiring
   (K Past)
   (Extend Identity (K Past) (Current (FlipTickedLedgerState DiffMK)))
   x
   y)
-> InPairs
     (Requiring
        (K Past)
        (Extend
           Identity (K Past) (Current (FlipTickedLedgerState DiffMK))))
     xs
forall {k} (xs :: [k]) (f :: k -> k -> *).
(SListI xs, IsNonEmpty xs) =>
(forall (x :: k) (y :: k). f x y) -> InPairs f xs
InPairs.hpure
                  (String
-> Requiring
     (K Past)
     (Extend Identity (K Past) (Current (FlipTickedLedgerState DiffMK)))
     x
     y
forall a. HasCallStack => String -> a
error String
"When prepending mempool diffs we used to un-aligned states, this should be impossible!")
              )
              ( Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    (-.->)
      (Current (FlipTickedLedgerState DiffMK))
      (Current (FlipTickedLedgerState DiffMK)
       -.-> Current (FlipTickedLedgerState DiffMK))
      a)
-> NP
     (Current (FlipTickedLedgerState DiffMK)
      -.-> (Current (FlipTickedLedgerState DiffMK)
            -.-> Current (FlipTickedLedgerState DiffMK)))
     xs
forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *).
(HPure h, AllN h c xs) =>
proxy c -> (forall (a :: k). c a => f a) -> h f xs
forall (c :: * -> Constraint) (xs :: [*])
       (proxy :: (* -> Constraint) -> *) (f :: * -> *).
AllN NP c xs =>
proxy c -> (forall a. c a => f a) -> NP f xs
hcpure Proxy SingleEraBlock
proxySingle ((forall a.
  SingleEraBlock a =>
  (-.->)
    (Current (FlipTickedLedgerState DiffMK))
    (Current (FlipTickedLedgerState DiffMK)
     -.-> Current (FlipTickedLedgerState DiffMK))
    a)
 -> NP
      (Current (FlipTickedLedgerState DiffMK)
       -.-> (Current (FlipTickedLedgerState DiffMK)
             -.-> Current (FlipTickedLedgerState DiffMK)))
      xs)
-> (forall a.
    SingleEraBlock a =>
    (-.->)
      (Current (FlipTickedLedgerState DiffMK))
      (Current (FlipTickedLedgerState DiffMK)
       -.-> Current (FlipTickedLedgerState DiffMK))
      a)
-> NP
     (Current (FlipTickedLedgerState DiffMK)
      -.-> (Current (FlipTickedLedgerState DiffMK)
            -.-> Current (FlipTickedLedgerState DiffMK)))
     xs
forall a b. (a -> b) -> a -> b
$ (Current (FlipTickedLedgerState DiffMK) a
 -> Current (FlipTickedLedgerState DiffMK) a
 -> Current (FlipTickedLedgerState DiffMK) a)
-> (-.->)
     (Current (FlipTickedLedgerState DiffMK))
     (Current (FlipTickedLedgerState DiffMK)
      -.-> Current (FlipTickedLedgerState DiffMK))
     a
forall {k} (f :: k -> *) (a :: k) (f' :: k -> *) (f'' :: k -> *).
(f a -> f' a -> f'' a) -> (-.->) f (f' -.-> f'') a
fn_2 ((Current (FlipTickedLedgerState DiffMK) a
  -> Current (FlipTickedLedgerState DiffMK) a
  -> Current (FlipTickedLedgerState DiffMK) a)
 -> (-.->)
      (Current (FlipTickedLedgerState DiffMK))
      (Current (FlipTickedLedgerState DiffMK)
       -.-> Current (FlipTickedLedgerState DiffMK))
      a)
-> (Current (FlipTickedLedgerState DiffMK) a
    -> Current (FlipTickedLedgerState DiffMK) a
    -> Current (FlipTickedLedgerState DiffMK) a)
-> (-.->)
     (Current (FlipTickedLedgerState DiffMK))
     (Current (FlipTickedLedgerState DiffMK)
      -.-> Current (FlipTickedLedgerState DiffMK))
     a
forall a b. (a -> b) -> a -> b
$ \(State.Current Bound
_ FlipTickedLedgerState DiffMK a
a) (State.Current Bound
start FlipTickedLedgerState DiffMK a
b) ->
                  Bound
-> FlipTickedLedgerState DiffMK a
-> Current (FlipTickedLedgerState DiffMK) a
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
State.Current Bound
start (FlipTickedLedgerState DiffMK a
 -> Current (FlipTickedLedgerState DiffMK) a)
-> FlipTickedLedgerState DiffMK a
-> Current (FlipTickedLedgerState DiffMK) a
forall a b. (a -> b) -> a -> b
$
                    Ticked (LedgerState a) DiffMK -> FlipTickedLedgerState DiffMK a
forall (mk :: MapKind) blk.
Ticked (LedgerState blk) mk -> FlipTickedLedgerState mk blk
FlipTickedLedgerState (Ticked (LedgerState a) DiffMK -> FlipTickedLedgerState DiffMK a)
-> Ticked (LedgerState a) DiffMK -> FlipTickedLedgerState DiffMK a
forall a b. (a -> b) -> a -> b
$
                      Ticked (LedgerState a) DiffMK
-> Ticked (LedgerState a) DiffMK -> Ticked (LedgerState a) DiffMK
forall blk.
LedgerSupportsMempool blk =>
TickedLedgerState blk DiffMK
-> TickedLedgerState blk DiffMK -> TickedLedgerState blk DiffMK
prependMempoolDiffs
                        (FlipTickedLedgerState DiffMK a -> Ticked (LedgerState a) DiffMK
forall (mk :: MapKind) blk.
FlipTickedLedgerState mk blk -> Ticked (LedgerState blk) mk
getFlipTickedLedgerState FlipTickedLedgerState DiffMK a
a)
                        (FlipTickedLedgerState DiffMK a -> Ticked (LedgerState a) DiffMK
forall (mk :: MapKind) blk.
FlipTickedLedgerState mk blk -> Ticked (LedgerState blk) mk
getFlipTickedLedgerState FlipTickedLedgerState DiffMK a
b)
              )
              Telescope (K Past) (Current (FlipTickedLedgerState DiffMK)) xs
st1
              Telescope (K Past) (Current (FlipTickedLedgerState DiffMK)) xs
st2
          )

  -- This optimization is worthwile because we can save the projection and
  -- injection of ledger tables.
  --
  -- These operations are used when adding new transactions to the mempool,
  -- which is _not_ in the critical path for the forging loop but still will
  -- make adoption of new transactions faster. As adding a transaction takes a
  -- TMVar, it is interesting to hold it for as short of a time as possible.
  applyMempoolDiffs :: LedgerTables (LedgerState (HardForkBlock xs)) ValuesMK
-> LedgerTables (LedgerState (HardForkBlock xs)) KeysMK
-> TickedLedgerState (HardForkBlock xs) DiffMK
-> TickedLedgerState (HardForkBlock xs) ValuesMK
applyMempoolDiffs
    LedgerTables (LedgerState (HardForkBlock xs)) ValuesMK
vals
    LedgerTables (LedgerState (HardForkBlock xs)) KeysMK
keys
    (TickedHardForkLedgerState TransitionInfo
tr (State.HardForkState Telescope (K Past) (Current (FlipTickedLedgerState DiffMK)) xs
st)) =
      TransitionInfo
-> HardForkState (FlipTickedLedgerState ValuesMK) xs
-> TickedLedgerState (HardForkBlock xs) ValuesMK
forall (xs :: [*]) (mk :: MapKind).
TransitionInfo
-> HardForkState (FlipTickedLedgerState mk) xs
-> Ticked (LedgerState (HardForkBlock xs)) mk
TickedHardForkLedgerState TransitionInfo
tr (HardForkState (FlipTickedLedgerState ValuesMK) xs
 -> TickedLedgerState (HardForkBlock xs) ValuesMK)
-> HardForkState (FlipTickedLedgerState ValuesMK) xs
-> TickedLedgerState (HardForkBlock xs) ValuesMK
forall a b. (a -> b) -> a -> b
$
        Telescope (K Past) (Current (FlipTickedLedgerState ValuesMK)) xs
-> HardForkState (FlipTickedLedgerState ValuesMK) xs
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
State.HardForkState (Telescope (K Past) (Current (FlipTickedLedgerState ValuesMK)) xs
 -> HardForkState (FlipTickedLedgerState ValuesMK) xs)
-> Telescope (K Past) (Current (FlipTickedLedgerState ValuesMK)) xs
-> HardForkState (FlipTickedLedgerState ValuesMK) xs
forall a b. (a -> b) -> a -> b
$
          Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    Index xs a
    -> Current (FlipTickedLedgerState DiffMK) a
    -> Current (FlipTickedLedgerState ValuesMK) a)
-> Telescope (K Past) (Current (FlipTickedLedgerState DiffMK)) xs
-> Telescope (K Past) (Current (FlipTickedLedgerState ValuesMK)) 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
idx (State.Current Bound
start (FlipTickedLedgerState Ticked (LedgerState a) DiffMK
a)) ->
                Bound
-> FlipTickedLedgerState ValuesMK a
-> Current (FlipTickedLedgerState ValuesMK) a
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
State.Current Bound
start (FlipTickedLedgerState ValuesMK a
 -> Current (FlipTickedLedgerState ValuesMK) a)
-> FlipTickedLedgerState ValuesMK a
-> Current (FlipTickedLedgerState ValuesMK) a
forall a b. (a -> b) -> a -> b
$
                  Ticked (LedgerState a) ValuesMK -> FlipTickedLedgerState ValuesMK a
forall (mk :: MapKind) blk.
Ticked (LedgerState blk) mk -> FlipTickedLedgerState mk blk
FlipTickedLedgerState (Ticked (LedgerState a) ValuesMK
 -> FlipTickedLedgerState ValuesMK a)
-> Ticked (LedgerState a) ValuesMK
-> FlipTickedLedgerState ValuesMK a
forall a b. (a -> b) -> a -> b
$
                    LedgerTables (LedgerState a) ValuesMK
-> LedgerTables (LedgerState a) KeysMK
-> Ticked (LedgerState a) DiffMK
-> Ticked (LedgerState a) ValuesMK
forall blk.
LedgerSupportsMempool blk =>
LedgerTables (LedgerState blk) ValuesMK
-> LedgerTables (LedgerState blk) KeysMK
-> TickedLedgerState blk DiffMK
-> TickedLedgerState blk ValuesMK
applyMempoolDiffs
                      (Index xs a
-> LedgerTables (LedgerState (HardForkBlock xs)) ValuesMK
-> LedgerTables (LedgerState a) ValuesMK
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 a
idx LedgerTables (LedgerState (HardForkBlock xs)) ValuesMK
vals)
                      (Index xs a
-> LedgerTables (LedgerState (HardForkBlock xs)) KeysMK
-> LedgerTables (LedgerState a) KeysMK
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 a
idx LedgerTables (LedgerState (HardForkBlock xs)) KeysMK
keys)
                      Ticked (LedgerState a) DiffMK
a
            )
            Telescope (K Past) (Current (FlipTickedLedgerState DiffMK)) xs
st

instance CanHardFork xs => TxLimits (HardForkBlock xs) where
  type TxMeasure (HardForkBlock xs) = HardForkTxMeasure xs

  blockCapacityTxMeasure :: forall (mk :: MapKind).
LedgerConfig (HardForkBlock xs)
-> TickedLedgerState (HardForkBlock xs) mk
-> TxMeasure (HardForkBlock xs)
blockCapacityTxMeasure
    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
hardForkState) =
      HardForkState (K (HardForkTxMeasure xs)) xs
-> CollapseTo HardForkState (HardForkTxMeasure xs)
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 (HardForkTxMeasure xs)) xs
 -> CollapseTo HardForkState (HardForkTxMeasure xs))
-> HardForkState (K (HardForkTxMeasure xs)) xs
-> CollapseTo HardForkState (HardForkTxMeasure xs)
forall a b. (a -> b) -> a -> b
$
        Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    Index xs a
    -> WrapPartialLedgerConfig a
    -> FlipTickedLedgerState mk a
    -> K (HardForkTxMeasure xs) a)
-> NP WrapPartialLedgerConfig xs
-> HardForkState (FlipTickedLedgerState mk) xs
-> HardForkState (K (HardForkTxMeasure 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
-> WrapPartialLedgerConfig a
-> FlipTickedLedgerState mk a
-> K (HardForkTxMeasure xs) a
forall a.
SingleEraBlock a =>
Index xs a
-> WrapPartialLedgerConfig a
-> FlipTickedLedgerState mk a
-> K (HardForkTxMeasure xs) a
forall blk (mk :: MapKind).
SingleEraBlock blk =>
Index xs blk
-> WrapPartialLedgerConfig blk
-> FlipTickedLedgerState mk blk
-> K (HardForkTxMeasure xs) blk
aux NP WrapPartialLedgerConfig xs
pcfgs HardForkState (FlipTickedLedgerState mk) xs
hardForkState
     where
      pcfgs :: NP WrapPartialLedgerConfig xs
pcfgs = 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
hardForkState

      aux ::
        SingleEraBlock blk =>
        Index xs blk ->
        WrapPartialLedgerConfig blk ->
        FlipTickedLedgerState mk blk ->
        K (HardForkTxMeasure xs) blk
      aux :: forall blk (mk :: MapKind).
SingleEraBlock blk =>
Index xs blk
-> WrapPartialLedgerConfig blk
-> FlipTickedLedgerState mk blk
-> K (HardForkTxMeasure xs) blk
aux Index xs blk
idx WrapPartialLedgerConfig blk
pcfg FlipTickedLedgerState mk blk
st' =
        HardForkTxMeasure xs -> K (HardForkTxMeasure xs) blk
forall k a (b :: k). a -> K a b
K (HardForkTxMeasure xs -> K (HardForkTxMeasure xs) blk)
-> HardForkTxMeasure xs -> K (HardForkTxMeasure xs) blk
forall a b. (a -> b) -> a -> b
$
          NS WrapTxMeasure xs -> HardForkTxMeasure xs
forall (xs :: [*]).
CanHardFork xs =>
NS WrapTxMeasure xs -> HardForkTxMeasure xs
hardForkInjTxMeasure (NS WrapTxMeasure xs -> HardForkTxMeasure xs)
-> (TxMeasure blk -> NS WrapTxMeasure xs)
-> TxMeasure blk
-> HardForkTxMeasure xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index xs blk -> WrapTxMeasure blk -> NS WrapTxMeasure xs
forall {k} (f :: k -> *) (x :: k) (xs :: [k]).
All Top xs =>
Index xs x -> f x -> NS f xs
injectNS Index xs blk
idx (WrapTxMeasure blk -> NS WrapTxMeasure xs)
-> (TxMeasure blk -> WrapTxMeasure blk)
-> TxMeasure blk
-> NS WrapTxMeasure xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxMeasure blk -> WrapTxMeasure blk
forall blk. TxMeasure blk -> WrapTxMeasure blk
WrapTxMeasure (TxMeasure blk -> HardForkTxMeasure xs)
-> TxMeasure blk -> HardForkTxMeasure xs
forall a b. (a -> b) -> a -> b
$
            LedgerConfig blk -> TickedLedgerState blk mk -> TxMeasure blk
forall blk (mk :: MapKind).
TxLimits blk =>
LedgerConfig blk -> TickedLedgerState blk mk -> TxMeasure blk
forall (mk :: MapKind).
LedgerConfig blk -> TickedLedgerState blk mk -> TxMeasure blk
blockCapacityTxMeasure
              (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
pcfg)
              (FlipTickedLedgerState mk blk -> TickedLedgerState blk mk
forall (mk :: MapKind) blk.
FlipTickedLedgerState mk blk -> Ticked (LedgerState blk) mk
getFlipTickedLedgerState FlipTickedLedgerState mk blk
st')

  txMeasure :: LedgerConfig (HardForkBlock xs)
-> TickedLedgerState (HardForkBlock xs) ValuesMK
-> GenTx (HardForkBlock xs)
-> Except
     (ApplyTxErr (HardForkBlock xs)) (TxMeasure (HardForkBlock xs))
txMeasure
    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 ValuesMK) xs
hardForkState)
    GenTx (HardForkBlock xs)
tx =
      case InPairs InjectTx xs
-> NS GenTx xs
-> HardForkState (FlipTickedLedgerState ValuesMK) xs
-> Either
     (Mismatch GenTx (Current (FlipTickedLedgerState ValuesMK)) xs)
     (HardForkState (Product GenTx (FlipTickedLedgerState ValuesMK)) xs)
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
InPairs InjectTx xs
-> NS GenTx xs
-> HardForkState f xs
-> Either
     (Mismatch GenTx (Current f) xs)
     (HardForkState (Product GenTx f) xs)
matchTx InPairs InjectTx xs
injs (GenTx (HardForkBlock xs) -> NS GenTx xs
forall {xs :: [*]}. GenTx (HardForkBlock xs) -> NS GenTx xs
unwrapTx GenTx (HardForkBlock xs)
tx) HardForkState (FlipTickedLedgerState ValuesMK) xs
hardForkState of
        Left{} -> HardForkTxMeasure xs
-> ExceptT (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs)
forall a. a -> ExceptT (HardForkApplyTxErr xs) Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HardForkTxMeasure xs
forall a. Measure a => a
Measure.zero -- safe b/c the tx will be found invalid
        Right HardForkState (Product GenTx (FlipTickedLedgerState ValuesMK)) xs
pair -> HardForkState
  (K (ExceptT
        (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs)))
  xs
-> CollapseTo
     HardForkState
     (ExceptT (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs))
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 (ExceptT
         (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs)))
   xs
 -> CollapseTo
      HardForkState
      (ExceptT (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs)))
-> HardForkState
     (K (ExceptT
           (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs)))
     xs
-> CollapseTo
     HardForkState
     (ExceptT (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs))
forall a b. (a -> b) -> a -> b
$ Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    Index xs a
    -> WrapLedgerConfig a
    -> Product GenTx (FlipTickedLedgerState ValuesMK) a
    -> K (ExceptT
            (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs))
         a)
-> NP WrapLedgerConfig xs
-> HardForkState
     (Product GenTx (FlipTickedLedgerState ValuesMK)) xs
-> HardForkState
     (K (ExceptT
           (HardForkApplyTxErr xs) Identity (HardForkTxMeasure 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
-> WrapLedgerConfig a
-> Product GenTx (FlipTickedLedgerState ValuesMK) a
-> K (ExceptT
        (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs))
     a
forall a.
SingleEraBlock a =>
Index xs a
-> WrapLedgerConfig a
-> Product GenTx (FlipTickedLedgerState ValuesMK) a
-> K (ExceptT
        (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs))
     a
aux NP WrapLedgerConfig xs
cfgs HardForkState (Product GenTx (FlipTickedLedgerState ValuesMK)) xs
pair
     where
      pcfgs :: NP WrapPartialLedgerConfig xs
pcfgs = 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 ValuesMK) 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 ValuesMK) xs
hardForkState
      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

      unwrapTx :: GenTx (HardForkBlock xs) -> NS GenTx xs
unwrapTx = OneEraGenTx xs -> NS GenTx xs
forall (xs :: [*]). OneEraGenTx xs -> NS GenTx xs
getOneEraGenTx (OneEraGenTx xs -> NS GenTx xs)
-> (GenTx (HardForkBlock xs) -> OneEraGenTx xs)
-> GenTx (HardForkBlock xs)
-> NS GenTx xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx (HardForkBlock xs) -> OneEraGenTx xs
forall (xs :: [*]). GenTx (HardForkBlock xs) -> OneEraGenTx xs
getHardForkGenTx

      injs :: InPairs (InjectPolyTx GenTx) xs
      injs :: InPairs InjectTx xs
injs =
        (forall x y.
 Product2 InjectTx InjectValidatedTx x y -> InjectPolyTx GenTx x y)
-> InPairs (Product2 InjectTx InjectValidatedTx) xs
-> InPairs InjectTx 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 (\(Pair2 InjectPolyTx GenTx x y
injTx InjectValidatedTx x y
_injValidatedTx) -> InjectPolyTx GenTx x y
injTx) (InPairs (Product2 InjectTx InjectValidatedTx) xs
 -> InPairs InjectTx xs)
-> InPairs (Product2 InjectTx InjectValidatedTx) xs
-> InPairs InjectTx xs
forall a b. (a -> b) -> a -> b
$
          NP WrapLedgerConfig xs
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (Product2 InjectTx InjectValidatedTx))
     xs
-> InPairs (Product2 InjectTx InjectValidatedTx) 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 (Product2 InjectTx InjectValidatedTx))
  xs
forall (xs :: [*]).
CanHardFork xs =>
InPairs
  (RequiringBoth
     WrapLedgerConfig (Product2 InjectTx InjectValidatedTx))
  xs
hardForkInjectTxs

      aux ::
        forall blk.
        SingleEraBlock blk =>
        Index xs blk ->
        WrapLedgerConfig blk ->
        (Product GenTx (FlipTickedLedgerState ValuesMK)) blk ->
        K (Except (HardForkApplyTxErr xs) (HardForkTxMeasure xs)) blk
      aux :: forall a.
SingleEraBlock a =>
Index xs a
-> WrapLedgerConfig a
-> Product GenTx (FlipTickedLedgerState ValuesMK) a
-> K (ExceptT
        (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs))
     a
aux Index xs blk
idx WrapLedgerConfig blk
cfg (Pair GenTx blk
tx' FlipTickedLedgerState ValuesMK blk
st') =
        ExceptT (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs)
-> K (ExceptT
        (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs))
     blk
forall k a (b :: k). a -> K a b
K
          (ExceptT (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs)
 -> K (ExceptT
         (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs))
      blk)
-> ExceptT (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs)
-> K (ExceptT
        (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs))
     blk
forall a b. (a -> b) -> a -> b
$ (Either (ApplyTxErr blk) (TxMeasure blk)
 -> Either (HardForkApplyTxErr xs) (HardForkTxMeasure xs))
-> Except (ApplyTxErr blk) (TxMeasure blk)
-> ExceptT (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs)
forall e a e' b.
(Either e a -> Either e' b) -> Except e a -> Except e' b
mapExcept
            ( ( OneEraApplyTxErr xs -> HardForkApplyTxErr xs
forall (xs :: [*]). OneEraApplyTxErr xs -> HardForkApplyTxErr xs
HardForkApplyTxErrFromEra
                  (OneEraApplyTxErr xs -> HardForkApplyTxErr xs)
-> (ApplyTxErr blk -> OneEraApplyTxErr xs)
-> ApplyTxErr blk
-> HardForkApplyTxErr xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS WrapApplyTxErr xs -> OneEraApplyTxErr xs
forall (xs :: [*]). NS WrapApplyTxErr xs -> OneEraApplyTxErr xs
OneEraApplyTxErr
                  (NS WrapApplyTxErr xs -> OneEraApplyTxErr xs)
-> (ApplyTxErr blk -> NS WrapApplyTxErr xs)
-> ApplyTxErr blk
-> OneEraApplyTxErr xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index xs blk -> WrapApplyTxErr blk -> NS WrapApplyTxErr xs
forall {k} (f :: k -> *) (x :: k) (xs :: [k]).
All Top xs =>
Index xs x -> f x -> NS f xs
injectNS Index xs blk
idx
                  (WrapApplyTxErr blk -> NS WrapApplyTxErr xs)
-> (ApplyTxErr blk -> WrapApplyTxErr blk)
-> ApplyTxErr blk
-> NS WrapApplyTxErr xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApplyTxErr blk -> WrapApplyTxErr blk
forall blk. ApplyTxErr blk -> WrapApplyTxErr blk
WrapApplyTxErr
              )
                (ApplyTxErr blk -> HardForkApplyTxErr xs)
-> (TxMeasure blk -> HardForkTxMeasure xs)
-> Either (ApplyTxErr blk) (TxMeasure blk)
-> Either (HardForkApplyTxErr xs) (HardForkTxMeasure xs)
forall b c b' c'.
(b -> c) -> (b' -> c') -> Either b b' -> Either c c'
forall (a :: MapKind) b c b' c'.
ArrowChoice a =>
a b c -> a b' c' -> a (Either b b') (Either c c')
+++ (NS WrapTxMeasure xs -> HardForkTxMeasure xs
forall (xs :: [*]).
CanHardFork xs =>
NS WrapTxMeasure xs -> HardForkTxMeasure xs
hardForkInjTxMeasure (NS WrapTxMeasure xs -> HardForkTxMeasure xs)
-> (TxMeasure blk -> NS WrapTxMeasure xs)
-> TxMeasure blk
-> HardForkTxMeasure xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index xs blk -> WrapTxMeasure blk -> NS WrapTxMeasure xs
forall {k} (f :: k -> *) (x :: k) (xs :: [k]).
All Top xs =>
Index xs x -> f x -> NS f xs
injectNS Index xs blk
idx (WrapTxMeasure blk -> NS WrapTxMeasure xs)
-> (TxMeasure blk -> WrapTxMeasure blk)
-> TxMeasure blk
-> NS WrapTxMeasure xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxMeasure blk -> WrapTxMeasure blk
forall blk. TxMeasure blk -> WrapTxMeasure blk
WrapTxMeasure)
            )
          (Except (ApplyTxErr blk) (TxMeasure blk)
 -> ExceptT (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs))
-> Except (ApplyTxErr blk) (TxMeasure blk)
-> ExceptT (HardForkApplyTxErr xs) Identity (HardForkTxMeasure xs)
forall a b. (a -> b) -> a -> b
$ LedgerConfig blk
-> TickedLedgerState blk ValuesMK
-> GenTx blk
-> Except (ApplyTxErr blk) (TxMeasure blk)
forall blk.
TxLimits blk =>
LedgerConfig blk
-> TickedLedgerState blk ValuesMK
-> GenTx blk
-> Except (ApplyTxErr blk) (TxMeasure blk)
txMeasure
            (WrapLedgerConfig blk -> LedgerConfig blk
forall blk. WrapLedgerConfig blk -> LedgerConfig blk
unwrapLedgerConfig WrapLedgerConfig blk
cfg)
            (FlipTickedLedgerState ValuesMK blk
-> TickedLedgerState blk ValuesMK
forall (mk :: MapKind) blk.
FlipTickedLedgerState mk blk -> Ticked (LedgerState blk) mk
getFlipTickedLedgerState FlipTickedLedgerState ValuesMK blk
st')
            GenTx blk
tx'

-- | A private type used only to clarify the parameterization of 'applyHelper'
data ApplyHelperMode :: (Type -> Type) -> Type where
  ModeApply :: ApplyHelperMode GenTx
  ModeReapply :: ApplyHelperMode WrapValidatedGenTx

-- | 'applyHelper' has to return one of these, depending on the apply mode used.
type family ApplyMK k where
  ApplyMK (ApplyHelperMode GenTx) = DiffMK
  ApplyMK (ApplyHelperMode WrapValidatedGenTx) = TrackingMK

-- | A private type used only to clarify the definition of 'applyHelper'
data ApplyResult xs txIn blk = ApplyResult
  { forall (xs :: [*]) (txIn :: * -> *) blk.
ApplyResult xs txIn blk
-> Ticked (LedgerState blk) (ApplyMK (ApplyHelperMode txIn))
arState :: Ticked (LedgerState blk) (ApplyMK (ApplyHelperMode txIn))
  , forall (xs :: [*]) (txIn :: * -> *) blk.
ApplyResult xs txIn blk -> Validated (GenTx (HardForkBlock xs))
arValidatedTx :: Validated (GenTx (HardForkBlock xs))
  }

-- | The shared logic between 'applyTx' and 'reapplyTx' for 'HardForkBlock'
--
-- The @txIn@ variable is 'GenTx' or 'WrapValidatedGenTx', respectively. See
-- 'ApplyHelperMode'.
applyHelper ::
  forall xs txIn.
  CanHardFork xs =>
  ApplyHelperMode txIn ->
  ComputeDiffs ->
  LedgerConfig (HardForkBlock xs) ->
  WhetherToIntervene ->
  SlotNo ->
  txIn (HardForkBlock xs) ->
  TickedLedgerState (HardForkBlock xs) ValuesMK ->
  Except
    (HardForkApplyTxErr xs)
    ( TickedLedgerState (HardForkBlock xs) (ApplyMK (ApplyHelperMode txIn))
    , Validated (GenTx (HardForkBlock xs))
    )
applyHelper :: forall (xs :: [*]) (txIn :: * -> *).
CanHardFork xs =>
ApplyHelperMode txIn
-> ComputeDiffs
-> LedgerConfig (HardForkBlock xs)
-> WhetherToIntervene
-> SlotNo
-> txIn (HardForkBlock xs)
-> TickedLedgerState (HardForkBlock xs) ValuesMK
-> Except
     (HardForkApplyTxErr xs)
     (TickedLedgerState
        (HardForkBlock xs) (ApplyMK (ApplyHelperMode txIn)),
      Validated (GenTx (HardForkBlock xs)))
applyHelper
  ApplyHelperMode txIn
mode
  ComputeDiffs
doDiffs
  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
..}
  WhetherToIntervene
wti
  SlotNo
slot
  txIn (HardForkBlock xs)
tx
  (TickedHardForkLedgerState TransitionInfo
transition HardForkState (FlipTickedLedgerState ValuesMK) xs
hardForkState) =
    case InPairs (InjectPolyTx txIn) xs
-> NS txIn xs
-> HardForkState (FlipTickedLedgerState ValuesMK) xs
-> Either
     (Mismatch txIn (Current (FlipTickedLedgerState ValuesMK)) xs)
     (HardForkState (Product txIn (FlipTickedLedgerState ValuesMK)) xs)
forall (xs :: [*]) (tx :: * -> *) (f :: * -> *).
SListI xs =>
InPairs (InjectPolyTx tx) xs
-> NS tx xs
-> HardForkState f xs
-> Either
     (Mismatch tx (Current f) xs) (HardForkState (Product tx f) xs)
matchPolyTx InPairs (InjectPolyTx txIn) xs
injs (txIn (HardForkBlock xs) -> NS txIn xs
modeGetTx txIn (HardForkBlock xs)
tx) HardForkState (FlipTickedLedgerState ValuesMK) xs
hardForkState of
      Left Mismatch txIn (Current (FlipTickedLedgerState ValuesMK)) xs
mismatch ->
        HardForkApplyTxErr xs
-> Except
     (HardForkApplyTxErr xs)
     (TickedLedgerState
        (HardForkBlock xs) (ApplyMK (ApplyHelperMode txIn)),
      Validated (GenTx (HardForkBlock xs)))
forall a.
HardForkApplyTxErr xs -> ExceptT (HardForkApplyTxErr xs) Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (HardForkApplyTxErr xs
 -> Except
      (HardForkApplyTxErr xs)
      (TickedLedgerState
         (HardForkBlock xs) (ApplyMK (ApplyHelperMode txIn)),
       Validated (GenTx (HardForkBlock xs))))
-> HardForkApplyTxErr xs
-> Except
     (HardForkApplyTxErr xs)
     (TickedLedgerState
        (HardForkBlock xs) (ApplyMK (ApplyHelperMode txIn)),
      Validated (GenTx (HardForkBlock xs)))
forall a b. (a -> b) -> a -> b
$
          MismatchEraInfo xs -> HardForkApplyTxErr xs
forall (xs :: [*]). MismatchEraInfo xs -> HardForkApplyTxErr xs
HardForkApplyTxErrWrongEra (MismatchEraInfo xs -> HardForkApplyTxErr xs)
-> (Mismatch SingleEraInfo LedgerEraInfo xs -> MismatchEraInfo xs)
-> Mismatch SingleEraInfo LedgerEraInfo xs
-> HardForkApplyTxErr 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 -> HardForkApplyTxErr xs)
-> Mismatch SingleEraInfo LedgerEraInfo xs -> HardForkApplyTxErr xs
forall a b. (a -> b) -> a -> b
$
            Proxy SingleEraBlock
-> (forall x. SingleEraBlock x => txIn x -> SingleEraInfo x)
-> (forall x.
    SingleEraBlock x =>
    Current (FlipTickedLedgerState ValuesMK) x -> LedgerEraInfo x)
-> Mismatch txIn (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 txIn x -> SingleEraInfo x
forall x. SingleEraBlock x => txIn 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 txIn (Current (FlipTickedLedgerState ValuesMK)) xs
mismatch
      Right HardForkState (Product txIn (FlipTickedLedgerState ValuesMK)) xs
matched ->
        -- We are updating the ticked ledger state by applying a transaction,
        -- but for the HFC that ledger state contains a bundled
        -- 'TransitionInfo'. We don't change that 'TransitionInfo' here, which
        -- requires justification. Three cases:
        --
        -- o 'TransitionUnknown'. Transitions become known only when the
        --    transaction that confirms them becomes stable, so this cannot
        --    happen simply by applying a transaction. In this case we record
        --    the tip of the ledger, which is also not changed halfway a block.
        -- o 'TransitionKnown'. In this case, we record the 'EpochNo' of the
        --    epoch that starts the new era; this information similarly won't
        --    halfway a block (it can only change, in fact, when we do transition
        --    to that new era).
        -- o 'TransitionImpossible'. Two subcases: we are in the final era (in
        --    which we will remain to be) or we are forecasting, which is not
        --    applicable here.
        do
          result <-
            HardForkState
  (ExceptT (HardForkApplyTxErr xs) Identity :.: ApplyResult xs txIn)
  xs
-> ExceptT
     (HardForkApplyTxErr xs)
     Identity
     (HardForkState (ApplyResult xs txIn) 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 (HardForkApplyTxErr xs) Identity :.: ApplyResult xs txIn)
   xs
 -> ExceptT
      (HardForkApplyTxErr xs)
      Identity
      (HardForkState (ApplyResult xs txIn) xs))
-> HardForkState
     (ExceptT (HardForkApplyTxErr xs) Identity :.: ApplyResult xs txIn)
     xs
-> ExceptT
     (HardForkApplyTxErr xs)
     Identity
     (HardForkState (ApplyResult xs txIn) xs)
forall a b. (a -> b) -> a -> b
$
              Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    Index xs a
    -> WrapLedgerConfig a
    -> Product txIn (FlipTickedLedgerState ValuesMK) a
    -> (:.:)
         (ExceptT (HardForkApplyTxErr xs) Identity) (ApplyResult xs txIn) a)
-> NP WrapLedgerConfig xs
-> HardForkState (Product txIn (FlipTickedLedgerState ValuesMK)) xs
-> HardForkState
     (ExceptT (HardForkApplyTxErr xs) Identity :.: ApplyResult xs txIn)
     xs
forall {k} (h :: (k -> *) -> [k] -> *) (c :: k -> Constraint)
       (xs :: [k]) (proxy :: (k -> Constraint) -> *) (f1 :: k -> *)
       (f2 :: k -> *) (f3 :: k -> *).
(HAp h, All c xs, Prod h ~ NP) =>
proxy c
-> (forall (a :: k). c a => Index xs a -> f1 a -> f2 a -> f3 a)
-> NP f1 xs
-> h f2 xs
-> h f3 xs
hcizipWith Proxy SingleEraBlock
proxySingle Index xs a
-> WrapLedgerConfig a
-> Product txIn (FlipTickedLedgerState ValuesMK) a
-> (:.:)
     (ExceptT (HardForkApplyTxErr xs) Identity) (ApplyResult xs txIn) a
forall a.
SingleEraBlock a =>
Index xs a
-> WrapLedgerConfig a
-> Product txIn (FlipTickedLedgerState ValuesMK) a
-> (:.:)
     (ExceptT (HardForkApplyTxErr xs) Identity) (ApplyResult xs txIn) a
modeApplyCurrent NP WrapLedgerConfig xs
cfgs HardForkState (Product txIn (FlipTickedLedgerState ValuesMK)) xs
matched
          let _ = result :: State.HardForkState (ApplyResult xs txIn) xs

              st' :: State.HardForkState (FlipTickedLedgerState (ApplyMK (ApplyHelperMode txIn))) xs
              st' = (Ticked (LedgerState a) (ApplyMK (ApplyHelperMode txIn))
-> FlipTickedLedgerState (ApplyMK (ApplyHelperMode txIn)) a
forall (mk :: MapKind) blk.
Ticked (LedgerState blk) mk -> FlipTickedLedgerState mk blk
FlipTickedLedgerState (Ticked (LedgerState a) (ApplyMK (ApplyHelperMode txIn))
 -> FlipTickedLedgerState (ApplyMK (ApplyHelperMode txIn)) a)
-> (ApplyResult xs txIn a
    -> Ticked (LedgerState a) (ApplyMK (ApplyHelperMode txIn)))
-> ApplyResult xs txIn a
-> FlipTickedLedgerState (ApplyMK (ApplyHelperMode txIn)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApplyResult xs txIn a
-> Ticked (LedgerState a) (ApplyMK (ApplyHelperMode txIn))
forall (xs :: [*]) (txIn :: * -> *) blk.
ApplyResult xs txIn blk
-> Ticked (LedgerState blk) (ApplyMK (ApplyHelperMode txIn))
arState) (forall {a}.
 ApplyResult xs txIn a
 -> FlipTickedLedgerState (ApplyMK (ApplyHelperMode txIn)) a)
-> HardForkState (ApplyResult xs txIn) xs
-> HardForkState
     (FlipTickedLedgerState (ApplyMK (ApplyHelperMode txIn))) 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` HardForkState (ApplyResult xs txIn) xs
result

              vtx :: Validated (GenTx (HardForkBlock xs))
              vtx = HardForkState (K (Validated (GenTx (HardForkBlock xs)))) xs
-> CollapseTo HardForkState (Validated (GenTx (HardForkBlock xs)))
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 (Validated (GenTx (HardForkBlock xs)))) xs
 -> CollapseTo HardForkState (Validated (GenTx (HardForkBlock xs))))
-> HardForkState (K (Validated (GenTx (HardForkBlock xs)))) xs
-> CollapseTo HardForkState (Validated (GenTx (HardForkBlock xs)))
forall a b. (a -> b) -> a -> b
$ (Validated (GenTx (HardForkBlock xs))
-> K (Validated (GenTx (HardForkBlock xs))) a
forall k a (b :: k). a -> K a b
K (Validated (GenTx (HardForkBlock xs))
 -> K (Validated (GenTx (HardForkBlock xs))) a)
-> (ApplyResult xs txIn a -> Validated (GenTx (HardForkBlock xs)))
-> ApplyResult xs txIn a
-> K (Validated (GenTx (HardForkBlock xs))) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApplyResult xs txIn a -> Validated (GenTx (HardForkBlock xs))
forall (xs :: [*]) (txIn :: * -> *) blk.
ApplyResult xs txIn blk -> Validated (GenTx (HardForkBlock xs))
arValidatedTx) (forall {a}.
 ApplyResult xs txIn a
 -> K (Validated (GenTx (HardForkBlock xs))) a)
-> HardForkState (ApplyResult xs txIn) xs
-> HardForkState (K (Validated (GenTx (HardForkBlock xs)))) 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` HardForkState (ApplyResult xs txIn) xs
result

          return (TickedHardForkLedgerState transition st', vtx)
   where
    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
    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
        Shape xs
hardForkLedgerConfigShape
        TransitionInfo
transition
        HardForkState (FlipTickedLedgerState ValuesMK) xs
hardForkState

    injs :: InPairs (InjectPolyTx txIn) xs
    injs :: InPairs (InjectPolyTx txIn) xs
injs =
      (forall x y.
 Product2 InjectTx InjectValidatedTx x y -> InjectPolyTx txIn x y)
-> InPairs (Product2 InjectTx InjectValidatedTx) xs
-> InPairs (InjectPolyTx txIn) 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
        Product2 InjectTx InjectValidatedTx x y -> InjectPolyTx txIn x y
forall x y.
Product2 InjectTx InjectValidatedTx x y -> InjectPolyTx txIn x y
modeGetInjection
        (NP WrapLedgerConfig xs
-> InPairs
     (RequiringBoth
        WrapLedgerConfig (Product2 InjectTx InjectValidatedTx))
     xs
-> InPairs (Product2 InjectTx InjectValidatedTx) 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 (Product2 InjectTx InjectValidatedTx))
  xs
forall (xs :: [*]).
CanHardFork xs =>
InPairs
  (RequiringBoth
     WrapLedgerConfig (Product2 InjectTx InjectValidatedTx))
  xs
hardForkInjectTxs)

    modeGetTx :: txIn (HardForkBlock xs) -> NS txIn xs
    modeGetTx :: txIn (HardForkBlock xs) -> NS txIn xs
modeGetTx = case ApplyHelperMode txIn
mode of
      ApplyHelperMode txIn
ModeApply ->
        OneEraGenTx xs -> NS txIn xs
OneEraGenTx xs -> NS GenTx xs
forall (xs :: [*]). OneEraGenTx xs -> NS GenTx xs
getOneEraGenTx
          (OneEraGenTx xs -> NS txIn xs)
-> (txIn (HardForkBlock xs) -> OneEraGenTx xs)
-> txIn (HardForkBlock xs)
-> NS txIn xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. txIn (HardForkBlock xs) -> OneEraGenTx xs
GenTx (HardForkBlock xs) -> OneEraGenTx xs
forall (xs :: [*]). GenTx (HardForkBlock xs) -> OneEraGenTx xs
getHardForkGenTx
      ApplyHelperMode txIn
ModeReapply ->
        OneEraValidatedGenTx xs -> NS txIn xs
OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs
forall (xs :: [*]).
OneEraValidatedGenTx xs -> NS WrapValidatedGenTx xs
getOneEraValidatedGenTx
          (OneEraValidatedGenTx xs -> NS txIn xs)
-> (txIn (HardForkBlock xs) -> OneEraValidatedGenTx xs)
-> txIn (HardForkBlock xs)
-> NS txIn xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx (HardForkBlock xs)) -> OneEraValidatedGenTx xs
forall (xs :: [*]).
Validated (GenTx (HardForkBlock xs)) -> OneEraValidatedGenTx xs
getHardForkValidatedGenTx
          (Validated (GenTx (HardForkBlock xs)) -> OneEraValidatedGenTx xs)
-> (txIn (HardForkBlock xs)
    -> Validated (GenTx (HardForkBlock xs)))
-> txIn (HardForkBlock xs)
-> OneEraValidatedGenTx xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. txIn (HardForkBlock xs) -> Validated (GenTx (HardForkBlock xs))
WrapValidatedGenTx (HardForkBlock xs)
-> Validated (GenTx (HardForkBlock xs))
forall blk. WrapValidatedGenTx blk -> Validated (GenTx blk)
unwrapValidatedGenTx

    modeGetInjection ::
      forall blk1 blk2.
      Product2 InjectTx InjectValidatedTx blk1 blk2 ->
      InjectPolyTx txIn blk1 blk2
    modeGetInjection :: forall x y.
Product2 InjectTx InjectValidatedTx x y -> InjectPolyTx txIn x y
modeGetInjection (Pair2 InjectTx blk1 blk2
injTx InjectValidatedTx blk1 blk2
injValidatedTx) = case ApplyHelperMode txIn
mode of
      ApplyHelperMode txIn
ModeApply -> InjectPolyTx txIn blk1 blk2
InjectTx blk1 blk2
injTx
      ApplyHelperMode txIn
ModeReapply -> InjectPolyTx txIn blk1 blk2
InjectValidatedTx blk1 blk2
injValidatedTx

    modeApplyCurrent ::
      forall blk.
      SingleEraBlock blk =>
      Index xs blk ->
      WrapLedgerConfig blk ->
      Product txIn (FlipTickedLedgerState ValuesMK) blk ->
      ( Except (HardForkApplyTxErr xs)
          :.: ApplyResult xs txIn
      )
        blk
    modeApplyCurrent :: forall a.
SingleEraBlock a =>
Index xs a
-> WrapLedgerConfig a
-> Product txIn (FlipTickedLedgerState ValuesMK) a
-> (:.:)
     (ExceptT (HardForkApplyTxErr xs) Identity) (ApplyResult xs txIn) a
modeApplyCurrent Index xs blk
index WrapLedgerConfig blk
cfg (Pair txIn blk
tx' (FlipTickedLedgerState Ticked (LedgerState blk) ValuesMK
st)) =
      Except (HardForkApplyTxErr xs) (ApplyResult xs txIn blk)
-> (:.:)
     (ExceptT (HardForkApplyTxErr xs) Identity)
     (ApplyResult xs txIn)
     blk
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (Except (HardForkApplyTxErr xs) (ApplyResult xs txIn blk)
 -> (:.:)
      (ExceptT (HardForkApplyTxErr xs) Identity)
      (ApplyResult xs txIn)
      blk)
-> Except (HardForkApplyTxErr xs) (ApplyResult xs txIn blk)
-> (:.:)
     (ExceptT (HardForkApplyTxErr xs) Identity)
     (ApplyResult xs txIn)
     blk
forall a b. (a -> b) -> a -> b
$
        (ApplyTxErr blk -> HardForkApplyTxErr xs)
-> Except (ApplyTxErr blk) (ApplyResult xs txIn blk)
-> Except (HardForkApplyTxErr xs) (ApplyResult xs txIn blk)
forall e e' a. (e -> e') -> Except e a -> Except e' a
withExcept (Index xs blk -> ApplyTxErr blk -> HardForkApplyTxErr xs
forall (xs :: [*]) blk.
SListI xs =>
Index xs blk -> ApplyTxErr blk -> HardForkApplyTxErr xs
injectApplyTxErr Index xs blk
index) (Except (ApplyTxErr blk) (ApplyResult xs txIn blk)
 -> Except (HardForkApplyTxErr xs) (ApplyResult xs txIn blk))
-> Except (ApplyTxErr blk) (ApplyResult xs txIn blk)
-> Except (HardForkApplyTxErr xs) (ApplyResult xs txIn blk)
forall a b. (a -> b) -> a -> b
$
          do
            let lcfg :: LedgerConfig blk
lcfg = WrapLedgerConfig blk -> LedgerConfig blk
forall blk. WrapLedgerConfig blk -> LedgerConfig blk
unwrapLedgerConfig WrapLedgerConfig blk
cfg
            case ApplyHelperMode txIn
mode of
              ApplyHelperMode txIn
ModeApply -> do
                (st', vtx) <- LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> Ticked (LedgerState blk) ValuesMK
-> ExceptT
     (ApplyTxErr blk)
     Identity
     (TickedLedgerState blk DiffMK, Validated (GenTx blk))
forall blk.
LedgerSupportsMempool blk =>
LedgerConfig blk
-> WhetherToIntervene
-> SlotNo
-> GenTx blk
-> TickedLedgerState blk ValuesMK
-> Except
     (ApplyTxErr blk)
     (TickedLedgerState blk DiffMK, Validated (GenTx blk))
applyTx LedgerConfig blk
lcfg WhetherToIntervene
wti SlotNo
slot txIn blk
GenTx blk
tx' Ticked (LedgerState blk) ValuesMK
st
                pure
                  ApplyResult
                    { arValidatedTx = injectValidatedGenTx index vtx
                    , arState = st'
                    }
              ApplyHelperMode txIn
ModeReapply -> do
                let vtx' :: Validated (GenTx blk)
vtx' = WrapValidatedGenTx blk -> Validated (GenTx blk)
forall blk. WrapValidatedGenTx blk -> Validated (GenTx blk)
unwrapValidatedGenTx txIn blk
WrapValidatedGenTx blk
tx'
                st' <- ComputeDiffs
-> LedgerConfig blk
-> SlotNo
-> Validated (GenTx blk)
-> Ticked (LedgerState blk) ValuesMK
-> ExceptT
     (ApplyTxErr blk) Identity (TickedLedgerState blk TrackingMK)
forall blk.
(LedgerSupportsMempool blk, HasCallStack) =>
ComputeDiffs
-> LedgerConfig blk
-> SlotNo
-> Validated (GenTx blk)
-> TickedLedgerState blk ValuesMK
-> Except (ApplyTxErr blk) (TickedLedgerState blk TrackingMK)
reapplyTx ComputeDiffs
doDiffs LedgerConfig blk
lcfg SlotNo
slot Validated (GenTx blk)
vtx' Ticked (LedgerState blk) ValuesMK
st
                -- provide the given transaction, which was already validated
                pure
                  ApplyResult
                    { arValidatedTx = injectValidatedGenTx index vtx'
                    , arState = st'
                    }

newtype instance TxId (GenTx (HardForkBlock xs)) = HardForkGenTxId
  { forall (xs :: [*]).
TxId (GenTx (HardForkBlock xs)) -> OneEraGenTxId xs
getHardForkGenTxId :: OneEraGenTxId xs
  }
  deriving (TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Bool
(TxId (GenTx (HardForkBlock xs))
 -> TxId (GenTx (HardForkBlock xs)) -> Bool)
-> (TxId (GenTx (HardForkBlock xs))
    -> TxId (GenTx (HardForkBlock xs)) -> Bool)
-> Eq (TxId (GenTx (HardForkBlock xs)))
forall (xs :: [*]).
CanHardFork xs =>
TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall (xs :: [*]).
CanHardFork xs =>
TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Bool
== :: TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Bool
$c/= :: forall (xs :: [*]).
CanHardFork xs =>
TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Bool
/= :: TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Bool
Eq, (forall x.
 TxId (GenTx (HardForkBlock xs))
 -> Rep (TxId (GenTx (HardForkBlock xs))) x)
-> (forall x.
    Rep (TxId (GenTx (HardForkBlock xs))) x
    -> TxId (GenTx (HardForkBlock xs)))
-> Generic (TxId (GenTx (HardForkBlock xs)))
forall (xs :: [*]) x.
Rep (TxId (GenTx (HardForkBlock xs))) x
-> TxId (GenTx (HardForkBlock xs))
forall (xs :: [*]) x.
TxId (GenTx (HardForkBlock xs))
-> Rep (TxId (GenTx (HardForkBlock xs))) x
forall x.
Rep (TxId (GenTx (HardForkBlock xs))) x
-> TxId (GenTx (HardForkBlock xs))
forall x.
TxId (GenTx (HardForkBlock xs))
-> Rep (TxId (GenTx (HardForkBlock xs))) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (xs :: [*]) x.
TxId (GenTx (HardForkBlock xs))
-> Rep (TxId (GenTx (HardForkBlock xs))) x
from :: forall x.
TxId (GenTx (HardForkBlock xs))
-> Rep (TxId (GenTx (HardForkBlock xs))) x
$cto :: forall (xs :: [*]) x.
Rep (TxId (GenTx (HardForkBlock xs))) x
-> TxId (GenTx (HardForkBlock xs))
to :: forall x.
Rep (TxId (GenTx (HardForkBlock xs))) x
-> TxId (GenTx (HardForkBlock xs))
Generic, Eq (TxId (GenTx (HardForkBlock xs)))
Eq (TxId (GenTx (HardForkBlock xs))) =>
(TxId (GenTx (HardForkBlock xs))
 -> TxId (GenTx (HardForkBlock xs)) -> Ordering)
-> (TxId (GenTx (HardForkBlock xs))
    -> TxId (GenTx (HardForkBlock xs)) -> Bool)
-> (TxId (GenTx (HardForkBlock xs))
    -> TxId (GenTx (HardForkBlock xs)) -> Bool)
-> (TxId (GenTx (HardForkBlock xs))
    -> TxId (GenTx (HardForkBlock xs)) -> Bool)
-> (TxId (GenTx (HardForkBlock xs))
    -> TxId (GenTx (HardForkBlock xs)) -> Bool)
-> (TxId (GenTx (HardForkBlock xs))
    -> TxId (GenTx (HardForkBlock xs))
    -> TxId (GenTx (HardForkBlock xs)))
-> (TxId (GenTx (HardForkBlock xs))
    -> TxId (GenTx (HardForkBlock xs))
    -> TxId (GenTx (HardForkBlock xs)))
-> Ord (TxId (GenTx (HardForkBlock xs)))
TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Bool
TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Ordering
TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs))
forall (xs :: [*]).
CanHardFork xs =>
Eq (TxId (GenTx (HardForkBlock xs)))
forall (xs :: [*]).
CanHardFork xs =>
TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Bool
forall (xs :: [*]).
CanHardFork xs =>
TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Ordering
forall (xs :: [*]).
CanHardFork xs =>
TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs))
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: forall (xs :: [*]).
CanHardFork xs =>
TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Ordering
compare :: TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Ordering
$c< :: forall (xs :: [*]).
CanHardFork xs =>
TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Bool
< :: TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Bool
$c<= :: forall (xs :: [*]).
CanHardFork xs =>
TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Bool
<= :: TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Bool
$c> :: forall (xs :: [*]).
CanHardFork xs =>
TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Bool
> :: TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Bool
$c>= :: forall (xs :: [*]).
CanHardFork xs =>
TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Bool
>= :: TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs)) -> Bool
$cmax :: forall (xs :: [*]).
CanHardFork xs =>
TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs))
max :: TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs))
$cmin :: forall (xs :: [*]).
CanHardFork xs =>
TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs))
min :: TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs))
-> TxId (GenTx (HardForkBlock xs))
Ord, Int -> TxId (GenTx (HardForkBlock xs)) -> ShowS
[TxId (GenTx (HardForkBlock xs))] -> ShowS
TxId (GenTx (HardForkBlock xs)) -> String
(Int -> TxId (GenTx (HardForkBlock xs)) -> ShowS)
-> (TxId (GenTx (HardForkBlock xs)) -> String)
-> ([TxId (GenTx (HardForkBlock xs))] -> ShowS)
-> Show (TxId (GenTx (HardForkBlock xs)))
forall (xs :: [*]).
CanHardFork xs =>
Int -> TxId (GenTx (HardForkBlock xs)) -> ShowS
forall (xs :: [*]).
CanHardFork xs =>
[TxId (GenTx (HardForkBlock xs))] -> ShowS
forall (xs :: [*]).
CanHardFork xs =>
TxId (GenTx (HardForkBlock xs)) -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (xs :: [*]).
CanHardFork xs =>
Int -> TxId (GenTx (HardForkBlock xs)) -> ShowS
showsPrec :: Int -> TxId (GenTx (HardForkBlock xs)) -> ShowS
$cshow :: forall (xs :: [*]).
CanHardFork xs =>
TxId (GenTx (HardForkBlock xs)) -> String
show :: TxId (GenTx (HardForkBlock xs)) -> String
$cshowList :: forall (xs :: [*]).
CanHardFork xs =>
[TxId (GenTx (HardForkBlock xs))] -> ShowS
showList :: [TxId (GenTx (HardForkBlock xs))] -> ShowS
Show)
  deriving anyclass Context -> TxId (GenTx (HardForkBlock xs)) -> IO (Maybe ThunkInfo)
Proxy (TxId (GenTx (HardForkBlock xs))) -> String
(Context
 -> TxId (GenTx (HardForkBlock xs)) -> IO (Maybe ThunkInfo))
-> (Context
    -> TxId (GenTx (HardForkBlock xs)) -> IO (Maybe ThunkInfo))
-> (Proxy (TxId (GenTx (HardForkBlock xs))) -> String)
-> NoThunks (TxId (GenTx (HardForkBlock xs)))
forall (xs :: [*]).
CanHardFork xs =>
Context -> TxId (GenTx (HardForkBlock xs)) -> IO (Maybe ThunkInfo)
forall (xs :: [*]).
CanHardFork xs =>
Proxy (TxId (GenTx (HardForkBlock 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 -> TxId (GenTx (HardForkBlock xs)) -> IO (Maybe ThunkInfo)
noThunks :: Context -> TxId (GenTx (HardForkBlock xs)) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context -> TxId (GenTx (HardForkBlock xs)) -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TxId (GenTx (HardForkBlock xs)) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (xs :: [*]).
CanHardFork xs =>
Proxy (TxId (GenTx (HardForkBlock xs))) -> String
showTypeOf :: Proxy (TxId (GenTx (HardForkBlock xs))) -> String
NoThunks

instance Typeable xs => ShowProxy (TxId (GenTx (HardForkBlock xs)))

instance CanHardFork xs => HasTxId (GenTx (HardForkBlock xs)) where
  txId :: GenTx (HardForkBlock xs) -> TxId (GenTx (HardForkBlock xs))
txId =
    OneEraGenTxId xs -> TxId (GenTx (HardForkBlock xs))
forall (xs :: [*]).
OneEraGenTxId xs -> TxId (GenTx (HardForkBlock xs))
HardForkGenTxId
      (OneEraGenTxId xs -> TxId (GenTx (HardForkBlock xs)))
-> (GenTx (HardForkBlock xs) -> OneEraGenTxId xs)
-> GenTx (HardForkBlock xs)
-> TxId (GenTx (HardForkBlock xs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS WrapGenTxId xs -> OneEraGenTxId xs
forall (xs :: [*]). NS WrapGenTxId xs -> OneEraGenTxId xs
OneEraGenTxId
      (NS WrapGenTxId xs -> OneEraGenTxId xs)
-> (GenTx (HardForkBlock xs) -> NS WrapGenTxId xs)
-> GenTx (HardForkBlock xs)
-> OneEraGenTxId xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy SingleEraBlock
-> (forall a. SingleEraBlock a => GenTx a -> WrapGenTxId a)
-> NS GenTx xs
-> NS WrapGenTxId 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 (GenTxId a -> WrapGenTxId a
forall blk. GenTxId blk -> WrapGenTxId blk
WrapGenTxId (GenTxId a -> WrapGenTxId a)
-> (GenTx a -> GenTxId a) -> GenTx a -> WrapGenTxId a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx a -> GenTxId a
forall tx. HasTxId tx => tx -> TxId tx
txId)
      (NS GenTx xs -> NS WrapGenTxId xs)
-> (GenTx (HardForkBlock xs) -> NS GenTx xs)
-> GenTx (HardForkBlock xs)
-> NS WrapGenTxId xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneEraGenTx xs -> NS GenTx xs
forall (xs :: [*]). OneEraGenTx xs -> NS GenTx xs
getOneEraGenTx
      (OneEraGenTx xs -> NS GenTx xs)
-> (GenTx (HardForkBlock xs) -> OneEraGenTx xs)
-> GenTx (HardForkBlock xs)
-> NS GenTx xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenTx (HardForkBlock xs) -> OneEraGenTx xs
forall (xs :: [*]). GenTx (HardForkBlock xs) -> OneEraGenTx xs
getHardForkGenTx

{-------------------------------------------------------------------------------
  HasTxs

  This is not required by consensus itself, but is required by RunNode.
-------------------------------------------------------------------------------}

instance All HasTxs xs => HasTxs (HardForkBlock xs) where
  extractTxs :: HardForkBlock xs -> [GenTx (HardForkBlock xs)]
extractTxs =
    NS (K [GenTx (HardForkBlock xs)]) xs -> [GenTx (HardForkBlock xs)]
NS (K [GenTx (HardForkBlock xs)]) xs
-> CollapseTo NS [GenTx (HardForkBlock 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 [GenTx (HardForkBlock xs)]) xs
 -> [GenTx (HardForkBlock xs)])
-> (HardForkBlock xs -> NS (K [GenTx (HardForkBlock xs)]) xs)
-> HardForkBlock xs
-> [GenTx (HardForkBlock xs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy HasTxs
-> (forall a.
    HasTxs a =>
    Index xs a -> I a -> K [GenTx (HardForkBlock xs)] a)
-> NS I xs
-> NS (K [GenTx (HardForkBlock 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 (forall {k} (t :: k). Proxy t
forall (t :: * -> Constraint). Proxy t
Proxy @HasTxs) Index xs a -> I a -> K [GenTx (HardForkBlock xs)] a
forall a.
HasTxs a =>
Index xs a -> I a -> K [GenTx (HardForkBlock xs)] a
aux
      (NS I xs -> NS (K [GenTx (HardForkBlock xs)]) xs)
-> (HardForkBlock xs -> NS I xs)
-> HardForkBlock xs
-> NS (K [GenTx (HardForkBlock xs)]) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OneEraBlock xs -> NS I xs
forall (xs :: [*]). OneEraBlock xs -> NS I xs
getOneEraBlock
      (OneEraBlock xs -> NS I xs)
-> (HardForkBlock xs -> OneEraBlock xs)
-> HardForkBlock xs
-> NS I xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkBlock xs -> OneEraBlock xs
forall (xs :: [*]). HardForkBlock xs -> OneEraBlock xs
getHardForkBlock
   where
    aux ::
      HasTxs blk =>
      Index xs blk ->
      I blk ->
      K [GenTx (HardForkBlock xs)] blk
    aux :: forall a.
HasTxs a =>
Index xs a -> I a -> K [GenTx (HardForkBlock xs)] a
aux Index xs blk
index = [GenTx (HardForkBlock xs)] -> K [GenTx (HardForkBlock xs)] blk
forall k a (b :: k). a -> K a b
K ([GenTx (HardForkBlock xs)] -> K [GenTx (HardForkBlock xs)] blk)
-> (I blk -> [GenTx (HardForkBlock xs)])
-> I blk
-> K [GenTx (HardForkBlock xs)] blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenTx blk -> GenTx (HardForkBlock xs))
-> [GenTx blk] -> [GenTx (HardForkBlock xs)]
forall a b. (a -> b) -> [a] -> [b]
map (Proxy GenTx
-> Index xs blk -> GenTx blk -> GenTx (HardForkBlock xs)
forall {k} (f :: k -> *) a b (x :: k) (xs :: [k]).
(All Top xs, Coercible a (f x), Coercible b (NS f xs)) =>
Proxy f -> Index xs x -> a -> b
injectNS' (forall {k} (t :: k). Proxy t
forall (t :: * -> *). Proxy t
Proxy @GenTx) Index xs blk
index) ([GenTx blk] -> [GenTx (HardForkBlock xs)])
-> (I blk -> [GenTx blk]) -> I blk -> [GenTx (HardForkBlock xs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. blk -> [GenTx blk]
forall blk. HasTxs blk => blk -> [GenTx blk]
extractTxs (blk -> [GenTx blk]) -> (I blk -> blk) -> I blk -> [GenTx blk]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. I blk -> blk
forall a. I a -> a
unI

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

ledgerInfo ::
  forall blk mk.
  SingleEraBlock blk =>
  State.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)

injectApplyTxErr :: SListI xs => Index xs blk -> ApplyTxErr blk -> HardForkApplyTxErr xs
injectApplyTxErr :: forall (xs :: [*]) blk.
SListI xs =>
Index xs blk -> ApplyTxErr blk -> HardForkApplyTxErr xs
injectApplyTxErr Index xs blk
index =
  OneEraApplyTxErr xs -> HardForkApplyTxErr xs
forall (xs :: [*]). OneEraApplyTxErr xs -> HardForkApplyTxErr xs
HardForkApplyTxErrFromEra
    (OneEraApplyTxErr xs -> HardForkApplyTxErr xs)
-> (ApplyTxErr blk -> OneEraApplyTxErr xs)
-> ApplyTxErr blk
-> HardForkApplyTxErr xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS WrapApplyTxErr xs -> OneEraApplyTxErr xs
forall (xs :: [*]). NS WrapApplyTxErr xs -> OneEraApplyTxErr xs
OneEraApplyTxErr
    (NS WrapApplyTxErr xs -> OneEraApplyTxErr xs)
-> (ApplyTxErr blk -> NS WrapApplyTxErr xs)
-> ApplyTxErr blk
-> OneEraApplyTxErr xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index xs blk -> WrapApplyTxErr blk -> NS WrapApplyTxErr 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
    (WrapApplyTxErr blk -> NS WrapApplyTxErr xs)
-> (ApplyTxErr blk -> WrapApplyTxErr blk)
-> ApplyTxErr blk
-> NS WrapApplyTxErr xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ApplyTxErr blk -> WrapApplyTxErr blk
forall blk. ApplyTxErr blk -> WrapApplyTxErr blk
WrapApplyTxErr

injectValidatedGenTx ::
  SListI xs => Index xs blk -> Validated (GenTx blk) -> Validated (GenTx (HardForkBlock xs))
injectValidatedGenTx :: forall (xs :: [*]) blk.
SListI xs =>
Index xs blk
-> Validated (GenTx blk) -> Validated (GenTx (HardForkBlock xs))
injectValidatedGenTx Index xs blk
index =
  OneEraValidatedGenTx xs -> Validated (GenTx (HardForkBlock xs))
forall (xs :: [*]).
OneEraValidatedGenTx xs -> Validated (GenTx (HardForkBlock xs))
HardForkValidatedGenTx
    (OneEraValidatedGenTx xs -> Validated (GenTx (HardForkBlock xs)))
-> (Validated (GenTx blk) -> OneEraValidatedGenTx xs)
-> Validated (GenTx blk)
-> Validated (GenTx (HardForkBlock xs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NS WrapValidatedGenTx xs -> OneEraValidatedGenTx xs
forall (xs :: [*]).
NS WrapValidatedGenTx xs -> OneEraValidatedGenTx xs
OneEraValidatedGenTx
    (NS WrapValidatedGenTx xs -> OneEraValidatedGenTx xs)
-> (Validated (GenTx blk) -> NS WrapValidatedGenTx xs)
-> Validated (GenTx blk)
-> OneEraValidatedGenTx xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index xs blk -> WrapValidatedGenTx blk -> NS WrapValidatedGenTx 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
    (WrapValidatedGenTx blk -> NS WrapValidatedGenTx xs)
-> (Validated (GenTx blk) -> WrapValidatedGenTx blk)
-> Validated (GenTx blk)
-> NS WrapValidatedGenTx xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (GenTx blk) -> WrapValidatedGenTx blk
forall blk. Validated (GenTx blk) -> WrapValidatedGenTx blk
WrapValidatedGenTx