{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-orphans #-}

-- | This module contains 'SupportsProtocol' instances tying the ledger and
-- protocol together. Since these instances reference both ledger concerns and
-- protocol concerns, it is the one class where we cannot provide a generic
-- instance for 'ShelleyBlock'.
module Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () where

import qualified Cardano.Ledger.Core as LedgerCore
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Protocol.TPraos.API as SL
import           Control.Monad.Except (MonadError (throwError))
import           Data.Coerce (coerce)
import qualified Lens.Micro
import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Forecast
import           Ouroboros.Consensus.HardFork.History.Util
import           Ouroboros.Consensus.Ledger.Abstract
import           Ouroboros.Consensus.Ledger.SupportsProtocol
                     (LedgerSupportsProtocol (..))
import           Ouroboros.Consensus.Ledger.Tables.Utils
import           Ouroboros.Consensus.Protocol.Abstract (translateLedgerView)
import           Ouroboros.Consensus.Protocol.Praos (Praos)
import qualified Ouroboros.Consensus.Protocol.Praos.Views as Praos
import           Ouroboros.Consensus.Protocol.TPraos (TPraos)
import           Ouroboros.Consensus.Shelley.Ledger.Block
import           Ouroboros.Consensus.Shelley.Ledger.Ledger
import           Ouroboros.Consensus.Shelley.Ledger.Protocol ()
import           Ouroboros.Consensus.Shelley.Protocol.Abstract ()
import           Ouroboros.Consensus.Shelley.Protocol.Praos ()
import           Ouroboros.Consensus.Shelley.Protocol.TPraos ()

instance
  (ShelleyCompatible (TPraos crypto) era) =>
  LedgerSupportsProtocol (ShelleyBlock (TPraos crypto) era)
  where
  protocolLedgerView :: forall (mk :: MapKind).
LedgerConfig (ShelleyBlock (TPraos crypto) era)
-> Ticked (LedgerState (ShelleyBlock (TPraos crypto) era)) mk
-> LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era))
protocolLedgerView LedgerConfig (ShelleyBlock (TPraos crypto) era)
_cfg = NewEpochState era -> LedgerView
forall era. GetLedgerView era => NewEpochState era -> LedgerView
SL.currentLedgerView (NewEpochState era -> LedgerView)
-> (Ticked (LedgerState (ShelleyBlock (TPraos crypto) era)) mk
    -> NewEpochState era)
-> Ticked (LedgerState (ShelleyBlock (TPraos crypto) era)) mk
-> LedgerView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked (LedgerState (ShelleyBlock (TPraos crypto) era)) mk
-> NewEpochState era
forall proto era (mk :: MapKind).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> NewEpochState era
tickedShelleyLedgerState

  -- Extra context available in
  -- https://github.com/IntersectMBO/ouroboros-consensus/blob/main/docs/website/contents/for-developers/HardWonWisdom.md#why-doesnt-ledger-code-ever-return-pasthorizonexception
  ledgerViewForecastAt :: forall (mk :: MapKind).
HasCallStack =>
LedgerConfig (ShelleyBlock (TPraos crypto) era)
-> LedgerState (ShelleyBlock (TPraos crypto) era) mk
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era)))
ledgerViewForecastAt LedgerConfig (ShelleyBlock (TPraos crypto) era)
cfg LedgerState (ShelleyBlock (TPraos crypto) era) mk
ledgerState = WithOrigin SlotNo
-> (SlotNo
    -> Except
         OutsideForecastRange
         (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era))))
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era)))
forall a.
WithOrigin SlotNo
-> (SlotNo -> Except OutsideForecastRange a) -> Forecast a
Forecast WithOrigin SlotNo
at ((SlotNo
  -> Except
       OutsideForecastRange
       (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era))))
 -> Forecast
      (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era))))
-> (SlotNo
    -> Except
         OutsideForecastRange
         (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era))))
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era)))
forall a b. (a -> b) -> a -> b
$ \SlotNo
for ->
    if
        | SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
for WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Eq a => a -> a -> Bool
== WithOrigin SlotNo
at ->
          LedgerView -> ExceptT OutsideForecastRange Identity LedgerView
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerView -> ExceptT OutsideForecastRange Identity LedgerView)
-> LedgerView -> ExceptT OutsideForecastRange Identity LedgerView
forall a b. (a -> b) -> a -> b
$ NewEpochState era -> LedgerView
forall era. GetLedgerView era => NewEpochState era -> LedgerView
SL.currentLedgerView NewEpochState era
shelleyLedgerState
        | SlotNo
for SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
maxFor ->
          LedgerView -> ExceptT OutsideForecastRange Identity LedgerView
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (LedgerView -> ExceptT OutsideForecastRange Identity LedgerView)
-> LedgerView -> ExceptT OutsideForecastRange Identity LedgerView
forall a b. (a -> b) -> a -> b
$ SlotNo -> LedgerView
futureLedgerView SlotNo
for
        | Bool
otherwise ->
          OutsideForecastRange
-> Except
     OutsideForecastRange
     (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era)))
forall a.
OutsideForecastRange -> ExceptT OutsideForecastRange Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (OutsideForecastRange
 -> Except
      OutsideForecastRange
      (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era))))
-> OutsideForecastRange
-> Except
     OutsideForecastRange
     (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era)))
forall a b. (a -> b) -> a -> b
$
            OutsideForecastRange
              { outsideForecastAt :: WithOrigin SlotNo
outsideForecastAt = WithOrigin SlotNo
at,
                outsideForecastMaxFor :: SlotNo
outsideForecastMaxFor = SlotNo
maxFor,
                outsideForecastFor :: SlotNo
outsideForecastFor = SlotNo
for
              }
    where
      ShelleyLedgerState {NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState :: forall proto era (mk :: MapKind).
LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
shelleyLedgerState} = LedgerState (ShelleyBlock (TPraos crypto) era) mk
ledgerState
      globals :: Globals
globals = ShelleyLedgerConfig era -> Globals
forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals LedgerConfig (ShelleyBlock (TPraos crypto) era)
ShelleyLedgerConfig era
cfg
      swindow :: Word64
swindow = Globals -> Word64
SL.stabilityWindow Globals
globals
      at :: WithOrigin SlotNo
at = LedgerState (ShelleyBlock (TPraos crypto) era) mk
-> WithOrigin SlotNo
forall blk (mk :: MapKind).
UpdateLedger blk =>
LedgerState blk mk -> WithOrigin SlotNo
ledgerTipSlot LedgerState (ShelleyBlock (TPraos crypto) era) mk
ledgerState

      futureLedgerView :: SlotNo -> SL.LedgerView
      futureLedgerView :: SlotNo -> LedgerView
futureLedgerView =
        (FutureLedgerViewError era -> LedgerView)
-> (LedgerView -> LedgerView)
-> Either (FutureLedgerViewError era) LedgerView
-> LedgerView
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          (\FutureLedgerViewError era
e -> [Char] -> LedgerView
forall a. HasCallStack => [Char] -> a
error ([Char]
"futureLedgerView failed: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> FutureLedgerViewError era -> [Char]
forall a. Show a => a -> [Char]
show FutureLedgerViewError era
e))
          LedgerView -> LedgerView
forall a. a -> a
id
          (Either (FutureLedgerViewError era) LedgerView -> LedgerView)
-> (SlotNo -> Either (FutureLedgerViewError era) LedgerView)
-> SlotNo
-> LedgerView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Globals
-> NewEpochState era
-> SlotNo
-> Either (FutureLedgerViewError era) LedgerView
forall era (m :: * -> *).
(GetLedgerView era, MonadError (FutureLedgerViewError era) m) =>
Globals -> NewEpochState era -> SlotNo -> m LedgerView
forall (m :: * -> *).
MonadError (FutureLedgerViewError era) m =>
Globals -> NewEpochState era -> SlotNo -> m LedgerView
SL.futureLedgerView Globals
globals NewEpochState era
shelleyLedgerState

      -- Exclusive upper bound
      maxFor :: SlotNo
      maxFor :: SlotNo
