{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators       #-}

module Ouroboros.Consensus.HardFork.Combinator.State.Types (
    -- * Main types
    Current (..)
  , HardForkState (..)
  , Past (..)
  , sequenceHardForkState
    -- * Supporting types
  , TransitionInfo (..)
  , Translate (..)
  , TranslateForecast (..)
  ) where

import           Prelude

import           Control.Monad.Except
import           Data.SOP.Strict
import           GHC.Generics (Generic)
import           NoThunks.Class (NoThunks (..))

import           Ouroboros.Consensus.Block
import           Ouroboros.Consensus.Forecast
import           Ouroboros.Consensus.HardFork.History (Bound)
import           Ouroboros.Consensus.Ticked

import           Ouroboros.Consensus.HardFork.Combinator.Util.Telescope
                     (Telescope)
import qualified Ouroboros.Consensus.HardFork.Combinator.Util.Telescope as Telescope

{-------------------------------------------------------------------------------
  Types
-------------------------------------------------------------------------------}

-- | Generic hard fork state
--
-- This is used both for the consensus state and the ledger state.
newtype HardForkState f xs = HardForkState {
      HardForkState f xs -> Telescope (K Past) (Current f) xs
getHardForkState :: Telescope (K Past) (Current f) xs
    }

-- | Information about the current era
data Current f blk = Current {
      Current f blk -> Bound
currentStart :: !Bound
    , Current f blk -> f blk
currentState :: !(f blk)
    }
  deriving ((forall x. Current f blk -> Rep (Current f blk) x)
-> (forall x. Rep (Current f blk) x -> Current f blk)
-> Generic (Current f blk)
forall x. Rep (Current f blk) x -> Current f blk
forall x. Current f blk -> Rep (Current f blk) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) blk x. Rep (Current f blk) x -> Current f blk
forall (f :: * -> *) blk x. Current f blk -> Rep (Current f blk) x
$cto :: forall (f :: * -> *) blk x. Rep (Current f blk) x -> Current f blk
$cfrom :: forall (f :: * -> *) blk x. Current f blk -> Rep (Current f blk) x
Generic)

-- | Information about a past era
data Past = Past {
      Past -> Bound
pastStart :: !Bound
    , Past -> Bound
pastEnd   :: !Bound
    }
  deriving (Past -> Past -> Bool
(Past -> Past -> Bool) -> (Past -> Past -> Bool) -> Eq Past
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Past -> Past -> Bool
$c/= :: Past -> Past -> Bool
== :: Past -> Past -> Bool
$c== :: Past -> Past -> Bool
Eq, Int -> Past -> ShowS
[Past] -> ShowS
Past -> String
(Int -> Past -> ShowS)
-> (Past -> String) -> ([Past] -> ShowS) -> Show Past
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Past] -> ShowS
$cshowList :: [Past] -> ShowS
show :: Past -> String
$cshow :: Past -> String
showsPrec :: Int -> Past -> ShowS
$cshowsPrec :: Int -> Past -> ShowS
Show, (forall x. Past -> Rep Past x)
-> (forall x. Rep Past x -> Past) -> Generic Past
forall x. Rep Past x -> Past
forall x. Past -> Rep Past x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Past x -> Past
$cfrom :: forall x. Past -> Rep Past x
Generic, Context -> Past -> IO (Maybe ThunkInfo)
Proxy Past -> String
(Context -> Past -> IO (Maybe ThunkInfo))
-> (Context -> Past -> IO (Maybe ThunkInfo))
-> (Proxy Past -> String)
-> NoThunks Past
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy Past -> String
$cshowTypeOf :: Proxy Past -> String
wNoThunks :: Context -> Past -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Past -> IO (Maybe ThunkInfo)
noThunks :: Context -> Past -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> Past -> IO (Maybe ThunkInfo)
NoThunks)

-- | Thin wrapper around 'Telescope.sequence'
sequenceHardForkState :: forall m f xs. (All Top xs, Functor m)
                      => HardForkState (m :.: f) xs -> m (HardForkState f xs)
sequenceHardForkState :: HardForkState (m :.: f) xs -> m (HardForkState f xs)
sequenceHardForkState (HardForkState Telescope (K Past) (Current (m :.: f)) xs
tel) =
      (Telescope (K Past) (Current f) xs -> HardForkState f xs)
