{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Ouroboros.Consensus.HardFork.Combinator.Abstract.CanHardFork (CanHardFork (..)) where

import           Data.Measure (Measure)
import           Data.SOP.Constraint
import           Data.SOP.Functors (Product2)
import           Data.SOP.InPairs (InPairs, RequiringBoth)
import qualified Data.SOP.InPairs as InPairs
import           Data.SOP.NonEmpty
import qualified Data.SOP.Strict as SOP
import           Data.SOP.Tails (Tails)
import qualified Data.SOP.Tails as Tails
import           Data.Typeable
import           NoThunks.Class (NoThunks)
import           Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock
import           Ouroboros.Consensus.HardFork.Combinator.InjectTxs
import           Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel
import           Ouroboros.Consensus.HardFork.Combinator.Translation
import           Ouroboros.Consensus.Ledger.SupportsMempool
import           Ouroboros.Consensus.TypeFamilyWrappers

{-------------------------------------------------------------------------------
  CanHardFork
-------------------------------------------------------------------------------}

class ( All SingleEraBlock xs
      , Typeable xs
      , IsNonEmpty xs
      , Measure     (HardForkTxMeasure xs)
      , HasByteSize (HardForkTxMeasure xs)
      , NoThunks    (HardForkTxMeasure xs)
      , Show        (HardForkTxMeasure xs)
      ) => CanHardFork xs where
  -- | A measure that can accurately represent the 'TxMeasure' of any era.
  --
  -- Usually, this can simply be the union of the sets of components of each
  -- individual era's 'TxMeasure'. (Which is too awkward of a type to express
  -- in Haskell.)
  type HardForkTxMeasure xs

  hardForkEraTranslation :: EraTranslation xs
  hardForkChainSel       :: Tails AcrossEraSelection xs
  hardForkInjectTxs      ::
    InPairs
      ( RequiringBoth
          WrapLedgerConfig
          (Product2 InjectTx InjectValidatedTx)
      )
      xs

  -- | This is ideally exact.
  --
  -- If that's not possible, the result must not be too small, since this is
  -- relied upon to determine which prefix of the mempool's txs will fit in a
  -- valid block.
  hardForkInjTxMeasure :: SOP.NS WrapTxMeasure xs -> HardForkTxMeasure xs

instance SingleEraBlock blk => CanHardFork '[blk] where
  type HardForkTxMeasure '[blk] = TxMeasure blk

  hardForkEraTranslation :: EraTranslation '[blk]
hardForkEraTranslation = EraTranslation '[blk]
forall blk. EraTranslation '[blk]
trivialEraTranslation
  hardForkChainSel :: Tails AcrossEraSelection '[blk]
hardForkChainSel       = Tails AcrossEraSelection '[blk]
forall {k} (f :: k -> k -> *) (x :: k). Tails f '[x]
Tails.mk1
  hardForkInjectTxs :: InPairs
  (RequiringBoth
     WrapLedgerConfig (Product2 InjectTx InjectValidatedTx))
  '[blk]
hardForkInjectTxs      = InPairs
  (RequiringBoth
     WrapLedgerConfig (Product2 InjectTx InjectValidatedTx))
  '[blk]
forall {k} (f :: k -> k -> *) (x :: k). InPairs f '[x]
InPairs.mk1

  hardForkInjTxMeasure :: NS WrapTxMeasure '[blk] -> HardForkTxMeasure '[blk]
hardForkInjTxMeasure (SOP.Z (WrapTxMeasure TxMeasure x
x)) = TxMeasure x
HardForkTxMeasure '[blk]
x