{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}

module Ouroboros.Consensus.Forecast
  ( Forecast (..)
  , OutsideForecastRange (..)
  , constantForecastInRange
  , constantForecastOf
  , mapForecast
  , trivialForecast

    -- * Utilities for constructing forecasts
  , crossEraForecastBound
  ) where

import Control.Exception (Exception)
import Control.Monad (guard)
import Control.Monad.Except (Except, throwError)
import Data.Word (Word64)
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.HardFork.History.Util (addSlots)
import Ouroboros.Consensus.Ledger.Basics (GetTip, getTipSlot)

data Forecast a = Forecast
  { forall a. Forecast a -> WithOrigin SlotNo
forecastAt :: WithOrigin SlotNo
  , -- Precondition: @At s >= forecastAt@
    forall a. Forecast a -> SlotNo -> Except OutsideForecastRange a
forecastFor :: SlotNo -> Except OutsideForecastRange a
  }

mapForecast :: (a -> b) -> Forecast a -> Forecast b
mapForecast :: forall a b. (a -> b) -> Forecast a -> Forecast b
mapForecast a -> b
f (Forecast WithOrigin SlotNo
at SlotNo -> Except OutsideForecastRange a
for) =
  Forecast
    { forecastAt :: WithOrigin SlotNo
forecastAt = WithOrigin SlotNo
at
    , forecastFor :: SlotNo -> Except OutsideForecastRange b
forecastFor = (a -> b)
-> Except OutsideForecastRange a -> Except OutsideForecastRange b
forall a b.
(a -> b)
-> ExceptT OutsideForecastRange Identity a
-> ExceptT OutsideForecastRange Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (Except OutsideForecastRange a -> Except OutsideForecastRange b)
-> (SlotNo -> Except OutsideForecastRange a)
-> SlotNo
-> Except OutsideForecastRange b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SlotNo -> Except OutsideForecastRange a
for
    }

-- | Trivial forecast of values of type @()@ performed by an instance of
-- 'GetTip'.
--
-- Specialization of 'constantForecast'.
trivialForecast :: GetTip b => b mk -> Forecast ()
trivialForecast :: forall (b :: LedgerStateKind) (mk :: MapKind).
GetTip b =>
b mk -> Forecast ()
trivialForecast b mk
x = () -> WithOrigin SlotNo -> Forecast ()
forall a. a -> WithOrigin SlotNo -> Forecast a
constantForecastOf () (b mk -> WithOrigin SlotNo
forall (l :: LedgerStateKind) (mk :: MapKind).
GetTip l =>
l mk -> WithOrigin SlotNo
getTipSlot b mk
x)

-- | Forecast where the values are never changing
--
-- This is primarily useful for tests; the forecast range is infinite, but we
-- do still check the precondition, to catch any bugs.
constantForecastOf :: a -> WithOrigin SlotNo -> Forecast a
constantForecastOf :: forall a. a -> WithOrigin SlotNo -> Forecast a
constantForecastOf = Maybe SlotNo -> a -> WithOrigin SlotNo -> Forecast a
forall a. Maybe SlotNo -> a -> WithOrigin SlotNo -> Forecast a
constantForecastInRange Maybe SlotNo
forall a. Maybe a
Nothing

-- | Forecast where the values are never changing, in a certain window.
--
-- This is primarily useful for tests; the forecast range is finite, and we
-- do still check the precondition, to catch any bugs.
constantForecastInRange :: Maybe SlotNo -> a -> WithOrigin SlotNo -> Forecast a
constantForecastInRange :: forall a. Maybe SlotNo -> a -> WithOrigin SlotNo -> Forecast a
constantForecastInRange Maybe SlotNo
range' a
a WithOrigin SlotNo
at =
  Forecast
    { forecastAt :: WithOrigin SlotNo
forecastAt = WithOrigin SlotNo
at
    , forecastFor :: SlotNo -> Except OutsideForecastRange a
forecastFor = Maybe SlotNo -> SlotNo -> Except OutsideForecastRange a
forall {m :: * -> *}.
MonadError OutsideForecastRange m =>
Maybe SlotNo -> SlotNo -> m a
forecastForWithRange Maybe SlotNo
range'
    }
 where
  forecastForWithRange :: Maybe SlotNo -> SlotNo -> m a
forecastForWithRange Maybe SlotNo
Nothing = \SlotNo
for ->
    if SlotNo -> WithOrigin SlotNo
