{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.HardFork.Combinator.Basics
  ( -- * Hard fork protocol, block, and ledger state
    HardForkBlock (..)
  , HardForkProtocol
  , LedgerState (..)

    -- * Config
  , BlockConfig (..)
  , CodecConfig (..)
  , ConsensusConfig (..)
  , HardForkLedgerConfig (..)
  , StorageConfig (..)

    -- ** Functions on config
  , completeConsensusConfig'
  , completeConsensusConfig''
  , completeLedgerConfig'
  , completeLedgerConfig''
  , distribLedgerConfig
  , distribTopLevelConfig

    -- * HFC injection/projection helpers for Peras
  , distribHardForkPoint
  , injectHardForkPoint

    -- ** Convenience re-exports
  , EpochInfo
  , Except
  ) where

import Cardano.Slotting.EpochInfo
import Data.Kind (Type)
import Data.SOP (K (..))
import Data.SOP.Constraint
import Data.SOP.Functors
import Data.SOP.Strict
import Data.Typeable
import GHC.Generics (Generic)
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block.Abstract
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.HardFork.Combinator.Abstract
import Ouroboros.Consensus.HardFork.Combinator.AcrossEras
import Ouroboros.Consensus.HardFork.Combinator.PartialConfig
import qualified Ouroboros.Consensus.HardFork.Combinator.State.Infra as State
import Ouroboros.Consensus.HardFork.Combinator.State.Instances ()
import Ouroboros.Consensus.HardFork.Combinator.State.Types
import qualified Ouroboros.Consensus.HardFork.History as History
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Ledger.SupportsPeras (LedgerStateSupportsPeras (..))
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.TypeFamilyWrappers
import Ouroboros.Consensus.Util (ShowProxy)
import Ouroboros.Consensus.Util.RedundantConstraints (keepRedundantConstraint)

{-------------------------------------------------------------------------------
  Hard fork protocol, block, and ledger state
-------------------------------------------------------------------------------}

data HardForkProtocol (xs :: [Type])

newtype HardForkBlock xs = HardForkBlock
  { forall (xs :: [*]). HardForkBlock xs -> OneEraBlock xs
getHardForkBlock :: OneEraBlock xs
  }
  deriving Int -> HardForkBlock xs -> ShowS
[HardForkBlock xs] -> ShowS
HardForkBlock xs -> String
(Int -> HardForkBlock xs -> ShowS)
-> (HardForkBlock xs -> String)
-> ([HardForkBlock xs] -> ShowS)
-> Show (HardForkBlock xs)
forall (xs :: [*]).
CanHardFork xs =>
Int -> HardForkBlock xs -> ShowS
forall (xs :: [*]). CanHardFork xs => [HardForkBlock xs] -> ShowS
forall (xs :: [*]). CanHardFork xs => HardForkBlock xs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall (xs :: [*]).
CanHardFork xs =>
Int -> HardForkBlock xs -> ShowS
showsPrec :: Int -> HardForkBlock xs -> ShowS
$cshow :: forall (xs :: [*]). CanHardFork xs => HardForkBlock xs -> String
show :: HardForkBlock xs -> String
$cshowList :: forall (xs :: [*]). CanHardFork xs => [HardForkBlock xs] -> ShowS
showList :: [HardForkBlock xs] -> ShowS
Show

instance Typeable xs => ShowProxy (HardForkBlock xs)

type instance BlockProtocol (HardForkBlock xs) = HardForkProtocol xs
type instance HeaderHash (HardForkBlock xs) = OneEraHash xs

newtype instance LedgerState (HardForkBlock xs) mk = HardForkLedgerState
  { forall (xs :: [*]) (mk :: MapKind).
LedgerState (HardForkBlock xs) mk
-> HardForkState (Flip LedgerState mk) xs
hardForkLedgerStatePerEra :: HardForkState (Flip LedgerState mk) xs
  }

deriving stock instance
  (ShowMK mk, CanHardFork xs) =>
  Show (LedgerState (HardForkBlock xs) mk)
deriving stock instance
  (EqMK mk, CanHardFork xs) =>
  Eq (LedgerState (HardForkBlock xs) mk)
deriving newtype instance
  (NoThunksMK mk, CanHardFork xs) =>
  NoThunks (LedgerState (HardForkBlock xs) mk)

{-------------------------------------------------------------------------------
  Protocol config
-------------------------------------------------------------------------------}

data instance ConsensusConfig (HardForkProtocol xs) = HardForkConsensusConfig
  { forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> SecurityParam
hardForkConsensusConfigK :: !(SecurityParam)
  -- ^ The value of @k@ cannot change at hard fork boundaries
  , forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> Shape xs
hardForkConsensusConfigShape :: !(History.Shape xs)
  -- ^ The shape of the hard fork
  --
  -- We require this in the consensus config because consensus might need
  -- access to 'EpochInfo', and in order to compute that, we need the
  -- 'EraParams' of all eras.
  , forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> PerEraConsensusConfig xs
hardForkConsensusConfigPerEra :: !(PerEraConsensusConfig xs)
  -- ^ Config for each era
  }
  deriving stock (forall x.
 ConsensusConfig (HardForkProtocol xs)
 -> Rep (ConsensusConfig (HardForkProtocol xs)) x)
-> (forall x.
    Rep (ConsensusConfig (HardForkProtocol xs)) x
    -> ConsensusConfig (HardForkProtocol xs))
-> Generic (ConsensusConfig (HardForkProtocol xs))
forall (xs :: [*]) x.
Rep (ConsensusConfig (HardForkProtocol xs)) x
-> ConsensusConfig (HardForkProtocol xs)
forall (xs :: [*]) x.
ConsensusConfig (HardForkProtocol xs)
-> Rep (ConsensusConfig (HardForkProtocol xs)) x
forall x.
Rep (ConsensusConfig (HardForkProtocol xs)) x
-> ConsensusConfig (HardForkProtocol xs)
forall x.
ConsensusConfig (HardForkProtocol xs)
-> Rep (ConsensusConfig (HardForkProtocol xs)) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (xs :: [*]) x.
ConsensusConfig (HardForkProtocol xs)
-> Rep (ConsensusConfig (HardForkProtocol xs)) x
from :: forall x.
ConsensusConfig (HardForkProtocol xs)
-> Rep (ConsensusConfig (HardForkProtocol xs)) x
$cto :: forall (xs :: [*]) x.
Rep (ConsensusConfig (HardForkProtocol xs)) x
-> ConsensusConfig (HardForkProtocol xs)
to :: forall x.
Rep (ConsensusConfig (HardForkProtocol xs)) x
-> ConsensusConfig (HardForkProtocol xs)
Generic
  deriving anyclass Context
-> ConsensusConfig (HardForkProtocol xs) -> IO (Maybe ThunkInfo)
Proxy (ConsensusConfig (HardForkProtocol xs)) -> String
(Context
 -> ConsensusConfig (HardForkProtocol xs) -> IO (Maybe ThunkInfo))
-> (Context
    -> ConsensusConfig (HardForkProtocol xs) -> IO (Maybe ThunkInfo))
-> (Proxy (ConsensusConfig (HardForkProtocol xs)) -> String)
-> NoThunks (ConsensusConfig (HardForkProtocol xs))
forall (xs :: [*]).
CanHardFork xs =>
Context
-> ConsensusConfig (HardForkProtocol xs) -> IO (Maybe ThunkInfo)
forall (xs :: [*]).
CanHardFork xs =>
Proxy (ConsensusConfig (HardForkProtocol 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
-> ConsensusConfig (HardForkProtocol xs) -> IO (Maybe ThunkInfo)
noThunks :: Context
-> ConsensusConfig (HardForkProtocol xs) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context
-> ConsensusConfig (HardForkProtocol xs) -> IO (Maybe ThunkInfo)
wNoThunks :: Context
-> ConsensusConfig (HardForkProtocol xs) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (xs :: [*]).
CanHardFork xs =>
Proxy (ConsensusConfig (HardForkProtocol xs)) -> String
showTypeOf :: Proxy (ConsensusConfig (HardForkProtocol xs)) -> String
NoThunks

{-------------------------------------------------------------------------------
  Block config
-------------------------------------------------------------------------------}

newtype instance BlockConfig (HardForkBlock xs) = HardForkBlockConfig
  { forall (xs :: [*]).
BlockConfig (HardForkBlock xs) -> PerEraBlockConfig xs
hardForkBlockConfigPerEra :: PerEraBlockConfig xs
  }
  deriving newtype Context -> BlockConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
Proxy (BlockConfig (HardForkBlock xs)) -> String
(Context -> BlockConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo))
-> (Context
    -> BlockConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo))
-> (Proxy (BlockConfig (HardForkBlock xs)) -> String)
-> NoThunks (BlockConfig (HardForkBlock xs))
forall (xs :: [*]).
CanHardFork xs =>
Context -> BlockConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
forall (xs :: [*]).
CanHardFork xs =>
Proxy (BlockConfig (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 -> BlockConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
noThunks :: Context -> BlockConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context -> BlockConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> BlockConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (xs :: [*]).
CanHardFork xs =>
Proxy (BlockConfig (HardForkBlock xs)) -> String
showTypeOf :: Proxy (BlockConfig (HardForkBlock xs)) -> String
NoThunks

{-------------------------------------------------------------------------------
  Codec config
-------------------------------------------------------------------------------}

newtype instance CodecConfig (HardForkBlock xs) = HardForkCodecConfig
  { forall (xs :: [*]).
CodecConfig (HardForkBlock xs) -> PerEraCodecConfig xs
hardForkCodecConfigPerEra :: PerEraCodecConfig xs
  }
  deriving newtype Context -> CodecConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
Proxy (CodecConfig (HardForkBlock xs)) -> String
(Context -> CodecConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo))
-> (Context
    -> CodecConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo))
-> (Proxy (CodecConfig (HardForkBlock xs)) -> String)
-> NoThunks (CodecConfig (HardForkBlock xs))
forall (xs :: [*]).
CanHardFork xs =>
Context -> CodecConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
forall (xs :: [*]).
CanHardFork xs =>
Proxy (CodecConfig (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 -> CodecConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
noThunks :: Context -> CodecConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context -> CodecConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> CodecConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (xs :: [*]).
CanHardFork xs =>
Proxy (CodecConfig (HardForkBlock xs)) -> String
showTypeOf :: Proxy (CodecConfig (HardForkBlock xs)) -> String
NoThunks

{-------------------------------------------------------------------------------
  Storage config
-------------------------------------------------------------------------------}

newtype instance StorageConfig (HardForkBlock xs) = HardForkStorageConfig
  { forall (xs :: [*]).
StorageConfig (HardForkBlock xs) -> PerEraStorageConfig xs
hardForkStorageConfigPerEra :: PerEraStorageConfig xs
  }
  deriving newtype Context -> StorageConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
Proxy (StorageConfig (HardForkBlock xs)) -> String
(Context
 -> StorageConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo))
-> (Context
    -> StorageConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo))
-> (Proxy (StorageConfig (HardForkBlock xs)) -> String)
-> NoThunks (StorageConfig (HardForkBlock xs))
forall (xs :: [*]).
CanHardFork xs =>
Context -> StorageConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
forall (xs :: [*]).
CanHardFork xs =>
Proxy (StorageConfig (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 -> StorageConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
noThunks :: Context -> StorageConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
$cwNoThunks :: forall (xs :: [*]).
CanHardFork xs =>
Context -> StorageConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> StorageConfig (HardForkBlock xs) -> IO (Maybe ThunkInfo)
$cshowTypeOf :: forall (xs :: [*]).
CanHardFork xs =>
Proxy (StorageConfig (HardForkBlock xs)) -> String
showTypeOf :: Proxy (StorageConfig (HardForkBlock xs)) -> String
NoThunks

{-------------------------------------------------------------------------------
  Ledger config
-------------------------------------------------------------------------------}

data HardForkLedgerConfig xs = HardForkLedgerConfig
  { forall (xs :: [*]). HardForkLedgerConfig xs -> Shape xs
hardForkLedgerConfigShape :: !(History.Shape xs)
  , forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
hardForkLedgerConfigPerEra :: !(PerEraLedgerConfig xs)
  }
  deriving (forall x.
 HardForkLedgerConfig xs -> Rep (HardForkLedgerConfig xs) x)
-> (forall x.
    Rep (HardForkLedgerConfig xs) x -> HardForkLedgerConfig xs)
-> Generic (HardForkLedgerConfig xs)
forall (xs :: [*]) x.
Rep (HardForkLedgerConfig xs) x -> HardForkLedgerConfig xs
forall (xs :: [*]) x.
HardForkLedgerConfig xs -> Rep (HardForkLedgerConfig xs) x
forall x.
Rep (HardForkLedgerConfig xs) x -> HardForkLedgerConfig xs
forall x.
HardForkLedgerConfig xs -> Rep (HardForkLedgerConfig xs) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall (xs :: [*]) x.
HardForkLedgerConfig xs -> Rep (HardForkLedgerConfig xs) x
from :: forall x.
HardForkLedgerConfig xs -> Rep (HardForkLedgerConfig xs) x
$cto :: forall (xs :: [*]) x.
Rep (HardForkLedgerConfig xs) x -> HardForkLedgerConfig xs
to :: forall x.
Rep (HardForkLedgerConfig xs) x -> HardForkLedgerConfig xs
Generic

deriving instance Show (PerEraLedgerConfig xs) => Show (HardForkLedgerConfig xs)
instance CanHardFork xs => NoThunks (HardForkLedgerConfig xs)

type instance LedgerCfg LedgerState (HardForkBlock xs) = HardForkLedgerConfig xs

{-------------------------------------------------------------------------------
  Operations on config
-------------------------------------------------------------------------------}

completeLedgerConfig' ::
  forall blk.
  HasPartialLedgerConfig blk =>
  EpochInfo (Except PastHorizonException) ->
  WrapPartialLedgerConfig blk ->
  LedgerConfig blk
completeLedgerConfig' :: forall blk.
HasPartialLedgerConfig blk =>
EpochInfo (Except PastHorizonException)
-> WrapPartialLedgerConfig blk -> LedgerConfig blk
completeLedgerConfig' EpochInfo (Except PastHorizonException)
ei =
  Proxy blk
-> EpochInfo (Except PastHorizonException)
-> PartialLedgerConfig blk
-> LedgerCfg LedgerState blk
forall blk (proxy :: * -> *).
HasPartialLedgerConfig blk =>
proxy blk
-> EpochInfo (Except PastHorizonException)
-> PartialLedgerConfig blk
-> LedgerConfig blk
forall (proxy :: * -> *).
proxy blk
-> EpochInfo (Except PastHorizonException)
-> PartialLedgerConfig blk
-> LedgerCfg LedgerState blk
completeLedgerConfig (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) EpochInfo (Except PastHorizonException)
ei
    (PartialLedgerConfig blk -> LedgerCfg LedgerState blk)
-> (WrapPartialLedgerConfig blk -> PartialLedgerConfig blk)
-> WrapPartialLedgerConfig blk
-> LedgerCfg LedgerState blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapPartialLedgerConfig blk -> PartialLedgerConfig blk
forall blk. WrapPartialLedgerConfig blk -> PartialLedgerConfig blk
unwrapPartialLedgerConfig

completeLedgerConfig'' ::
  forall blk.
  HasPartialLedgerConfig blk =>
  EpochInfo (Except PastHorizonException) ->
  WrapPartialLedgerConfig blk ->
  WrapLedgerConfig blk
completeLedgerConfig'' :: forall blk.
HasPartialLedgerConfig blk =>
EpochInfo (Except PastHorizonException)
-> WrapPartialLedgerConfig blk -> WrapLedgerConfig blk
completeLedgerConfig'' EpochInfo (Except PastHorizonException)
ei =
  LedgerConfig blk -> WrapLedgerConfig blk
forall blk. LedgerConfig blk -> WrapLedgerConfig blk
WrapLedgerConfig
    (LedgerConfig blk -> WrapLedgerConfig blk)
-> (WrapPartialLedgerConfig blk -> LedgerConfig blk)
-> WrapPartialLedgerConfig blk
-> WrapLedgerConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy blk
-> EpochInfo (Except PastHorizonException)
-> PartialLedgerConfig blk
-> LedgerConfig blk
forall blk (proxy :: * -> *).
HasPartialLedgerConfig blk =>
proxy blk
-> EpochInfo (Except PastHorizonException)
-> PartialLedgerConfig blk
-> LedgerConfig blk
forall (proxy :: * -> *).
proxy blk
-> EpochInfo (Except PastHorizonException)
-> PartialLedgerConfig blk
-> LedgerConfig blk
completeLedgerConfig (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) EpochInfo (Except PastHorizonException)
ei
    (PartialLedgerConfig blk -> LedgerConfig blk)
-> (WrapPartialLedgerConfig blk -> PartialLedgerConfig blk)
-> WrapPartialLedgerConfig blk
-> LedgerConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapPartialLedgerConfig blk -> PartialLedgerConfig blk
forall blk. WrapPartialLedgerConfig blk -> PartialLedgerConfig blk
unwrapPartialLedgerConfig

completeConsensusConfig' ::
  forall blk.
  HasPartialConsensusConfig (BlockProtocol blk) =>
  EpochInfo (Except PastHorizonException) ->
  WrapPartialConsensusConfig blk ->
  ConsensusConfig (BlockProtocol blk)
completeConsensusConfig' :: forall blk.
HasPartialConsensusConfig (BlockProtocol blk) =>
EpochInfo (Except PastHorizonException)
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
completeConsensusConfig' EpochInfo (Except PastHorizonException)
ei =
  Proxy (BlockProtocol blk)
-> EpochInfo (Except PastHorizonException)
-> PartialConsensusConfig (BlockProtocol blk)
-> ConsensusConfig (BlockProtocol blk)
forall p (proxy :: * -> *).
HasPartialConsensusConfig p =>
proxy p
-> EpochInfo (Except PastHorizonException)
-> PartialConsensusConfig p
-> ConsensusConfig p
forall (proxy :: * -> *).
proxy (BlockProtocol blk)
-> EpochInfo (Except PastHorizonException)
-> PartialConsensusConfig (BlockProtocol blk)
-> ConsensusConfig (BlockProtocol blk)
completeConsensusConfig (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(BlockProtocol blk)) EpochInfo (Except PastHorizonException)
ei
    (PartialConsensusConfig (BlockProtocol blk)
 -> ConsensusConfig (BlockProtocol blk))
-> (WrapPartialConsensusConfig blk
    -> PartialConsensusConfig (BlockProtocol blk))
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapPartialConsensusConfig blk
-> PartialConsensusConfig (BlockProtocol blk)
forall blk.
WrapPartialConsensusConfig blk
-> PartialConsensusConfig (BlockProtocol blk)
unwrapPartialConsensusConfig

completeConsensusConfig'' ::
  forall blk.
  HasPartialConsensusConfig (BlockProtocol blk) =>
  EpochInfo (Except PastHorizonException) ->
  WrapPartialConsensusConfig blk ->
  WrapConsensusConfig blk
completeConsensusConfig'' :: forall blk.
HasPartialConsensusConfig (BlockProtocol blk) =>
EpochInfo (Except PastHorizonException)
-> WrapPartialConsensusConfig blk -> WrapConsensusConfig blk
completeConsensusConfig'' EpochInfo (Except PastHorizonException)
ei =
  ConsensusConfig (BlockProtocol blk) -> WrapConsensusConfig blk
forall blk.
ConsensusConfig (BlockProtocol blk) -> WrapConsensusConfig blk
WrapConsensusConfig
    (ConsensusConfig (BlockProtocol blk) -> WrapConsensusConfig blk)
-> (WrapPartialConsensusConfig blk
    -> ConsensusConfig (BlockProtocol blk))
-> WrapPartialConsensusConfig blk
-> WrapConsensusConfig blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy (BlockProtocol blk)
-> EpochInfo (Except PastHorizonException)
-> PartialConsensusConfig (BlockProtocol blk)
-> ConsensusConfig (BlockProtocol blk)
forall p (proxy :: * -> *).
HasPartialConsensusConfig p =>
proxy p
-> EpochInfo (Except PastHorizonException)
-> PartialConsensusConfig p
-> ConsensusConfig p
forall (proxy :: * -> *).
proxy (BlockProtocol blk)
-> EpochInfo (Except PastHorizonException)
-> PartialConsensusConfig (BlockProtocol blk)
-> ConsensusConfig (BlockProtocol blk)
completeConsensusConfig (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(BlockProtocol blk)) EpochInfo (Except PastHorizonException)
ei
    (PartialConsensusConfig (BlockProtocol blk)
 -> ConsensusConfig (BlockProtocol blk))
-> (WrapPartialConsensusConfig blk
    -> PartialConsensusConfig (BlockProtocol blk))
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapPartialConsensusConfig blk
-> PartialConsensusConfig (BlockProtocol blk)
forall blk.
WrapPartialConsensusConfig blk
-> PartialConsensusConfig (BlockProtocol blk)
unwrapPartialConsensusConfig

distribLedgerConfig ::
  CanHardFork xs =>
  EpochInfo (Except PastHorizonException) ->
  LedgerConfig (HardForkBlock xs) ->
  NP WrapLedgerConfig xs
distribLedgerConfig :: forall (xs :: [*]).
CanHardFork xs =>
EpochInfo (Except PastHorizonException)
-> LedgerConfig (HardForkBlock xs) -> NP WrapLedgerConfig xs
distribLedgerConfig EpochInfo (Except PastHorizonException)
ei LedgerConfig (HardForkBlock xs)
cfg =
  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)
    (PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
forall (xs :: [*]).
PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
getPerEraLedgerConfig (PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs)
-> PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
forall a b. (a -> b) -> a -> b
$ HardForkLedgerConfig xs -> PerEraLedgerConfig xs
forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
hardForkLedgerConfigPerEra LedgerConfig (HardForkBlock xs)
HardForkLedgerConfig xs
cfg)

distribTopLevelConfig ::
  All SingleEraBlock xs =>
  EpochInfo (Except PastHorizonException) ->
  TopLevelConfig (HardForkBlock xs) ->
  NP TopLevelConfig xs
distribTopLevelConfig :: forall (xs :: [*]).
All SingleEraBlock xs =>
EpochInfo (Except PastHorizonException)
-> TopLevelConfig (HardForkBlock xs) -> NP TopLevelConfig xs
distribTopLevelConfig EpochInfo (Except PastHorizonException)
ei TopLevelConfig (HardForkBlock xs)
tlc =
  Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    (-.->)
      WrapPartialConsensusConfig
      (WrapPartialLedgerConfig
       -.-> (BlockConfig
             -.-> (CodecConfig -.-> (StorageConfig -.-> TopLevelConfig))))
      a)
-> NP
     (WrapPartialConsensusConfig
      -.-> (WrapPartialLedgerConfig
            -.-> (BlockConfig
                  -.-> (CodecConfig -.-> (StorageConfig -.-> TopLevelConfig)))))
     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
    ( (WrapPartialConsensusConfig a
 -> WrapPartialLedgerConfig a
 -> BlockConfig a
 -> CodecConfig a
 -> StorageConfig a
 -> TopLevelConfig a)
-> (-.->)
     WrapPartialConsensusConfig
     (WrapPartialLedgerConfig
      -.-> (BlockConfig
            -.-> (CodecConfig -.-> (StorageConfig -.-> TopLevelConfig))))
     a
forall {k} (f0 :: k -> *) (a :: k) (f1 :: k -> *) (f2 :: k -> *)
       (f3 :: k -> *) (f4 :: k -> *) (f5 :: k -> *).
(f0 a -> f1 a -> f2 a -> f3 a -> f4 a -> f5 a)
-> (-.->) f0 (f1 -.-> (f2 -.-> (f3 -.-> (f4 -.-> f5)))) a
fn_5
        ( \WrapPartialConsensusConfig a
cfgConsensus WrapPartialLedgerConfig a
cfgLedger BlockConfig a
cfgBlock CodecConfig a
cfgCodec StorageConfig a
cfgStorage ->
            ConsensusConfig (BlockProtocol a)
-> LedgerConfig a
-> BlockConfig a
-> CodecConfig a
-> StorageConfig a
-> CheckpointsMap a
-> TopLevelConfig a
forall blk.
ConsensusConfig (BlockProtocol blk)
-> LedgerConfig blk
-> BlockConfig blk
-> CodecConfig blk
-> StorageConfig blk
-> CheckpointsMap blk
-> TopLevelConfig blk
mkTopLevelConfig
              (EpochInfo (Except PastHorizonException)
-> WrapPartialConsensusConfig a
-> ConsensusConfig (BlockProtocol a)
forall blk.
HasPartialConsensusConfig (BlockProtocol blk) =>
EpochInfo (Except PastHorizonException)
-> WrapPartialConsensusConfig blk
-> ConsensusConfig (BlockProtocol blk)
completeConsensusConfig' EpochInfo (Except PastHorizonException)
ei WrapPartialConsensusConfig a
cfgConsensus)
              (EpochInfo (Except PastHorizonException)
-> WrapPartialLedgerConfig a -> LedgerConfig a
forall blk.
HasPartialLedgerConfig blk =>
EpochInfo (Except PastHorizonException)
-> WrapPartialLedgerConfig blk -> LedgerConfig blk
completeLedgerConfig' EpochInfo (Except PastHorizonException)
ei WrapPartialLedgerConfig a
cfgLedger)
              BlockConfig a
cfgBlock
              CodecConfig a
cfgCodec
              StorageConfig a
cfgStorage
              -- topLevelConfigCheckpoints is only used in validateEnvelope,
              -- where it comes from the TopLevelConfig of the HardForkBlock.
              --
              -- The checkpoints of the underlying blocks are not used.
              CheckpointsMap a
forall blk. CheckpointsMap blk
emptyCheckpointsMap
        )
    )
    Prod
  NP
  (WrapPartialConsensusConfig
   -.-> (WrapPartialLedgerConfig
         -.-> (BlockConfig
               -.-> (CodecConfig -.-> (StorageConfig -.-> TopLevelConfig)))))
  xs
-> NP WrapPartialConsensusConfig xs
-> NP
     (WrapPartialLedgerConfig
      -.-> (BlockConfig
            -.-> (CodecConfig -.-> (StorageConfig -.-> TopLevelConfig))))
     xs
forall k l (h :: (k -> *) -> l -> *) (f :: k -> *) (g :: k -> *)
       (xs :: l).
HAp h =>
Prod h (f -.-> g) xs -> h f xs -> h g xs
forall (f :: * -> *) (g :: * -> *) (xs :: [*]).
Prod NP (f -.-> g) xs -> NP f xs -> NP g xs
`hap` ( PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs
forall (xs :: [*]).
PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs
getPerEraConsensusConfig (PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs)
-> PerEraConsensusConfig xs -> NP WrapPartialConsensusConfig xs
forall a b. (a -> b) -> a -> b
$
              ConsensusConfig (HardForkProtocol xs) -> PerEraConsensusConfig xs
forall (xs :: [*]).
ConsensusConfig (HardForkProtocol xs) -> PerEraConsensusConfig xs
hardForkConsensusConfigPerEra (TopLevelConfig (HardForkBlock xs)
-> ConsensusConfig (BlockProtocol (HardForkBlock xs))
forall blk.
TopLevelConfig blk -> ConsensusConfig (BlockProtocol blk)
configConsensus TopLevelConfig (HardForkBlock xs)
tlc)
          )
    Prod
  NP
  (WrapPartialLedgerConfig
   -.-> (BlockConfig
         -.-> (CodecConfig -.-> (StorageConfig -.-> TopLevelConfig))))
  xs
-> NP WrapPartialLedgerConfig xs
-> NP
     (BlockConfig
      -.-> (CodecConfig -.-> (StorageConfig -.-> TopLevelConfig)))
     xs
forall k l (h :: (k -> *) -> l -> *) (f :: k -> *) (g :: k -> *)
       (xs :: l).
HAp h =>
Prod h (f -.-> g) xs -> h f xs -> h g xs
forall (f :: * -> *) (g :: * -> *) (xs :: [*]).
Prod NP (f -.-> g) xs -> NP f xs -> NP g xs
`hap` ( PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
forall (xs :: [*]).
PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
getPerEraLedgerConfig (PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs)
-> PerEraLedgerConfig xs -> NP WrapPartialLedgerConfig xs
forall a b. (a -> b) -> a -> b
$
              HardForkLedgerConfig xs -> PerEraLedgerConfig xs
forall (xs :: [*]).
HardForkLedgerConfig xs -> PerEraLedgerConfig xs
hardForkLedgerConfigPerEra (TopLevelConfig (HardForkBlock xs)
-> LedgerConfig (HardForkBlock xs)
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger TopLevelConfig (HardForkBlock xs)
tlc)
          )
    Prod
  NP
  (BlockConfig
   -.-> (CodecConfig -.-> (StorageConfig -.-> TopLevelConfig)))
  xs
-> NP BlockConfig xs
-> NP (CodecConfig -.-> (StorageConfig -.-> TopLevelConfig)) xs
forall k l (h :: (k -> *) -> l -> *) (f :: k -> *) (g :: k -> *)
       (xs :: l).
HAp h =>
Prod h (f -.-> g) xs -> h f xs -> h g xs
forall (f :: * -> *) (g :: * -> *) (xs :: [*]).
Prod NP (f -.-> g) xs -> NP f xs -> NP g xs
`hap` ( PerEraBlockConfig xs -> NP BlockConfig xs
forall (xs :: [*]). PerEraBlockConfig xs -> NP BlockConfig xs
getPerEraBlockConfig (PerEraBlockConfig xs -> NP BlockConfig xs)
-> PerEraBlockConfig xs -> NP BlockConfig xs
forall a b. (a -> b) -> a -> b
$
              BlockConfig (HardForkBlock xs) -> PerEraBlockConfig xs
forall (xs :: [*]).
BlockConfig (HardForkBlock xs) -> PerEraBlockConfig xs
hardForkBlockConfigPerEra (TopLevelConfig (HardForkBlock xs) -> BlockConfig (HardForkBlock xs)
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig (HardForkBlock xs)
tlc)
          )
    Prod NP (CodecConfig -.-> (StorageConfig -.-> TopLevelConfig)) xs
-> NP CodecConfig xs -> NP (StorageConfig -.-> TopLevelConfig) xs
forall k l (h :: (k -> *) -> l -> *) (f :: k -> *) (g :: k -> *)
       (xs :: l).
HAp h =>
Prod h (f -.-> g) xs -> h f xs -> h g xs
forall (f :: * -> *) (g :: * -> *) (xs :: [*]).
Prod NP (f -.-> g) xs -> NP f xs -> NP g xs
`hap` ( PerEraCodecConfig xs -> NP CodecConfig xs
forall (xs :: [*]). PerEraCodecConfig xs -> NP CodecConfig xs
getPerEraCodecConfig (PerEraCodecConfig xs -> NP CodecConfig xs)
-> PerEraCodecConfig xs -> NP CodecConfig xs
forall a b. (a -> b) -> a -> b
$
              CodecConfig (HardForkBlock xs) -> PerEraCodecConfig xs
forall (xs :: [*]).
CodecConfig (HardForkBlock xs) -> PerEraCodecConfig xs
hardForkCodecConfigPerEra (TopLevelConfig (HardForkBlock xs) -> CodecConfig (HardForkBlock xs)
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec TopLevelConfig (HardForkBlock xs)
tlc)
          )
    Prod NP (StorageConfig -.-> TopLevelConfig) xs
-> NP StorageConfig xs -> NP TopLevelConfig xs
forall k l (h :: (k -> *) -> l -> *) (f :: k -> *) (g :: k -> *)
       (xs :: l).
HAp h =>
Prod h (f -.-> g) xs -> h f xs -> h g xs
forall (f :: * -> *) (g :: * -> *) (xs :: [*]).
Prod NP (f -.-> g) xs -> NP f xs -> NP g xs
`hap` ( PerEraStorageConfig xs -> NP StorageConfig xs
forall (xs :: [*]). PerEraStorageConfig xs -> NP StorageConfig xs
getPerEraStorageConfig (PerEraStorageConfig xs -> NP StorageConfig xs)
-> PerEraStorageConfig xs -> NP StorageConfig xs
forall a b. (a -> b) -> a -> b
$
              StorageConfig (HardForkBlock xs) -> PerEraStorageConfig xs
forall (xs :: [*]).
StorageConfig (HardForkBlock xs) -> PerEraStorageConfig xs
hardForkStorageConfigPerEra (TopLevelConfig (HardForkBlock xs)
-> StorageConfig (HardForkBlock xs)
forall blk. TopLevelConfig blk -> StorageConfig blk
configStorage TopLevelConfig (HardForkBlock xs)
tlc)
          )

{-------------------------------------------------------------------------------
  HFC injection/projection helpers for Peras
-------------------------------------------------------------------------------}

-- | Extract a 'Point' of the hard fork block to a 'Point' of a single era by
-- decoding the raw hash via 'fromShortRawHash'. Used when delegating operations
-- that take a 'Point' argument to a single-era implementation.
distribHardForkPoint ::
  forall blk xs.
  ( ConvertRawHash blk
  , HashSize (HardForkBlock xs) ~ HashSize blk
  ) =>
  Point (HardForkBlock xs) ->
  Point blk
distribHardForkPoint :: forall blk (xs :: [*]).
(ConvertRawHash blk, HashSize (HardForkBlock xs) ~ HashSize blk) =>
Point (HardForkBlock xs) -> Point blk
distribHardForkPoint = \case
  Point (HardForkBlock xs)
GenesisPoint ->
    Point blk
forall {k} (block :: k). Point block
GenesisPoint
  BlockPoint SlotNo
s (OneEraHash ShortByteString
h) ->
    -- The constraints ensure that the hash sizes match, so we can safely use
    -- the unsafe variant of 'fromShortRawHash' here.
    SlotNo -> HeaderHash blk -> Point blk
forall {k} (block :: k). SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
s (Proxy blk -> ShortByteString -> HeaderHash blk
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> ShortByteString -> HeaderHash blk
forall (proxy :: * -> *).
proxy blk -> ShortByteString -> HeaderHash blk
unsafeFromShortRawHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) ShortByteString
h)
 where
  ()
