{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Consensus.Cardano.ShelleyHFC (
    ShelleyBlockHFC
  ) where

import qualified Data.Map.Strict as Map
import           Data.SOP.Strict

import           Ouroboros.Consensus.Config
import           Ouroboros.Consensus.Node.NetworkProtocolVersion

import           Ouroboros.Consensus.HardFork.Combinator
import           Ouroboros.Consensus.HardFork.Combinator.Serialisation.Common

import           Ouroboros.Consensus.Shelley.Ledger
import           Ouroboros.Consensus.Shelley.Node ()
import           Ouroboros.Consensus.Shelley.Protocol

import           Ouroboros.Consensus.Cardano.CanHardFork
import           Ouroboros.Consensus.Cardano.Node ()

{-------------------------------------------------------------------------------
  Synonym for convenience
-------------------------------------------------------------------------------}

-- | Shelley as the single era in the hard fork combinator
type ShelleyBlockHFC era = HardForkBlock '[ShelleyBlock era]

{-------------------------------------------------------------------------------
  NoHardForks instance
-------------------------------------------------------------------------------}

instance ShelleyBasedEra era => NoHardForks (ShelleyBlock era) where
  getEraParams :: TopLevelConfig (ShelleyBlock era) -> EraParams
getEraParams =
        ShelleyGenesis era -> EraParams
forall era. ShelleyGenesis era -> EraParams
shelleyEraParamsNeverHardForks
      (ShelleyGenesis era -> EraParams)
-> (TopLevelConfig (ShelleyBlock era) -> ShelleyGenesis era)
-> TopLevelConfig (ShelleyBlock era)
-> EraParams
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShelleyLedgerConfig era -> ShelleyGenesis era
forall era. ShelleyLedgerConfig era -> ShelleyGenesis era
shelleyLedgerGenesis
      (ShelleyLedgerConfig era -> ShelleyGenesis era)
-> (TopLevelConfig (ShelleyBlock era) -> ShelleyLedgerConfig era)
-> TopLevelConfig (ShelleyBlock era)
-> ShelleyGenesis era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevelConfig (ShelleyBlock era) -> ShelleyLedgerConfig era
forall blk. TopLevelConfig blk -> LedgerConfig blk
configLedger
  toPartialConsensusConfig :: proxy (ShelleyBlock era)
-> ConsensusConfig (BlockProtocol (ShelleyBlock era))
-> PartialConsensusConfig (BlockProtocol (ShelleyBlock era))
toPartialConsensusConfig proxy (ShelleyBlock era)
_  = ConsensusConfig (BlockProtocol (ShelleyBlock era))
-> PartialConsensusConfig (BlockProtocol (ShelleyBlock era))
forall c. ConsensusConfig (TPraos c) -> TPraosParams
tpraosParams
  toPartialLedgerConfig :: proxy (ShelleyBlock era)
-> LedgerConfig (ShelleyBlock era)
-> PartialLedgerConfig (ShelleyBlock era)
toPartialLedgerConfig proxy (ShelleyBlock era)
_ LedgerConfig (ShelleyBlock era)
cfg = ShelleyPartialLedgerConfig :: forall era.
ShelleyLedgerConfig era
-> TriggerHardFork -> ShelleyPartialLedgerConfig era
ShelleyPartialLedgerConfig {
        shelleyLedgerConfig :: ShelleyLedgerConfig era
shelleyLedgerConfig    = LedgerConfig (ShelleyBlock era)
ShelleyLedgerConfig era
cfg
      , shelleyTriggerHardFork :: TriggerHardFork
shelleyTriggerHardFork = TriggerHardFork
TriggerHardForkNever
      }

{-------------------------------------------------------------------------------
  SupportedNetworkProtocolVersion instance
-------------------------------------------------------------------------------}

-- | Forward to the ShelleyBlock instance. Only supports
-- 'HardForkNodeToNodeDisabled', which is compatible with nodes running with
-- 'ShelleyBlock'.
instance ShelleyBasedEra era
      => SupportedNetworkProtocolVersion (ShelleyBlockHFC era) where
  supportedNodeToNodeVersions :: Proxy (ShelleyBlockHFC era)
-> Map
     NodeToNodeVersion (BlockNodeToNodeVersion (ShelleyBlockHFC era))
supportedNodeToNodeVersions Proxy (ShelleyBlockHFC era)
_ =
      (ShelleyNodeToNodeVersion
 -> HardForkNodeToNodeVersion '[ShelleyBlock era])
-> Map NodeToNodeVersion ShelleyNodeToNodeVersion
-> Map
     NodeToNodeVersion (HardForkNodeToNodeVersion '[ShelleyBlock era])
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ShelleyNodeToNodeVersion
-> HardForkNodeToNodeVersion '[ShelleyBlock era]
forall x (xs1 :: [*]).
BlockNodeToNodeVersion x -> HardForkNodeToNodeVersion (x : xs1)
HardForkNodeToNodeDisabled (Map NodeToNodeVersion ShelleyNodeToNodeVersion
 -> Map
      NodeToNodeVersion (HardForkNodeToNodeVersion '[ShelleyBlock era]))
-> Map NodeToNodeVersion ShelleyNodeToNodeVersion
-> Map
     NodeToNodeVersion (HardForkNodeToNodeVersion '[ShelleyBlock era])
forall a b. (a -> b) -> a -> b
$
      Proxy (ShelleyBlock era)
-> Map
     NodeToNodeVersion (BlockNodeToNodeVersion (ShelleyBlock era))
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> Map NodeToNodeVersion (BlockNodeToNodeVersion blk)
supportedNodeToNodeVersions (Proxy (ShelleyBlock era)
forall k (t :: k). Proxy t
Proxy @(ShelleyBlock era))

  supportedNodeToClientVersions :: Proxy (ShelleyBlockHFC era)
-> Map
     NodeToClientVersion
     (BlockNodeToClientVersion (ShelleyBlockHFC era))
supportedNodeToClientVersions Proxy (ShelleyBlockHFC era)
_ =
      (ShelleyNodeToClientVersion
 -> HardForkNodeToClientVersion '[ShelleyBlock era])
-> Map NodeToClientVersion ShelleyNodeToClientVersion
-> Map
     NodeToClientVersion
     (HardForkNodeToClientVersion '[ShelleyBlock era])
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ShelleyNodeToClientVersion
-> HardForkNodeToClientVersion '[ShelleyBlock era]
forall x (xs1 :: [*]).
BlockNodeToClientVersion x -> HardForkNodeToClientVersion (x : xs1)
HardForkNodeToClientDisabled (Map NodeToClientVersion ShelleyNodeToClientVersion
 -> Map
      NodeToClientVersion
      (HardForkNodeToClientVersion '[ShelleyBlock era]))
-> Map NodeToClientVersion ShelleyNodeToClientVersion
-> Map
     NodeToClientVersion
     (HardForkNodeToClientVersion '[ShelleyBlock era])
forall a b. (a -> b) -> a -> b
$
      Proxy (ShelleyBlock era)
-> Map
     NodeToClientVersion (BlockNodeToClientVersion (ShelleyBlock era))
forall blk.
SupportedNetworkProtocolVersion blk =>
Proxy blk -> Map NodeToClientVersion (BlockNodeToClientVersion blk)
supportedNodeToClientVersions (Proxy (ShelleyBlock era)
forall k (t :: k). Proxy t
Proxy @(ShelleyBlock era))

{-------------------------------------------------------------------------------
  SerialiseHFC instance
-------------------------------------------------------------------------------}

-- | Use the default implementations. This means the serialisation of blocks
-- includes an era wrapper. Each block should do this from the start to be
-- prepared for future hard forks without having to do any bit twiddling.
instance ShelleyBasedEra era => SerialiseHFC '[ShelleyBlock era]