maxFor = Word64 -> SlotNo -> SlotNo
addSlots Word64
swindow (SlotNo -> SlotNo) -> SlotNo -> SlotNo
forall a b. (a -> b) -> a -> b
$ WithOrigin SlotNo -> SlotNo
forall t. (Bounded t, Enum t) => WithOrigin t -> t
succWithOrigin WithOrigin SlotNo
at

instance
  ( ShelleyCompatible (Praos crypto) era,
    ShelleyCompatible (TPraos crypto) era
  ) =>
  LedgerSupportsProtocol (ShelleyBlock (Praos crypto) era)
  where
  protocolLedgerView :: forall (mk :: MapKind).
LedgerConfig (ShelleyBlock (Praos crypto) era)
-> Ticked (LedgerState (ShelleyBlock (Praos crypto) era)) mk
-> LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era))
protocolLedgerView LedgerConfig (ShelleyBlock (Praos crypto) era)
_cfg Ticked (LedgerState (ShelleyBlock (Praos crypto) era)) mk
st =
    let nes :: NewEpochState era
nes = Ticked (LedgerState (ShelleyBlock (Praos crypto) era)) mk
-> NewEpochState era
forall proto era (mk :: MapKind).
Ticked (LedgerState (ShelleyBlock proto era)) mk
-> NewEpochState era
tickedShelleyLedgerState Ticked (LedgerState (ShelleyBlock (Praos crypto) era)) mk
st

        SL.NewEpochState {PoolDistr
nesPd :: PoolDistr
nesPd :: forall era. NewEpochState era -> PoolDistr
nesPd} = NewEpochState era
nes

        pparam :: forall a. Lens.Micro.Lens' (LedgerCore.PParams era) a -> a
        pparam :: forall a. Lens' (PParams era) a -> a
pparam Lens' (PParams era) a
lens = NewEpochState era -> PParams era
forall era. EraGov era => NewEpochState era -> PParams era
getPParams NewEpochState era
nes PParams era -> Getting a (PParams era) a -> a
forall s a. s -> Getting a s a -> a
Lens.Micro.^. Getting a (PParams era) a
Lens' (PParams era) a
lens

     in Praos.LedgerView
          { lvPoolDistr :: PoolDistr
Praos.lvPoolDistr       = PoolDistr
nesPd,
            lvMaxBodySize :: Word32
Praos.lvMaxBodySize     = Lens' (PParams era) Word32 -> Word32
forall a. Lens' (PParams era) a -> a
pparam (Word32 -> f Word32) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) Word32
Lens' (PParams era) Word32
LedgerCore.ppMaxBBSizeL,
            lvMaxHeaderSize :: Word16
Praos.lvMaxHeaderSize   = Lens' (PParams era) Word16 -> Word16
forall a. Lens' (PParams era) a -> a
pparam (Word16 -> f Word16) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) Word16
Lens' (PParams era) Word16
LedgerCore.ppMaxBHSizeL,
            lvProtocolVersion :: ProtVer
Praos.lvProtocolVersion = Lens' (PParams era) ProtVer -> ProtVer
forall a. Lens' (PParams era) a -> a
pparam (ProtVer -> f ProtVer) -> PParams era -> f (PParams era)
forall era. EraPParams era => Lens' (PParams era) ProtVer
Lens' (PParams era) ProtVer
LedgerCore.ppProtocolVersionL
          }

  -- | Currently the Shelley+ ledger is hard-coded to produce a TPraos ledger
  -- view. Since we can convert them, we piggy-back on this to get a Praos
  -- ledger view. Ultimately, we will want to liberalise the ledger code
  -- slightly.
  ledgerViewForecastAt :: forall (mk :: MapKind).
HasCallStack =>
LedgerConfig (ShelleyBlock (Praos crypto) era)
-> LedgerState (ShelleyBlock (Praos crypto) era) mk
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era)))
ledgerViewForecastAt LedgerConfig (ShelleyBlock (Praos crypto) era)
cfg LedgerState (ShelleyBlock (Praos crypto) era) mk
st =
    (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era))
 -> LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era)))
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era)))
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era)))
forall a b. (a -> b) -> Forecast a -> Forecast b
mapForecast (Proxy (TPraos crypto, Praos crypto)
-> LedgerView (TPraos crypto) -> LedgerView (Praos crypto)
forall protoFrom protoTo.
TranslateProto protoFrom protoTo =>
Proxy (protoFrom, protoTo)
-> LedgerView protoFrom -> LedgerView protoTo
translateLedgerView (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(TPraos crypto, Praos crypto))) (Forecast
   (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era)))
 -> Forecast
      (LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era))))
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (TPraos crypto) era)))
-> Forecast
     (LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era)))