_ = Proxy (HashSize blk ~ HashSize blk) -> ()
forall (c :: Constraint) (proxy :: Constraint -> *).
c =>
proxy c -> ()
keepRedundantConstraint (forall {k} (t :: k). Proxy t
forall (t :: Constraint). Proxy t
Proxy @(HashSize (HardForkBlock xs) ~ HashSize blk))

-- | Inject a 'Point' from a single era into a 'Point' of the hard fork block by
-- encoding the raw hash via 'toShortRawHash'. Used by accessor instances to
-- return 'Point (HardForkBlock xs)' from single-era point values.
injectHardForkPoint ::
  forall blk xs.
  ConvertRawHash blk =>
  Point blk ->
  Point (HardForkBlock xs)
injectHardForkPoint :: forall blk (xs :: [*]).
ConvertRawHash blk =>
Point blk -> Point (HardForkBlock xs)
injectHardForkPoint = \case
  Point blk
GenesisPoint ->
    Point (HardForkBlock xs)
forall {k} (block :: k). Point block
GenesisPoint
  BlockPoint SlotNo
s HeaderHash blk
h ->
    SlotNo -> HeaderHash (HardForkBlock xs) -> Point (HardForkBlock xs)
forall {k} (block :: k). SlotNo -> HeaderHash block -> Point block
BlockPoint SlotNo
s (ShortByteString -> OneEraHash xs
forall k (xs :: [k]). ShortByteString -> OneEraHash xs
OneEraHash (Proxy blk -> HeaderHash blk -> ShortByteString
forall blk (proxy :: * -> *).
ConvertRawHash blk =>
proxy blk -> HeaderHash blk -> ShortByteString
forall (proxy :: * -> *).
proxy blk -> HeaderHash blk -> ShortByteString
toShortRawHash (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @blk) HeaderHash blk
h))

