{-# 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 -> Forecast ()
trivialForecast :: forall b. GetTip b => b -> Forecast ()
trivialForecast b
x = () -> WithOrigin SlotNo -> Forecast ()
forall a. a -> WithOrigin SlotNo -> Forecast a
constantForecastOf () (b -> WithOrigin SlotNo
forall l. GetTip l => l -> WithOrigin SlotNo
getTipSlot b
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 {
        -- | The slot for which the forecast was obtained
        OutsideForecastRange -> WithOrigin SlotNo
outsideForecastAt     :: !(WithOrigin SlotNo)

        -- | Exclusive upper bound on the range of the forecast
      , OutsideForecastRange -> SlotNo
outsideForecastMaxFor :: !SlotNo

        -- | The slot for which we requested a value
      , OutsideForecastRange -> SlotNo
outsideForecastFor    :: !SlotNo
      }
  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 ::
     WithOrigin SlotNo  -- ^ Current tip (the slot the forecast is at)
  -> SlotNo             -- ^ Slot at which the transition to the next era happens
  -> Word64             -- ^ Max lookeahead in the current era
  -> Word64             -- ^ Max lookeahead in the next era
  -> 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