-> m (Telescope (K Past) (Current f) xs) -> m (HardForkState f xs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Telescope (K Past) (Current f) xs -> HardForkState f xs
forall (f :: * -> *) (xs :: [*]).
Telescope (K Past) (Current f) xs -> HardForkState f xs
HardForkState
    (m (Telescope (K Past) (Current f) xs) -> m (HardForkState f xs))
-> m (Telescope (K Past) (Current f) xs) -> m (HardForkState f xs)
forall a b. (a -> b) -> a -> b
$ Telescope (K Past) (m :.: Current f) xs
-> m (Telescope (K Past) (Current f) xs)
forall k (m :: * -> *) (g :: k -> *) (f :: k -> *) (xs :: [k]).
Functor m =>
Telescope g (m :.: f) xs -> m (Telescope g f xs)
Telescope.sequence
    (Telescope (K Past) (m :.: Current f) xs
 -> m (Telescope (K Past) (Current f) xs))
-> Telescope (K Past) (m :.: Current f) xs
-> m (Telescope (K Past) (Current f) xs)
forall a b. (a -> b) -> a -> b
$ (forall a. Current (m :.: f) a -> (:.:) m (Current f) a)
-> Telescope (K Past) (Current (m :.: f)) xs
-> Telescope (K Past) (m :.: Current f) xs
forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
       (f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap forall a. Current (m :.: f) a -> (:.:) m (Current f) a
sequenceCurrent Telescope (K Past) (Current (m :.: f)) xs
tel
  where
    sequenceCurrent :: Current (m :.: f) a -> (m :.: Current f) a
    sequenceCurrent :: Current (m :.: f) a -> (:.:) m (Current f) a
sequenceCurrent (Current Bound
start (:.:) m f a
state) =
      m (Current f a) -> (:.:) m (Current f) a
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp (m (Current f a) -> (:.:) m (Current f) a)
-> m (Current f a) -> (:.:) m (Current f) a
forall a b. (a -> b) -> a -> b
$ Bound -> f a -> Current f a
forall (f :: * -> *) blk. Bound -> f blk -> Current f blk
Current Bound
start (f a -> Current f a) -> m (f a) -> m (Current f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (:.:) m f a -> m (f a)
forall l k (f :: l -> *) (g :: k -> l) (p :: k).
(:.:) f g p -> f (g p)
unComp (:.:) m f a
state

{-------------------------------------------------------------------------------
  Supporting types
-------------------------------------------------------------------------------}

-- | Translate @f x@ to @f y@ across an era transition
--
-- Typically @f@ will be 'LedgerState' or 'WrapChainDepState'.
newtype Translate f x y = Translate {
      Translate f x y -> EpochNo -> f x -> f y
translateWith :: EpochNo -> f x -> f y
    }

-- | Translate (a forecast of) @f x@ to (a forecast of) @f y@
-- across an era transition.
--
-- Typically @f@ will be 'WrapLedgerView'.
--
-- In addition to the 'Bound' of the transition, this is also told the
-- 'SlotNo' we're constructing a forecast for. This enables the translation
-- function to take into account any scheduled changes that the final ledger
-- view in the preceding era might have.
newtype TranslateForecast f g x y = TranslateForecast {
      TranslateForecast f g x y
-> Bound
-> SlotNo
-> f x
-> Except OutsideForecastRange (Ticked (g y))
translateForecastWith ::
           Bound    -- 'Bound' of the transition (start of the new era)
        -> SlotNo   -- 'SlotNo' we're constructing a forecast for
        -> f x
        -> Except OutsideForecastRange (Ticked (g y))
    }

-- | Knowledge in a particular era of the transition to the next era
data TransitionInfo =
    -- | No transition is yet known for this era
    -- We instead record the ledger tip (which must be in /this/ era)
    --
    -- NOTE: If we are forecasting, this will be set to the slot number of the
    -- (past) ledger state in which the forecast was created. This means that
    -- when we construct an 'EpochInfo' using a 'HardForkLedgerView', the
    -- range of that 'EpochInfo' will extend a safe zone from that /past/
    -- ledger state.
    TransitionUnknown !(WithOrigin SlotNo)

    -- | Transition to the next era is known to happen at this 'EpochNo'
  | TransitionKnown !EpochNo

    -- | The transition is impossible
    --
    -- This can be due to one of two reasons:
    --
    -- * We are in the final era
    -- * This era has not actually begun yet (we are forecasting). In this case,
    --   we cannot look past the safe zone of this era and hence, by definition,
    --   the transition to the /next/ era cannot happen.
  | TransitionImpossible
  deriving (Int -> TransitionInfo -> ShowS
[TransitionInfo] -> ShowS
TransitionInfo -> String
(Int -> TransitionInfo -> ShowS)
-> (TransitionInfo -> String)
-> ([TransitionInfo] -> ShowS)
-> Show TransitionInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TransitionInfo] -> ShowS
$cshowList :: [TransitionInfo] -> ShowS
show :: TransitionInfo -> String
$cshow :: TransitionInfo -> String
showsPrec :: Int -> TransitionInfo -> ShowS
$cshowsPrec :: Int -> TransitionInfo -> ShowS
Show, (forall x. TransitionInfo -> Rep TransitionInfo x)
-> (forall x. Rep TransitionInfo x -> TransitionInfo)
-> Generic TransitionInfo
forall x. Rep TransitionInfo x -> TransitionInfo
forall x. TransitionInfo -> Rep TransitionInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TransitionInfo x -> TransitionInfo
$cfrom :: forall x. TransitionInfo -> Rep TransitionInfo x
Generic, Context -> TransitionInfo -> IO (Maybe ThunkInfo)
Proxy TransitionInfo -> String
(Context -> TransitionInfo -> IO (Maybe ThunkInfo))
-> (Context -> TransitionInfo -> IO (Maybe ThunkInfo))
-> (Proxy TransitionInfo -> String)
-> NoThunks TransitionInfo
forall a.
(Context -> a -> IO (Maybe ThunkInfo))
-> (Context -> a -> IO (Maybe ThunkInfo))
-> (Proxy a -> String)
-> NoThunks a
showTypeOf :: Proxy TransitionInfo -> String
$cshowTypeOf :: Proxy TransitionInfo -> String
wNoThunks :: Context -> TransitionInfo -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TransitionInfo -> IO (Maybe ThunkInfo)
noThunks :: Context -> TransitionInfo -> IO (Maybe ThunkInfo)
$cnoThunks :: Context -> TransitionInfo -> IO (Maybe ThunkInfo)
NoThunks)