{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}

-- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Protocol/Types.hs

module Cardano.Api.Protocol.Types (
    BlockType (..)
  , Protocol (..)
  , ProtocolClient (..)
  , ProtocolClientInfoArgs (..)
  , ProtocolInfoArgs (..)
  ) where

import           Cardano.Chain.Slotting (EpochSlots)
import           Data.Bifunctor (bimap)
import           Ouroboros.Consensus.Block.Forging (BlockForging)
import           Ouroboros.Consensus.Cardano
import           Ouroboros.Consensus.Cardano.Block
import           Ouroboros.Consensus.Cardano.ByronHFC (ByronBlockHFC)
import           Ouroboros.Consensus.Cardano.Node
import           Ouroboros.Consensus.HardFork.Combinator.Embed.Unary
import qualified Ouroboros.Consensus.Ledger.SupportsProtocol as Consensus
                     (LedgerSupportsProtocol)
import           Ouroboros.Consensus.Node.ProtocolInfo (ProtocolClientInfo (..),
                     ProtocolInfo (..))
import           Ouroboros.Consensus.Node.Run (RunNode)
import qualified Ouroboros.Consensus.Protocol.TPraos as Consensus
import qualified Ouroboros.Consensus.Shelley.Eras as Consensus (ShelleyEra)
import qualified Ouroboros.Consensus.Shelley.Ledger.Block as Consensus
                     (ShelleyBlock)
import           Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol ()
import           Ouroboros.Consensus.Shelley.ShelleyHFC (ShelleyBlockHFC)
import           Ouroboros.Consensus.Util.IOLike (IOLike)


class (RunNode blk, IOLike m) => Protocol m blk where
  data ProtocolInfoArgs m blk
  protocolInfo :: ProtocolInfoArgs m blk -> ( ProtocolInfo blk
                                            , m [BlockForging m blk]
                                            )

-- | Node client support for each consensus protocol.
--
-- This is like 'Protocol' but for clients of the node, so with less onerous
-- requirements than to run a node.
--
class RunNode blk => ProtocolClient blk where
  data ProtocolClientInfoArgs blk
  protocolClientInfo :: ProtocolClientInfoArgs blk -> ProtocolClientInfo blk


