{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Ouroboros.Consensus.Shelley.Ledger.SupportsProtocol () where
import qualified Cardano.Ledger.Dijkstra.Forecast as Dijkstra
import qualified Cardano.Ledger.Shelley.API as SL
import qualified Cardano.Protocol.TPraos.API as SL
import Control.Monad.Except (MonadError (throwError))
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.Protocol.Praos (Praos)
import qualified Ouroboros.Consensus.Protocol.Praos as Praos (PraosCrypto)
import qualified Ouroboros.Consensus.Protocol.Praos.Views as Praos
import Ouroboros.Consensus.Protocol.Praos2 (Praos2)
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
, SL.ShelleyEraForecast era
, SL.PraosCrypto crypto
) =>
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 =
Forecast Current era -> TPraosLedgerView
forall (t :: Timeline) era.
ShelleyEraForecast era =>
Forecast t era -> TPraosLedgerView
SL.forecastToTPraosLedgerView (Forecast Current era -> TPraosLedgerView)
-> (Ticked LedgerState (ShelleyBlock (TPraos crypto) era) mk
-> Forecast Current era)
-> Ticked LedgerState (ShelleyBlock (TPraos crypto) era) mk
-> TPraosLedgerView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> Forecast Current era
forall era.
EraForecast era =>
NewEpochState era -> Forecast Current era
SL.currentForecast (NewEpochState era -> Forecast Current era)
-> (Ticked LedgerState (ShelleyBlock (TPraos crypto) era) mk
-> NewEpochState era)
-> Ticked LedgerState (ShelleyBlock (TPraos crypto) era) mk
-> Forecast Current era
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
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 ->
TPraosLedgerView
-> ExceptT OutsideForecastRange Identity TPraosLedgerView
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (TPraosLedgerView
-> ExceptT OutsideForecastRange Identity TPraosLedgerView)
-> TPraosLedgerView
-> ExceptT OutsideForecastRange Identity TPraosLedgerView
forall a b. (a -> b) -> a -> b
$ Forecast Current era -> TPraosLedgerView
forall (t :: Timeline) era.
ShelleyEraForecast era =>
Forecast t era -> TPraosLedgerView
SL.forecastToTPraosLedgerView (NewEpochState era -> Forecast Current era
forall era.
EraForecast era =>
NewEpochState era -> Forecast Current era
SL.currentForecast NewEpochState era
shelleyLedgerState)
| SlotNo
for SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
maxFor ->
TPraosLedgerView
-> ExceptT OutsideForecastRange Identity TPraosLedgerView
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (TPraosLedgerView
-> ExceptT OutsideForecastRange Identity TPraosLedgerView)
-> TPraosLedgerView
-> ExceptT OutsideForecastRange Identity TPraosLedgerView
forall a b. (a -> b) -> a -> b
$ SlotNo -> TPraosLedgerView
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.TPraosLedgerView
futureLedgerView :: SlotNo -> TPraosLedgerView
futureLedgerView SlotNo
for =
Forecast Future era -> TPraosLedgerView
forall (t :: Timeline) era.
ShelleyEraForecast era =>
Forecast t era -> TPraosLedgerView
SL.forecastToTPraosLedgerView (Forecast Future era -> TPraosLedgerView)
-> Forecast Future era -> TPraosLedgerView
forall a b. (a -> b) -> a -> b
$
Globals -> SlotNo -> NewEpochState era -> Forecast Future era
forall era.
EraForecast era =>
Globals -> SlotNo -> NewEpochState era -> Forecast Future era
SL.futureForecast Globals
globals SlotNo
for NewEpochState era
shelleyLedgerState
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
, SL.EraForecast era
, Praos.PraosCrypto crypto
) =>
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)
-> Ticked LedgerState (ShelleyBlock (Praos crypto) era) mk
-> LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era))
LedgerConfig (ShelleyBlock (Praos crypto) era)
-> Ticked LedgerState (ShelleyBlock (Praos crypto) era) mk
-> PolyPraosLedgerView (Praos crypto)
forall proto era (mk :: MapKind).
(ForecastToPolyPraosLedgerView proto era, EraForecast era) =>
LedgerConfig (ShelleyBlock proto era)
-> Ticked LedgerState (ShelleyBlock proto era) mk
-> PolyPraosLedgerView proto
protocolLedgerViewPolyPraos
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)
-> LedgerState (ShelleyBlock (Praos crypto) era) mk
-> Forecast
(LedgerView (BlockProtocol (ShelleyBlock (Praos crypto) era)))
LedgerConfig (ShelleyBlock (Praos crypto) era)
-> LedgerState (ShelleyBlock (Praos crypto) era) mk
-> Forecast (PolyPraosLedgerView (Praos crypto))
forall proto era (mk :: MapKind).
(ShelleyCompatible proto era,
ForecastToPolyPraosLedgerView proto era) =>
LedgerConfig (ShelleyBlock proto era)
-> LedgerState (ShelleyBlock proto era) mk
-> Forecast (PolyPraosLedgerView proto)
ledgerViewForecastAtPolyPraos
protocolLedgerViewPolyPraos ::
forall proto era mk.
( Praos.ForecastToPolyPraosLedgerView proto era
, SL.EraForecast era
) =>
LedgerConfig (ShelleyBlock proto era) ->
Ticked LedgerState (ShelleyBlock proto era) mk ->
Praos.PolyPraosLedgerView proto
protocolLedgerViewPolyPraos :: forall proto era (mk :: MapKind).
(ForecastToPolyPraosLedgerView proto era, EraForecast era) =>
LedgerConfig (ShelleyBlock proto era)
-> Ticked LedgerState (ShelleyBlock proto era) mk
-> PolyPraosLedgerView proto
protocolLedgerViewPolyPraos LedgerConfig (ShelleyBlock proto era)
_cfg =
Forecast Current era -> PolyPraosLedgerView proto
forall proto era (t :: Timeline).
(ForecastToPolyPraosLedgerView proto era, EraForecast era) =>
Forecast t era -> PolyPraosLedgerView proto
forall (t :: Timeline).
EraForecast era =>
Forecast t era -> PolyPraosLedgerView proto
Praos.forecastToPolyPraosLedgerView (Forecast Current era -> PolyPraosLedgerView proto)
-> (Ticked LedgerState (ShelleyBlock proto era) mk
-> Forecast Current era)
-> Ticked LedgerState (ShelleyBlock proto era) mk
-> PolyPraosLedgerView proto
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NewEpochState era -> Forecast Current era
forall era.
EraForecast era =>
NewEpochState era -> Forecast Current era
SL.currentForecast (NewEpochState era -> Forecast Current era)
-> (Ticked LedgerState (ShelleyBlock proto era) mk
-> NewEpochState era)
-> Ticked LedgerState (ShelleyBlock proto era) mk
-> Forecast Current era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ticked LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
forall proto era (mk :: MapKind).
Ticked LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
tickedShelleyLedgerState
ledgerViewForecastAtPolyPraos ::
forall proto era mk.
( ShelleyCompatible proto era
, Praos.ForecastToPolyPraosLedgerView proto era
) =>
LedgerConfig (ShelleyBlock proto era) ->
LedgerState (ShelleyBlock proto era) mk ->
Forecast (Praos.PolyPraosLedgerView proto)
ledgerViewForecastAtPolyPraos :: forall proto era (mk :: MapKind).
(ShelleyCompatible proto era,
ForecastToPolyPraosLedgerView proto era) =>
LedgerConfig (ShelleyBlock proto era)
-> LedgerState (ShelleyBlock proto era) mk
-> Forecast (PolyPraosLedgerView proto)
ledgerViewForecastAtPolyPraos LedgerConfig (ShelleyBlock proto era)
cfg LedgerState (ShelleyBlock proto era) mk
ledgerState = WithOrigin SlotNo
-> (SlotNo
-> Except OutsideForecastRange (PolyPraosLedgerView proto))
-> Forecast (PolyPraosLedgerView proto)
forall a.
WithOrigin SlotNo
-> (SlotNo -> Except OutsideForecastRange a) -> Forecast a
Forecast WithOrigin SlotNo
at ((SlotNo
-> Except OutsideForecastRange (PolyPraosLedgerView proto))
-> Forecast (PolyPraosLedgerView proto))
-> (SlotNo
-> Except OutsideForecastRange (PolyPraosLedgerView proto))
-> Forecast (PolyPraosLedgerView proto)
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 ->
PolyPraosLedgerView proto
-> Except OutsideForecastRange (PolyPraosLedgerView proto)
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (PolyPraosLedgerView proto
-> Except OutsideForecastRange (PolyPraosLedgerView proto))
-> PolyPraosLedgerView proto
-> Except OutsideForecastRange (PolyPraosLedgerView proto)
forall a b. (a -> b) -> a -> b
$
Forecast Current era -> PolyPraosLedgerView proto
forall proto era (t :: Timeline).
(ForecastToPolyPraosLedgerView proto era, EraForecast era) =>
Forecast t era -> PolyPraosLedgerView proto
forall (t :: Timeline).
EraForecast era =>
Forecast t era -> PolyPraosLedgerView proto
Praos.forecastToPolyPraosLedgerView (NewEpochState era -> Forecast Current era
forall era.
EraForecast era =>
NewEpochState era -> Forecast Current era
SL.currentForecast NewEpochState era
shelleyLedgerState)
| SlotNo
for SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
maxFor ->
PolyPraosLedgerView proto
-> Except OutsideForecastRange (PolyPraosLedgerView proto)
forall a. a -> ExceptT OutsideForecastRange Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (PolyPraosLedgerView proto
-> Except OutsideForecastRange (PolyPraosLedgerView proto))
-> PolyPraosLedgerView proto
-> Except OutsideForecastRange (PolyPraosLedgerView proto)
forall a b. (a -> b) -> a -> b
$ SlotNo -> PolyPraosLedgerView proto
futureLedgerView SlotNo
for
| Bool
otherwise ->
OutsideForecastRange
-> Except OutsideForecastRange (PolyPraosLedgerView proto)
forall a.
OutsideForecastRange -> ExceptT OutsideForecastRange Identity a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (OutsideForecastRange
-> Except OutsideForecastRange (PolyPraosLedgerView proto))
-> OutsideForecastRange
-> Except OutsideForecastRange (PolyPraosLedgerView proto)
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 :: forall proto era (mk :: MapKind).
LedgerState (ShelleyBlock proto era) mk -> NewEpochState era
shelleyLedgerState :: NewEpochState era
shelleyLedgerState} = LedgerState (ShelleyBlock proto era) mk
ledgerState
globals :: Globals
globals = ShelleyLedgerConfig era -> Globals
forall era. ShelleyLedgerConfig era -> Globals
shelleyLedgerGlobals LedgerConfig (ShelleyBlock proto era)
ShelleyLedgerConfig era
cfg
swindow :: Word64
swindow = Globals -> Word64
SL.stabilityWindow Globals
globals
at :: WithOrigin SlotNo
at = LedgerState (ShelleyBlock proto era) mk -> WithOrigin SlotNo
forall blk (mk :: MapKind).
UpdateLedger blk =>
LedgerState blk mk -> WithOrigin SlotNo
ledgerTipSlot LedgerState (ShelleyBlock proto era) mk
ledgerState
futureLedgerView :: SlotNo -> Praos.PolyPraosLedgerView proto
futureLedgerView :: SlotNo -> PolyPraosLedgerView proto
futureLedgerView SlotNo
for =
Forecast Future era -> PolyPraosLedgerView proto
forall proto era (t :: Timeline).
(ForecastToPolyPraosLedgerView proto era, EraForecast era) =>
Forecast t era -> PolyPraosLedgerView proto
forall (t :: Timeline).
EraForecast era =>
Forecast t era -> PolyPraosLedgerView proto
Praos.forecastToPolyPraosLedgerView (Forecast Future era -> PolyPraosLedgerView proto)
-> Forecast Future era -> PolyPraosLedgerView proto
forall a b. (a -> b) -> a -> b
$
Globals -> SlotNo -> NewEpochState era -> Forecast Future era
forall era.
EraForecast era =>
Globals -> SlotNo -> NewEpochState era -> Forecast Future era
SL.futureForecast Globals
globals SlotNo
for NewEpochState era
shelleyLedgerState
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 (Praos2 c) era
, Dijkstra.DijkstraEraForecast era
, SL.EraForecast era
) =>
LedgerSupportsProtocol (ShelleyBlock (Praos2 c) era)
where
protocolLedgerView :: forall (mk :: MapKind).
LedgerConfig (ShelleyBlock (Praos2 c) era)
-> Ticked LedgerState (ShelleyBlock (Praos2 c) era) mk
-> LedgerView (BlockProtocol (ShelleyBlock (Praos2 c) era))
protocolLedgerView = LedgerConfig (ShelleyBlock (Praos2 c) era)
-> Ticked LedgerState (ShelleyBlock (Praos2 c) era) mk
-> LedgerView (BlockProtocol (ShelleyBlock (Praos2 c) era))
LedgerConfig (ShelleyBlock (Praos2 c) era)
-> Ticked LedgerState (ShelleyBlock (Praos2 c) era) mk
-> PolyPraosLedgerView (Praos2 c)
forall proto era (mk :: MapKind).
(ForecastToPolyPraosLedgerView proto era, EraForecast era) =>
LedgerConfig (ShelleyBlock proto era)
-> Ticked LedgerState (ShelleyBlock proto era) mk
-> PolyPraosLedgerView proto
protocolLedgerViewPolyPraos
ledgerViewForecastAt :: forall (mk :: MapKind).
HasCallStack =>
LedgerConfig (ShelleyBlock (Praos2 c) era)
-> LedgerState (ShelleyBlock (Praos2 c) era) mk
-> Forecast
(LedgerView (BlockProtocol (ShelleyBlock (Praos2 c) era)))
ledgerViewForecastAt = LedgerConfig (ShelleyBlock (Praos2 c) era)
-> LedgerState (ShelleyBlock (Praos2 c) era) mk
-> Forecast
(LedgerView (BlockProtocol (ShelleyBlock (Praos2 c) era)))
LedgerConfig (ShelleyBlock (Praos2 c) era)
-> LedgerState (ShelleyBlock (Praos2 c) era) mk
-> Forecast (PolyPraosLedgerView (Praos2 c))
forall proto era (mk :: MapKind).
(ShelleyCompatible proto era,
ForecastToPolyPraosLedgerView proto era) =>
LedgerConfig (ShelleyBlock proto era)
-> LedgerState (ShelleyBlock proto era) mk
-> Forecast (PolyPraosLedgerView proto)
ledgerViewForecastAtPolyPraos