forall t. t -> WithOrigin t
NotOrigin SlotNo
for WithOrigin SlotNo -> WithOrigin SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= WithOrigin SlotNo
at
      then a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a
      else [Char] -> m a
forall a. HasCallStack => [Char] -> a
error [Char]
"constantForecastOf: precondition violated"
  forecastForWithRange (Just SlotNo
range) = \SlotNo
for ->
    let outsideForecastMaxFor :: SlotNo
outsideForecastMaxFor = WithOrigin SlotNo -> SlotNo
forall t. (Bounded t, Enum t) => WithOrigin t -> t
succWithOrigin WithOrigin SlotNo
at SlotNo -> SlotNo -> SlotNo
forall a. Num a => a -> a -> a
+ SlotNo
range
     in if SlotNo
for SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
>= SlotNo
outsideForecastMaxFor
          then
            OutsideForecastRange -> m a
forall a. OutsideForecastRange -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (OutsideForecastRange -> m a) -> OutsideForecastRange -> m a
forall a b. (a -> b) -> a -> b
$
              OutsideForecastRange
                { outsideForecastAt :: WithOrigin SlotNo
outsideForecastAt = WithOrigin SlotNo
at
                , SlotNo
outsideForecastMaxFor :: SlotNo
outsideForecastMaxFor :: SlotNo
outsideForecastMaxFor
                , outsideForecastFor :: SlotNo
outsideForecastFor = SlotNo
for
                }
          else Maybe SlotNo -> SlotNo -> m a
forecastForWithRange Maybe SlotNo
forall a. Maybe a
Nothing SlotNo
for

data OutsideForecastRange
  = OutsideForecastRange
  { OutsideForecastRange -> WithOrigin SlotNo
outsideForecastAt :: !(WithOrigin SlotNo)
  -- ^ The slot for which the forecast was obtained
  , OutsideForecastRange -> SlotNo
outsideForecastMaxFor :: !SlotNo
  -- ^ Exclusive upper bound on the range of the forecast
  , OutsideForecastRange -> SlotNo
outsideForecastFor :: !SlotNo
  -- ^ The slot for which we requested a value
  }
  deriving (Int -> OutsideForecastRange -> ShowS
[OutsideForecastRange] -> ShowS
OutsideForecastRange -> [Char]
(Int -> OutsideForecastRange -> ShowS)
-> (OutsideForecastRange -> [Char])
-> ([OutsideForecastRange] -> ShowS)
-> Show OutsideForecastRange
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OutsideForecastRange -> ShowS
showsPrec :: Int -> OutsideForecastRange -> ShowS
$cshow :: OutsideForecastRange -> [Char]
show :: OutsideForecastRange -> [Char]
$cshowList :: [OutsideForecastRange] -> ShowS
showList :: [OutsideForecastRange] -> ShowS
Show, OutsideForecastRange -> OutsideForecastRange -> Bool
(OutsideForecastRange -> OutsideForecastRange -> Bool)
-> (OutsideForecastRange -> OutsideForecastRange -> Bool)
-> Eq OutsideForecastRange
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OutsideForecastRange -> OutsideForecastRange -> Bool
== :: OutsideForecastRange -> OutsideForecastRange -> Bool
$c/= :: OutsideForecastRange -> OutsideForecastRange -> Bool
/= :: OutsideForecastRange -> OutsideForecastRange -> Bool
Eq)

instance Exception OutsideForecastRange

{-------------------------------------------------------------------------------
  Utilities for constructing forecasts
-------------------------------------------------------------------------------}

