{-# 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           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Protocol.Signed

import qualified Cardano.Ledger.Shelley.API as SL

import           Ouroboros.Consensus.Protocol.TPraos
import           Ouroboros.Consensus.Shelley.Eras (EraCrypto)
import           Ouroboros.Consensus.Shelley.Ledger.Block
import           Ouroboros.Consensus.Shelley.Ledger.Config ()
import           Ouroboros.Consensus.Shelley.Protocol.Abstract
                     (ShelleyProtocolHeader, pHeaderIssueNo, pHeaderIssuer,
                     pHeaderVRFValue, 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 = ProtocolHeaderSupportsProtocol proto =>
ShelleyProtocolHeader proto -> ValidateView proto
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 shdr _) = PraosChainSelectView :: forall c.
BlockNo
-> SlotNo
-> VKey 'BlockIssuer c
-> Word64
-> OutputVRF (VRF c)
-> PraosChainSelectView c
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
      , csvLeaderVRF :: OutputVRF (VRF (ProtoCrypto proto))
csvLeaderVRF   = ShelleyProtocolHeader proto -> OutputVRF (VRF (ProtoCrypto proto))
forall proto.
ProtocolHeaderSupportsProtocol proto =>
ShelleyProtocolHeader proto -> OutputVRF (VRF (ProtoCrypto proto))
pHeaderVRFValue 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

-- 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