{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeData #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableSuperClasses #-}

-- | Forecast API for the consensus layer.
--
-- This module provides a type-safe interface for extracting protocol-relevant
-- data from the ledger state, both for the current slot and for future slots
-- within the stability window.
module Cardano.Ledger.Shelley.API.Forecast (
  -- * Core forecast class
  EraForecast (..),
  Timeline (..),

  -- * TPraos-era extension (Shelley through Alonzo)
  ShelleyEraForecast (..),

  -- * Main functions
  currentForecast,
  futureForecast,

  -- * Conversion helpers
  forecastChainChecks,
) where

import Cardano.Ledger.BaseTypes (
  Globals,
  Nonce,
  ProtVer,
  ShelleyBase,
  SlotNo,
  UnitInterval,
 )
import Cardano.Ledger.Chain (ChainChecksPParams (..))
import Cardano.Ledger.Core
import Cardano.Ledger.Keys (GenDelegs)
import Cardano.Ledger.Shelley.LedgerState (NewEpochState)
import Cardano.Ledger.State (EraCertState, EraGov, PoolDistr)
import Control.Monad.Trans.Reader (runReader)
import Control.State.Transition.Extended
import qualified Data.List.NonEmpty as NE (head)
import Data.Void (Void, absurd)
import Data.Word (Word16, Word32)
import Lens.Micro (Lens', (^.))

-- | Type-level tag distinguishing current from future forecasts.
type data Timeline = Current | Future

-- | Core class for extracting forecast data from the ledger state.
class
  ( STS (EraRule "TICKF" era)
  , BaseM (EraRule "TICKF" era) ~ ShelleyBase
  , Environment (EraRule "TICKF" era) ~ ()
  , State (EraRule "TICKF" era) ~ NewEpochState era
  , Signal (EraRule "TICKF" era) ~ SlotNo
  , PredicateFailure (EraRule "TICKF" era) ~ Void
  , EraGov era
  , EraCertState era
  ) =>
  EraForecast era
  where
  -- | Per-era forecast type.
  type Forecast (t :: Timeline) era = r | r -> t era

  -- | Extract a forecast from a `NewEpochState`
  mkForecast :: NewEpochState era -> Forecast t era

  poolDistrForecastL :: Lens' (Forecast t era) PoolDistr
  maxBlockHeaderSizeForecastL :: Lens' (Forecast t era) Word16
  maxBlockBodySizeForecastL :: Lens' (Forecast t era) Word32
  protocolVersionForecastL :: Lens' (Forecast t era) ProtVer

-- | Extract the forecast for the current slot.
currentForecast :: forall era. EraForecast era => NewEpochState era -> Forecast Current era
currentForecast :: forall era.
EraForecast era =>
NewEpochState era -> Forecast Current era
currentForecast = forall era (t :: Timeline).
EraForecast era =>
NewEpochState era -> Forecast t era
mkForecast @era @Current

-- | `TICKF` a `NewEpochState` and then extract the forecast from it.
futureForecast ::
  forall era.
  EraForecast era =>
  Globals ->
  SlotNo ->
  NewEpochState era ->
  Forecast Future era
futureForecast :: forall era.
EraForecast era =>
Globals -> SlotNo -> NewEpochState era -> Forecast Future era
futureForecast Globals
globals SlotNo
slot NewEpochState era
nes =
  (NonEmpty Void -> Forecast Future era)
-> (NewEpochState era -> Forecast Future era)
-> Either (NonEmpty Void) (NewEpochState era)
-> Forecast Future era
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Void -> Forecast Future era
forall a. Void -> a
absurd (Void -> Forecast Future era)
-> (NonEmpty Void -> Void) -> NonEmpty Void -> Forecast Future era
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Void -> Void
forall a. NonEmpty a -> a
NE.head) (forall era (t :: Timeline).
EraForecast era =>
NewEpochState era -> Forecast t era
mkForecast @era @Future) (Either (NonEmpty Void) (NewEpochState era) -> Forecast Future era)
-> Either (NonEmpty Void) (NewEpochState era)
-> Forecast Future era
forall a b. (a -> b) -> a -> b
$
    (Reader Globals (Either (NonEmpty Void) (NewEpochState era))
 -> Globals -> Either (NonEmpty Void) (NewEpochState era))
-> Globals
-> Reader Globals (Either (NonEmpty Void) (NewEpochState era))
-> Either (NonEmpty Void) (NewEpochState era)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader Globals (Either (NonEmpty Void) (NewEpochState era))
-> Globals -> Either (NonEmpty Void) (NewEpochState era)
forall r a. Reader r a -> r -> a
runReader Globals
globals (Reader Globals (Either (NonEmpty Void) (NewEpochState era))
 -> Either (NonEmpty Void) (NewEpochState era))
-> Reader Globals (Either (NonEmpty Void) (NewEpochState era))
-> Either (NonEmpty Void) (NewEpochState era)
forall a b. (a -> b) -> a -> b
$
      forall s (m :: * -> *) (rtype :: RuleType).
(STS s, RuleTypeRep rtype, m ~ BaseM s) =>
RuleContext rtype s
-> m (Either (NonEmpty (PredicateFailure s)) (State s))
applySTS @(EraRule "TICKF" era) ((Environment (EraRule "TICKF" era), State (EraRule "TICKF" era),
 Signal (EraRule "TICKF" era))
-> TRC (EraRule "TICKF" era)
forall sts. (Environment sts, State sts, Signal sts) -> TRC sts
TRC ((), State (EraRule "TICKF" era)
NewEpochState era
nes, SlotNo
Signal (EraRule "TICKF" era)
slot))

-- | Additional forecast fields available only in TPraos eras.
class (EraForecast era, AtMostEra "Alonzo" era) => ShelleyEraForecast era where
  genDelegsForecastL :: Lens' (Forecast t era) GenDelegs
  decentralizationForecastL :: Lens' (Forecast t era) UnitInterval
  extraEntropyForecastL :: Lens' (Forecast t era) Nonce

-- | Construct 'ChainChecksPParams' from any forecast.
forecastChainChecks :: forall t era. EraForecast era => Forecast t era -> ChainChecksPParams
forecastChainChecks :: forall (t :: Timeline) era.
EraForecast era =>
Forecast t era -> ChainChecksPParams
forecastChainChecks Forecast t era
f =
  ChainChecksPParams
    { ccMaxBHSize :: Word16
ccMaxBHSize = Forecast t era
f Forecast t era -> Getting Word16 (Forecast t era) Word16 -> Word16
forall s a. s -> Getting a s a -> a
^. forall era (t :: Timeline).
EraForecast era =>
Lens' (Forecast t era) Word16
maxBlockHeaderSizeForecastL @era @t
    , ccMaxBBSize :: Word32
ccMaxBBSize = Forecast t era
f Forecast t era -> Getting Word32 (Forecast t era) Word32 -> Word32
forall s a. s -> Getting a s a -> a
^. forall era (t :: Timeline).
EraForecast era =>
Lens' (Forecast t era) Word32
maxBlockBodySizeForecastL @era @t
    , ccProtocolVersion :: ProtVer
ccProtocolVersion = Forecast t era
f Forecast t era
-> Getting ProtVer (Forecast t era) ProtVer -> ProtVer
forall s a. s -> Getting a s a -> a
^. forall era (t :: Timeline).
EraForecast era =>
Lens' (Forecast t era) ProtVer
protocolVersionForecastL @era @t
    }