-- | Compute the upper bound for a range for a forecast across eras.
--
-- We have to be very careful here in how we compute the maximum lookahead.
-- As long as we are in a single era, things look like this:
--
-- >                                          /-------------------\
-- >                                          |                   |
-- > chain     ... - block - block - block [block]                |
-- >                                   |                          v
-- > ledger                           TIP                  VIEW
--
-- where @TIP@ is the current ledger tip and @VIEW@ is the last ledger view we
-- can forecast, because the next block @[block]@ to arrive will take effect in
-- the next leger state after @VIEW@. Note that if the maximum lookahead is
-- zero, this looks like
--
-- > chain     ... - block - block - block [block]
-- >                                   |      |
-- > ledger                           TIP
--
-- where @[block]@ can have immediate changes on the ledger, and so we can't
-- look ahead at all (of course, we always know the /current/ @TIP@).
--
-- Note that blocks arriving /after/ @[block]@ can only take effect /later/ than
-- @[block]@, and so they are not relevant for computing the maximum slot number
-- we can compute a ledger view for.
--
-- Now, if we are near an era transition, this picture gets a bit more
-- complicated. /If/ the next block is still in this era (that is, unless we are
-- /right/ at the edge), then that imposes /one/ constraint, as before. However,
-- the first block in the /next/ era imposes an /additional/ constraint:
--
-- >                      ~
-- >                      ~    /------------------\
-- >                      ~    |                  |
-- >          /---------- ~ ---|----------\       |
-- >          |           ~    |          |       |
-- > block [block]        ~ [block']      |       |
-- >   |                  ~               v       v
-- >  TIP                 ~         VIEW
-- >                      ~
--
-- There are no restrictions on the relative values of these two maximum
-- lookahead values. This means that it's quite possible for the next era to
-- have a /smaller/ lookahead (to re-iterate, since that era has not yet begun,
-- the first block in that era is at the transition, and so the maximum
-- lookahead applies from the transition point):
--
-- >                      ~
-- >                      ~    /----------\
-- >                      ~    |          |
-- >          /---------- ~ ---|----------|-------\
-- >          |           ~    |          |       |
-- > block [block]        ~ [block']      |       |
-- >   |                  ~               v       v
-- >  TIP                 ~         VIEW
-- >                      ~
--
-- Indeed, if the next era has zero lookahead, when the first block of the next
-- era comes it, it can make changes immediately, and so we can't even know what
-- the view at the transition point is.
--
-- Note that if there can be no more blocks in this era, the maximum lookahead
-- of the current era is irrelevant:
--
-- >       ~
-- >       ~    /----------\
-- >       ~    |          |
-- >       ~    |          |
-- >       ~    |          |
-- > block ~ [block']      |
-- >   |   ~               v
-- >  TIP  ~         VIEW
-- >       ~
--
-- We can therefore compute the earliest 'SlotNo' the next block in this era
-- (if any) can make changes to the ledger state, as well as the earliest
-- 'SlotNo' the first block in the next era can; their @minimum@ will serve as
-- an exclusive upper bound for the forecast range.
crossEraForecastBound ::
  -- | Current tip (the slot the forecast is at)
  WithOrigin SlotNo ->
  -- | Slot at which the transition to the next era happens
  SlotNo ->
  -- | Max lookeahead in the current era
  Word64 ->
  -- | Max lookeahead in the next era
  Word64 ->
  SlotNo
crossEraForecastBound :: WithOrigin SlotNo -> SlotNo -> Word64 -> Word64 -> SlotNo
crossEraForecastBound WithOrigin SlotNo
currentTip SlotNo
transitionSlot Word64
currentLookahead Word64
nextLookahead =
  SlotNo -> (SlotNo -> SlotNo) -> Maybe SlotNo -> SlotNo
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SlotNo
boundFromNextEra (SlotNo -> SlotNo -> SlotNo
forall a. Ord a => a -> a -> a
min SlotNo
boundFromNextEra) Maybe SlotNo
boundFromCurrentEra
 where
  tipSucc :: SlotNo
  tipSucc :: SlotNo
tipSucc = WithOrigin SlotNo -> SlotNo
forall t. (Bounded t, Enum t) => WithOrigin t -> t
succWithOrigin WithOrigin SlotNo
currentTip

  -- Upper bound arising from blocks in the current era
  --
  -- 'Nothing' if there are no more blocks in this era
  boundFromCurrentEra :: Maybe SlotNo
  boundFromCurrentEra :: Maybe SlotNo
boundFromCurrentEra = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (SlotNo
tipSucc SlotNo -> SlotNo -> Bool
forall a. Ord a => a -> a -> Bool
< SlotNo
transitionSlot)
    SlotNo -> Maybe SlotNo
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (SlotNo -> Maybe SlotNo) -> SlotNo -> Maybe SlotNo
forall a b. (a -> b) -> a -> b
$ Word64 -> SlotNo -> SlotNo
addSlots Word64
currentLookahead SlotNo
tipSucc

  -- Upper bound arising from blocks in the next era
  boundFromNextEra :: SlotNo
  boundFromNextEra :: SlotNo
boundFromNextEra = Word64 -> SlotNo -> SlotNo
addSlots Word64
nextLookahead SlotNo
transitionSlot