{-# 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.Eras (EraCrypto)
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 (ProtoCrypto proto)
_) = 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 (ProtoCrypto proto)
csvIssuer      = VKey 'BlockIssuer (EraCrypto era)
VKey 'BlockIssuer (ProtoCrypto proto)
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 (EraCrypto era)
      hdrIssuer :: VKey 'BlockIssuer (EraCrypto era)
hdrIssuer = ShelleyProtocolHeader proto
-> VKey 'BlockIssuer (ProtoCrypto proto)
forall proto.
ProtocolHeaderSupportsProtocol proto =>
ShelleyProtocolHeader proto
-> VKey 'BlockIssuer (ProtoCrypto proto)
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