{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Ouroboros.Consensus.Block.SupportsProtocol (BlockSupportsProtocol (..), selectView) where

import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block.Abstract
import Ouroboros.Consensus.Protocol.Abstract

{-------------------------------------------------------------------------------
  Supported blocks
-------------------------------------------------------------------------------}

-- | Evidence that a block supports its protocol
class
  ( GetHeader blk
  , GetPrevHash blk
  , ConsensusProtocol (BlockProtocol blk)
  , NoThunks (Header blk)
  , NoThunks (BlockConfig blk)
  , NoThunks (CodecConfig blk)
  , NoThunks (StorageConfig blk)
  ) =>
  BlockSupportsProtocol blk
  where
  validateView ::
    BlockConfig blk ->
    Header blk ->
    ValidateView (BlockProtocol blk)

  tiebreakerView ::
    BlockConfig blk ->
    Header blk ->
    TiebreakerView (BlockProtocol blk)
  -- Default chain selection just looks at longest chains
  default tiebreakerView ::
    TiebreakerView (BlockProtocol blk) ~ NoTiebreaker =>
    BlockConfig blk ->
    Header blk ->
    TiebreakerView (BlockProtocol blk)
  tiebreakerView BlockConfig blk
_ Header blk
_ = NoTiebreaker
TiebreakerView (BlockProtocol blk)
NoTiebreaker

  projectChainOrderConfig ::
    BlockConfig blk ->
    ChainOrderConfig (SelectView (BlockProtocol blk))
  default projectChainOrderConfig ::
    ChainOrderConfig (SelectView (BlockProtocol blk)) ~ () =>
    BlockConfig blk ->
    ChainOrderConfig (SelectView (BlockProtocol blk))
  projectChainOrderConfig BlockConfig blk
_ = ()

selectView ::
  BlockSupportsProtocol blk =>
  BlockConfig blk ->
  Header blk ->
  SelectView (BlockProtocol blk)
selectView :: forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> SelectView (BlockProtocol blk)
selectView BlockConfig blk
bcfg Header blk
hdr =
  SelectView
    { svBlockNo :: BlockNo
svBlockNo = Header blk -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header blk
hdr
    , svTiebreakerView :: TiebreakerView (BlockProtocol blk)
svTiebreakerView = BlockConfig blk -> Header blk -> TiebreakerView (BlockProtocol blk)
forall blk.
BlockSupportsProtocol blk =>
BlockConfig blk -> Header blk -> TiebreakerView (BlockProtocol blk)
tiebreakerView BlockConfig blk
bcfg Header blk
hdr
    }