forall a b. (a -> b) -> a -> b
$
      forall blk (mk :: MapKind).
(LedgerSupportsProtocol blk, HasCallStack) =>
LedgerConfig blk
-> LedgerState blk mk -> Forecast (LedgerView (BlockProtocol blk))
ledgerViewForecastAt @(ShelleyBlock (TPraos crypto) era) LedgerConfig (ShelleyBlock (TPraos crypto) era)
LedgerConfig (ShelleyBlock (Praos crypto) era)
cfg LedgerState (ShelleyBlock (TPraos crypto) era) EmptyMK
st'
    where
      st' :: LedgerState (ShelleyBlock (TPraos crypto) era) EmptyMK
      st' :: LedgerState (ShelleyBlock (TPraos crypto) era) EmptyMK
st' =
        ShelleyLedgerState
          { shelleyLedgerTip :: WithOrigin (ShelleyTip (TPraos crypto) era)
shelleyLedgerTip = ShelleyTip (Praos crypto) era -> ShelleyTip (TPraos crypto) era
forall {proto} {era} {proto} {era}.
ShelleyTip proto era -> ShelleyTip proto era
coerceTip (ShelleyTip (Praos crypto) era -> ShelleyTip (TPraos crypto) era)
-> WithOrigin (ShelleyTip (Praos crypto) era)
-> WithOrigin (ShelleyTip (TPraos crypto) era)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LedgerState (ShelleyBlock (Praos crypto) era) mk
-> WithOrigin (ShelleyTip (Praos crypto) era)
forall proto era (mk :: MapKind).
LedgerState (ShelleyBlock proto era) mk
-> WithOrigin (ShelleyTip proto era)
shelleyLedgerTip LedgerState (ShelleyBlock (Praos crypto) era) mk
st,
            shelleyLedgerState :: NewEpochState era
shelleyLedgerState = LedgerState (ShelleyBlock (Praos crypto) era) mk
-> NewEpochState era
forall proto era (mk :: MapKind).
LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
shelleyLedgerState LedgerState (ShelleyBlock (Praos crypto) era) mk
st,
            shelleyLedgerTransition :: ShelleyTransition
shelleyLedgerTransition = LedgerState (ShelleyBlock (Praos crypto) era) mk
-> ShelleyTransition
forall proto era (mk :: MapKind).
LedgerState (ShelleyBlock proto era) mk -> ShelleyTransition
shelleyLedgerTransition LedgerState (ShelleyBlock (Praos crypto) era) mk
st,
            shelleyLedgerTables :: LedgerTables
  (LedgerState (ShelleyBlock (TPraos crypto) era)) EmptyMK
shelleyLedgerTables = LedgerTables
  (LedgerState (ShelleyBlock (TPraos crypto) era)) EmptyMK
forall (mk :: MapKind) (l :: MapKind -> *).
(ZeroableMK mk, LedgerTableConstraints l) =>
LedgerTables l mk
emptyLedgerTables
          }
      coerceTip :: ShelleyTip proto era -> ShelleyTip proto era
coerceTip (ShelleyTip SlotNo
slot BlockNo
block HeaderHash (ShelleyBlock proto era)
hash) = SlotNo
-> BlockNo
-> HeaderHash (ShelleyBlock proto era)
-> ShelleyTip proto era
forall proto era.
SlotNo
-> BlockNo
-> HeaderHash (ShelleyBlock proto era)
-> ShelleyTip proto era
ShelleyTip SlotNo
slot BlockNo
block (ShelleyHash -> ShelleyHash
forall a b. Coercible a b => a -> b
coerce HeaderHash (ShelleyBlock proto era)
ShelleyHash
hash)