{-# 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)