{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -Wno-orphans #-}

module Ouroboros.Consensus.Shelley.Ledger.Protocol () where

import qualified Cardano.Ledger.Shelley.API as SL
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Protocol.Signed
import Ouroboros.Consensus.Protocol.TPraos
import Ouroboros.Consensus.Shelley.Ledger.Block
import Ouroboros.Consensus.Shelley.Ledger.Config (BlockConfig (..))
import Ouroboros.Consensus.Shelley.Protocol.Abstract
  ( ShelleyProtocolHeader
  , pHeaderIssueNo
  , pHeaderIssuer
  , pTieBreakVRFValue
  , protocolHeaderView
  )

{-------------------------------------------------------------------------------
  Support for Transitional Praos consensus algorithm
-------------------------------------------------------------------------------}

type instance BlockProtocol (ShelleyBlock proto era) = proto

instance ShelleyCompatible proto era => BlockSupportsProtocol (ShelleyBlock proto era) where
  validateView :: BlockConfig (ShelleyBlock proto era)
-> Header (ShelleyBlock proto era)
-> ValidateView (BlockProtocol (ShelleyBlock proto era))
validateView BlockConfig (ShelleyBlock proto era)
_cfg = forall proto.
ProtocolHeaderSupportsProtocol proto =>
ShelleyProtocolHeader proto -> ValidateView proto
protocolHeaderView @proto (ShelleyProtocolHeader proto -> ValidateView proto)
-> (Header (ShelleyBlock proto era) -> ShelleyProtocolHeader proto)
-> Header (ShelleyBlock proto era)
-> ValidateView proto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header (ShelleyBlock proto era) -> ShelleyProtocolHeader proto
forall proto era.
Header (ShelleyBlock proto era) -> ShelleyProtocolHeader proto
shelleyHeaderRaw

  selectView :: BlockConfig (ShelleyBlock proto era)
-> Header (ShelleyBlock proto era)
-> SelectView (BlockProtocol (ShelleyBlock proto era))
selectView BlockConfig (ShelleyBlock proto era)
_ hdr :: Header (ShelleyBlock proto era)
hdr@(ShelleyHeader ShelleyProtocolHeader proto
shdr ShelleyHash
_) =
    PraosChainSelectView
      { csvChainLength :: BlockNo
csvChainLength = Header (ShelleyBlock proto era) -> BlockNo
forall b. HasHeader b => b -> BlockNo
blockNo Header (ShelleyBlock proto era)
hdr
      , csvSlotNo :: SlotNo
csvSlotNo = Header (ShelleyBlock proto era) -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot Header (ShelleyBlock proto era)
hdr
      , csvIssuer :: VKey 'BlockIssuer
csvIssuer = VKey 'BlockIssuer
hdrIssuer
      , csvIssueNo :: Word64
csvIssueNo = ShelleyProtocolHeader proto -> Word64
forall proto.
ProtocolHeaderSupportsProtocol proto =>
ShelleyProtocolHeader proto -> Word64
pHeaderIssueNo ShelleyProtocolHeader proto
shdr
      , csvTieBreakVRF :: OutputVRF (VRF (ProtoCrypto proto))
csvTieBreakVRF = ShelleyProtocolHeader proto -> OutputVRF (VRF (ProtoCrypto proto))
forall proto.
ProtocolHeaderSupportsProtocol proto =>
ShelleyProtocolHeader proto -> OutputVRF (VRF (ProtoCrypto proto))
pTieBreakVRFValue ShelleyProtocolHeader proto
shdr
      }
   where
    hdrIssuer :: SL.VKey 'SL.BlockIssuer
    hdrIssuer :: VKey 'BlockIssuer
hdrIssuer = ShelleyProtocolHeader proto -> VKey 'BlockIssuer
forall proto.
ProtocolHeaderSupportsProtocol proto =>
ShelleyProtocolHeader proto -> VKey 'BlockIssuer
pHeaderIssuer ShelleyProtocolHeader proto
shdr

  projectChainOrderConfig :: BlockConfig (ShelleyBlock proto era)
-> ChainOrderConfig
     (SelectView (BlockProtocol (ShelleyBlock proto era)))
projectChainOrderConfig = BlockConfig (ShelleyBlock proto era)
-> ChainOrderConfig
     (SelectView (BlockProtocol (ShelleyBlock proto era)))
BlockConfig (ShelleyBlock proto era) -> VRFTiebreakerFlavor
forall proto era.
BlockConfig (ShelleyBlock proto era) -> VRFTiebreakerFlavor
shelleyVRFTiebreakerFlavor

-- TODO correct place for these two?
type instance
  Signed (Header (ShelleyBlock proto era)) =
    Signed (ShelleyProtocolHeader proto)

instance
  SignedHeader (ShelleyProtocolHeader proto) =>
  SignedHeader (Header (ShelleyBlock proto era))
  where
  headerSigned :: Header (ShelleyBlock proto era)
-> Signed (Header (ShelleyBlock proto era))
headerSigned = ShelleyProtocolHeader proto -> Signed (ShelleyProtocolHeader proto)
forall hdr. SignedHeader hdr => hdr -> Signed hdr
headerSigned (ShelleyProtocolHeader proto
 -> Signed (ShelleyProtocolHeader proto))
-> (Header (ShelleyBlock proto era) -> ShelleyProtocolHeader proto)
-> Header (ShelleyBlock proto era)
-> Signed (ShelleyProtocolHeader proto)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header (ShelleyBlock proto era) -> ShelleyProtocolHeader proto
forall proto era.
Header (ShelleyBlock proto era) -> ShelleyProtocolHeader proto
shelleyHeaderRaw