{-------------------------------------------------------------------------------
  LedgerSupportsPeras
-------------------------------------------------------------------------------}

instance CanHardFork xs => LedgerStateSupportsPeras (LedgerState (HardForkBlock xs)) where
  getPoolDistr :: LedgerState (HardForkBlock xs) EmptyMK -> PoolDistr
getPoolDistr =
    NS (K PoolDistr) xs -> PoolDistr
NS (K PoolDistr) xs -> CollapseTo NS PoolDistr
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 PoolDistr) xs -> PoolDistr)
-> (LedgerState (HardForkBlock xs) EmptyMK -> NS (K PoolDistr) xs)
-> LedgerState (HardForkBlock xs) EmptyMK
-> PoolDistr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    Flip LedgerState EmptyMK a -> K PoolDistr a)
-> NS (Flip LedgerState EmptyMK) xs
-> NS (K PoolDistr) 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 (PoolDistr -> K PoolDistr a
forall k a (b :: k). a -> K a b
K (PoolDistr -> K PoolDistr a)
-> (Flip LedgerState EmptyMK a -> PoolDistr)
-> Flip LedgerState EmptyMK a
-> K PoolDistr a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState a EmptyMK -> PoolDistr
forall (ledgerState :: MapKind -> *).
LedgerStateSupportsPeras ledgerState =>
ledgerState EmptyMK -> PoolDistr
getPoolDistr (LedgerState a EmptyMK -> PoolDistr)
-> (Flip LedgerState EmptyMK a -> LedgerState a EmptyMK)
-> Flip LedgerState EmptyMK a
-> PoolDistr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Flip LedgerState EmptyMK a -> LedgerState a EmptyMK
forall x1 y1 (f :: x1 -> y1 -> *) (x2 :: y1) (y2 :: x1).
Flip f x2 y2 -> f y2 x2
unFlip)
      (NS (Flip LedgerState EmptyMK) xs -> NS (K PoolDistr) xs)
-> (LedgerState (HardForkBlock xs) EmptyMK
    -> NS (Flip LedgerState EmptyMK) xs)
-> LedgerState (HardForkBlock xs) EmptyMK
-> NS (K PoolDistr) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HardForkState (Flip LedgerState EmptyMK) xs
-> NS (Flip LedgerState EmptyMK) xs
forall (xs :: [*]) (f :: * -> *).
SListI xs =>
HardForkState f xs -> NS f xs
State.tip
      (HardForkState (Flip LedgerState EmptyMK) xs
 -> NS (Flip LedgerState EmptyMK) xs)
-> (LedgerState (HardForkBlock xs) EmptyMK
    -> HardForkState (Flip LedgerState EmptyMK) xs)
-> LedgerState (HardForkBlock xs) EmptyMK
-> NS (Flip LedgerState EmptyMK) xs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState (HardForkBlock xs) EmptyMK
-> HardForkState (Flip LedgerState EmptyMK) xs
forall (xs :: [*]) (mk :: MapKind).
LedgerState (HardForkBlock xs) mk
-> HardForkState (Flip LedgerState mk) xs
hardForkLedgerStatePerEra