{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module Ouroboros.Consensus.HardFork.Combinator.PartialConfig
  ( HasPartialConsensusConfig (..)
  , HasPartialLedgerConfig (..)

    -- * Newtype wrappers
  , WrapPartialConsensusConfig (..)
  , WrapPartialLedgerConfig (..)

    -- * Convenience re-exports
  , EpochInfo (..)
  , Except
  , PastHorizonException
  ) where

import Cardano.Slotting.EpochInfo
import Control.Monad.Except (Except)
import Data.Kind (Type)
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.HardFork.History.Qry (PastHorizonException)
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Node.Serialisation
import Ouroboros.Consensus.Protocol.Abstract

-- | Partial consensus config
class
  ( ConsensusProtocol p
  , NoThunks (PartialConsensusConfig p)
  ) =>
  HasPartialConsensusConfig p
  where
  type PartialConsensusConfig p :: Type
  type PartialConsensusConfig p = ConsensusConfig p

  -- | Construct 'ConsensusConfig' from 'PartialConsensusConfig'
  --
  -- See comments for 'completeLedgerConfig' for some details about the
  -- 'EpochInfo'.
  completeConsensusConfig ::
    proxy p ->
    EpochInfo (Except PastHorizonException) ->
    PartialConsensusConfig p ->
    ConsensusConfig p
  default completeConsensusConfig ::
    PartialConsensusConfig p ~ ConsensusConfig p =>
    proxy p ->
    EpochInfo (Except PastHorizonException) ->
    PartialConsensusConfig p ->
    ConsensusConfig p
  completeConsensusConfig proxy p
_ EpochInfo (Except PastHorizonException)
_ = ConsensusConfig p -> ConsensusConfig p
PartialConsensusConfig p -> ConsensusConfig p
forall a. a -> a
id

  -- | Construct partial consensus config from full consensus config
  --
  -- NOTE: This is basically just losing 'EpochInfo', but that is constant
  -- anyway when we are dealing with a single era.
  toPartialConsensusConfig ::
    proxy p ->
    ConsensusConfig p ->
    PartialConsensusConfig p
  default toPartialConsensusConfig ::
    PartialConsensusConfig p ~ ConsensusConfig p =>
    proxy p ->
    ConsensusConfig p ->
    PartialConsensusConfig p
  toPartialConsensusConfig proxy p
_ = ConsensusConfig p -> ConsensusConfig p
ConsensusConfig p -> PartialConsensusConfig p
forall a. a -> a
id

-- | Partial ledger config
class
  ( UpdateLedger blk
  , Show (PartialLedgerConfig blk)
  , NoThunks (PartialLedgerConfig blk)
  ) =>
  HasPartialLedgerConfig blk
  where
  type PartialLedgerConfig blk :: Type
  type PartialLedgerConfig blk = LedgerConfig blk

  -- | Construct 'LedgerConfig' from 'PartialLedgerCfg'
  --
  -- NOTE: The 'EpochInfo' provided will have limited range, any attempt to
  -- look past its horizon will result in a pure 'PastHorizonException'.
  -- The horizon is determined by the tip of the ledger /state/ (not view)
  -- from which the 'EpochInfo' is derived.
  completeLedgerConfig ::
    proxy blk ->
    EpochInfo (Except PastHorizonException) ->
    PartialLedgerConfig blk ->
    LedgerConfig blk
  default completeLedgerConfig ::
    PartialLedgerConfig blk ~ LedgerConfig blk =>
    proxy blk ->
    EpochInfo (Except PastHorizonException) ->
    PartialLedgerConfig blk ->
    LedgerConfig blk
  completeLedgerConfig proxy blk
_ EpochInfo (Except PastHorizonException)
_ = PartialLedgerConfig blk -> LedgerConfig blk
PartialLedgerConfig blk -> PartialLedgerConfig blk
forall a. a -> a
id

{-------------------------------------------------------------------------------
  Newtype wrappers
-------------------------------------------------------------------------------}

newtype WrapPartialLedgerConfig blk = WrapPartialLedgerConfig
  {forall blk. WrapPartialLedgerConfig blk -> PartialLedgerConfig blk
unwrapPartialLedgerConfig :: PartialLedgerConfig blk}
newtype WrapPartialConsensusConfig blk = WrapPartialConsensusConfig
  {forall blk.
WrapPartialConsensusConfig blk
-> PartialConsensusConfig (BlockProtocol blk)
unwrapPartialConsensusConfig :: PartialConsensusConfig (BlockProtocol blk)}

deriving instance
  NoThunks (PartialLedgerConfig blk) => NoThunks (WrapPartialLedgerConfig blk)
deriving instance
  NoThunks (PartialConsensusConfig (BlockProtocol blk)) => NoThunks (WrapPartialConsensusConfig blk)

deriving newtype instance
  SerialiseNodeToClient blk (PartialLedgerConfig blk) =>
  SerialiseNodeToClient blk (WrapPartialLedgerConfig blk)