-- | Run PBFT against the Byron ledger
instance IOLike m => Protocol m ByronBlockHFC where
  data ProtocolInfoArgs m ByronBlockHFC = ProtocolInfoArgsByron ProtocolParamsByron
  protocolInfo :: ProtocolInfoArgs m (HardForkBlock '[ByronBlock])
-> (ProtocolInfo (HardForkBlock '[ByronBlock]),
    m [BlockForging m (HardForkBlock '[ByronBlock])])
protocolInfo (ProtocolInfoArgsByron ProtocolParamsByron
params) = ( ProtocolInfo ByronBlock
-> ProtocolInfo (HardForkBlock '[ByronBlock])
forall blk.
NoHardForks blk =>
ProtocolInfo blk -> ProtocolInfo (HardForkBlock '[blk])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject (ProtocolInfo ByronBlock
 -> ProtocolInfo (HardForkBlock '[ByronBlock]))
-> ProtocolInfo ByronBlock
-> ProtocolInfo (HardForkBlock '[ByronBlock])
forall a b. (a -> b) -> a -> b
$ ProtocolParamsByron -> ProtocolInfo ByronBlock
protocolInfoByron ProtocolParamsByron
params
                                                , [BlockForging m (HardForkBlock '[ByronBlock])]
-> m [BlockForging m (HardForkBlock '[ByronBlock])]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([BlockForging m (HardForkBlock '[ByronBlock])]
 -> m [BlockForging m (HardForkBlock '[ByronBlock])])
-> ([BlockForging m ByronBlock]
    -> [BlockForging m (HardForkBlock '[ByronBlock])])
-> [BlockForging m ByronBlock]
-> m [BlockForging m (HardForkBlock '[ByronBlock])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (BlockForging m ByronBlock
 -> BlockForging m (HardForkBlock '[ByronBlock]))
-> [BlockForging m ByronBlock]
-> [BlockForging m (HardForkBlock '[ByronBlock])]
forall a b. (a -> b) -> [a] -> [b]
map BlockForging m ByronBlock
-> BlockForging m (HardForkBlock '[ByronBlock])
forall blk.
NoHardForks blk =>
BlockForging m blk -> BlockForging m (HardForkBlock '[blk])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject ([BlockForging m ByronBlock]
 -> m [BlockForging m (HardForkBlock '[ByronBlock])])
-> [BlockForging m ByronBlock]
-> m [BlockForging m (HardForkBlock '[ByronBlock])]
forall a b. (a -> b) -> a -> b
$ ProtocolParamsByron -> [BlockForging m ByronBlock]
forall (m :: * -> *).
Monad m =>
ProtocolParamsByron -> [BlockForging m ByronBlock]
blockForgingByron ProtocolParamsByron
params
                                                )

instance (CardanoHardForkConstraints StandardCrypto, IOLike m) => Protocol m (CardanoBlock StandardCrypto) where
  data ProtocolInfoArgs m (CardanoBlock StandardCrypto) =
         ProtocolInfoArgsCardano
          (CardanoProtocolParams StandardCrypto)

  protocolInfo :: ProtocolInfoArgs m (HardForkBlock (CardanoEras StandardCrypto))
-> (ProtocolInfo (HardForkBlock (CardanoEras StandardCrypto)),
    m [BlockForging m (HardForkBlock (CardanoEras StandardCrypto))])
protocolInfo (ProtocolInfoArgsCardano CardanoProtocolParams StandardCrypto
paramsCardano) =
      CardanoProtocolParams StandardCrypto
-> (ProtocolInfo (HardForkBlock (CardanoEras StandardCrypto)),
    m [BlockForging m (HardForkBlock (CardanoEras StandardCrypto))])
forall c (m :: * -> *).
(IOLike m, CardanoHardForkConstraints c) =>
CardanoProtocolParams c
-> (ProtocolInfo (CardanoBlock c),
    m [BlockForging m (CardanoBlock c)])
protocolInfoCardano CardanoProtocolParams StandardCrypto
paramsCardano

instance ProtocolClient ByronBlockHFC where
  data ProtocolClientInfoArgs ByronBlockHFC =
    ProtocolClientInfoArgsByron EpochSlots
  protocolClientInfo :: ProtocolClientInfoArgs (HardForkBlock '[ByronBlock])
-> ProtocolClientInfo (HardForkBlock '[ByronBlock])
protocolClientInfo (ProtocolClientInfoArgsByron EpochSlots
epochSlots) =
    ProtocolClientInfo ByronBlock
-> ProtocolClientInfo (HardForkBlock '[ByronBlock])
forall blk.
NoHardForks blk =>
ProtocolClientInfo blk -> ProtocolClientInfo (HardForkBlock '[blk])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject (ProtocolClientInfo ByronBlock
 -> ProtocolClientInfo (HardForkBlock '[ByronBlock]))
-> ProtocolClientInfo ByronBlock
-> ProtocolClientInfo (HardForkBlock '[ByronBlock])
forall a b. (a -> b) -> a -> b
$ EpochSlots -> ProtocolClientInfo ByronBlock
protocolClientInfoByron EpochSlots
epochSlots

instance CardanoHardForkConstraints StandardCrypto => ProtocolClient (CardanoBlock StandardCrypto) where
  data ProtocolClientInfoArgs (CardanoBlock StandardCrypto) =
    ProtocolClientInfoArgsCardano EpochSlots
  protocolClientInfo :: ProtocolClientInfoArgs (HardForkBlock (CardanoEras StandardCrypto))
-> ProtocolClientInfo (HardForkBlock (CardanoEras StandardCrypto))
protocolClientInfo (ProtocolClientInfoArgsCardano EpochSlots
epochSlots) =
    EpochSlots
-> ProtocolClientInfo (HardForkBlock (CardanoEras StandardCrypto))
forall c. EpochSlots -> ProtocolClientInfo (CardanoBlock c)
protocolClientInfoCardano EpochSlots
epochSlots

instance ( IOLike m
         , Consensus.LedgerSupportsProtocol
             (Consensus.ShelleyBlock
                (Consensus.TPraos StandardCrypto) (ShelleyEra StandardCrypto))
         )
  => Protocol m (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley) where
  data ProtocolInfoArgs m (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley) = ProtocolInfoArgsShelley
    (ShelleyGenesis StandardCrypto)
    (ProtocolParamsShelleyBased StandardCrypto)
    ProtVer
  protocolInfo :: ProtocolInfoArgs
  m
  (HardForkBlock
     '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])
-> (ProtocolInfo
      (HardForkBlock
         '[ShelleyBlock (TPraos StandardCrypto) StandardShelley]),
    m [BlockForging
         m
         (HardForkBlock
            '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])])
protocolInfo (ProtocolInfoArgsShelley ShelleyGenesis StandardCrypto
genesis ProtocolParamsShelleyBased StandardCrypto
shelleyBasedProtocolParams' ProtVer
protVer) =
    (ProtocolInfo
   (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
 -> ProtocolInfo
      (HardForkBlock
         '[ShelleyBlock (TPraos StandardCrypto) StandardShelley]))
-> (m [BlockForging
         m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)]
    -> m [BlockForging
            m
            (HardForkBlock
               '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])])
-> (ProtocolInfo
      (ShelleyBlock (TPraos StandardCrypto) StandardShelley),
    m [BlockForging
         m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)])
-> (ProtocolInfo
      (HardForkBlock
         '[ShelleyBlock (TPraos StandardCrypto) StandardShelley]),
    m [BlockForging
         m
         (HardForkBlock
            '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])])
forall a b c d. (a -> b) -> (c -> d) -> (a, c) -> (b, d)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ProtocolInfo (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
-> ProtocolInfo
     (HardForkBlock
        '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])
forall blk.
NoHardForks blk =>
ProtocolInfo blk -> ProtocolInfo (HardForkBlock '[blk])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject (([BlockForging
    m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)]
 -> [BlockForging
       m
       (HardForkBlock
          '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])])
-> m [BlockForging
        m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)]
-> m [BlockForging
        m
        (HardForkBlock
           '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])]
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([BlockForging
     m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)]
  -> [BlockForging
        m
        (HardForkBlock
           '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])])
 -> m [BlockForging
         m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)]
 -> m [BlockForging
         m
         (HardForkBlock
            '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])])
-> ([BlockForging
       m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)]
    -> [BlockForging
          m
          (HardForkBlock
             '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])])
-> m [BlockForging
        m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)]
-> m [BlockForging
        m
        (HardForkBlock
           '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])]
forall a b. (a -> b) -> a -> b
$ (BlockForging
   m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
 -> BlockForging
      m
      (HardForkBlock
         '[ShelleyBlock (TPraos StandardCrypto) StandardShelley]))
-> [BlockForging
      m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)]
-> [BlockForging
      m
      (HardForkBlock
         '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])]
forall a b. (a -> b) -> [a] -> [b]
map BlockForging
  m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
-> BlockForging
     m
     (HardForkBlock
        '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])
forall blk.
NoHardForks blk =>
BlockForging m blk -> BlockForging m (HardForkBlock '[blk])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject) ((ProtocolInfo
    (ShelleyBlock (TPraos StandardCrypto) StandardShelley),
  m [BlockForging
       m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)])
 -> (ProtocolInfo
       (HardForkBlock
          '[ShelleyBlock (TPraos StandardCrypto) StandardShelley]),
     m [BlockForging
          m
          (HardForkBlock
             '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])]))
-> (ProtocolInfo
      (ShelleyBlock (TPraos StandardCrypto) StandardShelley),
    m [BlockForging
         m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)])
-> (ProtocolInfo
      (HardForkBlock
         '[ShelleyBlock (TPraos StandardCrypto) StandardShelley]),
    m [BlockForging
         m
         (HardForkBlock
            '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])])
forall a b. (a -> b) -> a -> b
$ ShelleyGenesis StandardCrypto
-> ProtocolParamsShelleyBased StandardCrypto
-> ProtVer
-> (ProtocolInfo
      (ShelleyBlock (TPraos StandardCrypto) StandardShelley),
    m [BlockForging
         m (ShelleyBlock (TPraos StandardCrypto) StandardShelley)])
forall (m :: * -> *) c.
(IOLike m, PraosCrypto c,
 ShelleyCompatible (TPraos c) (ShelleyEra c),
 TxLimits (ShelleyBlock (TPraos c) (ShelleyEra c))) =>
ShelleyGenesis c
-> ProtocolParamsShelleyBased c
-> ProtVer
-> (ProtocolInfo (ShelleyBlock (TPraos c) (ShelleyEra c)),
    m [BlockForging m (ShelleyBlock (TPraos c) (ShelleyEra c))])
protocolInfoShelley ShelleyGenesis StandardCrypto
genesis ProtocolParamsShelleyBased StandardCrypto
shelleyBasedProtocolParams' ProtVer
protVer

instance Consensus.LedgerSupportsProtocol
          (Consensus.ShelleyBlock
            (Consensus.TPraos StandardCrypto) (Consensus.ShelleyEra StandardCrypto))
  => ProtocolClient (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley) where
  data ProtocolClientInfoArgs (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley) =
    ProtocolClientInfoArgsShelley
  protocolClientInfo :: ProtocolClientInfoArgs
  (HardForkBlock
     '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])
-> ProtocolClientInfo
     (HardForkBlock
        '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])
protocolClientInfo ProtocolClientInfoArgs
  (HardForkBlock
     '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])
R:ProtocolClientInfoArgsHardForkBlock
ProtocolClientInfoArgsShelley =
    ProtocolClientInfo
  (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
-> ProtocolClientInfo
     (HardForkBlock
        '[ShelleyBlock (TPraos StandardCrypto) StandardShelley])
forall blk.
NoHardForks blk =>
ProtocolClientInfo blk -> ProtocolClientInfo (HardForkBlock '[blk])
forall (f :: * -> *) blk.
(Isomorphic f, NoHardForks blk) =>
f blk -> f (HardForkBlock '[blk])
inject ProtocolClientInfo
  (ShelleyBlock (TPraos StandardCrypto) StandardShelley)
forall proto era. ProtocolClientInfo (ShelleyBlock proto era)
protocolClientInfoShelley

data BlockType blk where
  ByronBlockType :: BlockType ByronBlockHFC
  ShelleyBlockType :: BlockType (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley)
  CardanoBlockType :: BlockType (CardanoBlock StandardCrypto)

deriving instance Eq (BlockType blk)
deriving instance Show (BlockType blk)