{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# 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

    -- ** 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 (LedgerSupportsPeras (..))
import Ouroboros.Consensus.Protocol.Abstract
import Ouroboros.Consensus.TypeFamilyWrappers
import Ouroboros.Consensus.Util (ShowProxy)

{-------------------------------------------------------------------------------
  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)
          )

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

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