{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Ouroboros.Consensus.HardFork.Combinator.State.Types (
Current (..)
, HardForkState (..)
, Past (..)
, sequenceHardForkState
, CrossEraForecaster (..)
, TransitionInfo (..)
, Translate (..)
, TranslateLedgerState (..)
, TranslateLedgerTables (..)
, TranslateTxOut (..)
, translateLedgerTablesWith
) where
import Control.Monad.Except
import qualified Data.Map.Strict as Map
import Data.SOP.BasicFunctors
import Data.SOP.Constraint
import Data.SOP.Strict
import Data.SOP.Telescope (Telescope)
import qualified Data.SOP.Telescope as Telescope
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.Ledger.Basics
import qualified Ouroboros.Consensus.Ledger.Tables.Diff as Diff
newtype HardForkState f xs = HardForkState {
forall (f :: * -> *) (xs :: [*]).
HardForkState f xs -> Telescope (K Past) (Current f) xs
getHardForkState :: Telescope (K Past) (Current f) xs
} deriving ((forall x. HardForkState f xs -> Rep (HardForkState f xs) x)
-> (forall x. Rep (HardForkState f xs) x -> HardForkState f xs)
-> Generic (HardForkState f xs)
forall x. Rep (HardForkState f xs) x -> HardForkState f xs
forall x. HardForkState f xs -> Rep (HardForkState f xs) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (f :: * -> *) (xs :: [*]) x.
Rep (HardForkState f xs) x -> HardForkState f xs
forall (f :: * -> *) (xs :: [*]) x.
HardForkState f xs -> Rep (HardForkState f xs) x
$cfrom :: forall (f :: * -> *) (xs :: [*]) x.
HardForkState f xs -> Rep (HardForkState f xs) x
from :: forall x. HardForkState f xs -> Rep (HardForkState f xs) x
$cto :: forall (f :: * -> *) (xs :: [*]) x.
Rep (HardForkState f xs) x -> HardForkState f xs
to :: forall x. Rep (HardForkState f xs) x -> HardForkState f xs
Generic)
data Current f blk = Current {
forall (f :: * -> *) blk. Current f blk -> Bound
currentStart :: !Bound
, forall (f :: * -> *) blk. 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
$cfrom :: forall (f :: * -> *) blk x. Current f blk -> Rep (Current f blk) x
from :: forall x. Current f blk -> Rep (Current f blk) x
$cto :: forall (f :: * -> *) blk x. Rep (Current f blk) x -> Current f blk
to :: forall x. Rep (Current f blk) x -> Current f blk
Generic)
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
$c== :: Past -> Past -> Bool
== :: Past -> Past -> Bool
$c/= :: Past -> Past -> Bool
/= :: 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
$cshowsPrec :: Int -> Past -> ShowS
showsPrec :: Int -> Past -> ShowS
$cshow :: Past -> String
show :: Past -> String
$cshowList :: [Past] -> ShowS
showList :: [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
$cfrom :: forall x. Past -> Rep Past x
from :: forall x. Past -> Rep Past x
$cto :: forall x. Rep Past x -> Past
to :: forall x. Rep Past x -> Past
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
$cnoThunks :: Context -> Past -> IO (Maybe ThunkInfo)
noThunks :: Context -> Past -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> Past -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> Past -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy Past -> String
showTypeOf :: Proxy Past -> String
NoThunks)
sequenceHardForkState :: forall m f xs. (All Top xs, Functor m)
=> HardForkState (m :.: f) xs -> m (HardForkState f xs)
sequenceHardForkState :: forall (m :: * -> *) (f :: * -> *) (xs :: [*]).
(All Top xs, Functor m) =>
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 a b. (a -> b) -> m a -> m b
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 Current (m :.: f) a -> (:.:) m (Current f) a
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 :: forall a. 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
newtype Translate f x y = Translate {
forall (f :: * -> *) x y. Translate f x y -> EpochNo -> f x -> f y
translateWith :: EpochNo -> f x -> f y
}
newtype CrossEraForecaster state view x y = CrossEraForecaster {
forall (state :: * -> (* -> * -> *) -> *) (view :: * -> *) x y.
CrossEraForecaster state view x y
-> Bound
-> SlotNo
-> state x EmptyMK
-> Except OutsideForecastRange (view y)
crossEraForecastWith ::
Bound
-> SlotNo
-> state x EmptyMK
-> Except OutsideForecastRange (view y)
}
newtype TranslateLedgerState x y = TranslateLedgerState {
forall x y.
TranslateLedgerState x y
-> EpochNo -> LedgerState x EmptyMK -> LedgerState y DiffMK
translateLedgerStateWith ::
EpochNo
-> LedgerState x EmptyMK
-> LedgerState y DiffMK
}
data TranslateLedgerTables x y = TranslateLedgerTables {
forall x y.
TranslateLedgerTables x y
-> TxIn (LedgerState x) -> TxIn (LedgerState y)
translateTxInWith :: !(TxIn (LedgerState x) -> TxIn (LedgerState y))
, forall x y.
TranslateLedgerTables x y
-> TxOut (LedgerState x) -> TxOut (LedgerState y)
translateTxOutWith :: !(TxOut (LedgerState x) -> TxOut (LedgerState y))
}
newtype TranslateTxOut x y = TranslateTxOut (TxOut (LedgerState x) -> TxOut (LedgerState y))
translateLedgerTablesWith ::
Ord (TxIn (LedgerState y))
=> TranslateLedgerTables x y
-> LedgerTables (LedgerState x) DiffMK
-> LedgerTables (LedgerState y) DiffMK
translateLedgerTablesWith :: forall y x.
Ord (TxIn (LedgerState y)) =>
TranslateLedgerTables x y
-> LedgerTables (LedgerState x) DiffMK
-> LedgerTables (LedgerState y) DiffMK
translateLedgerTablesWith TranslateLedgerTables x y
f =
DiffMK (TxIn (LedgerState y)) (TxOut (LedgerState y))
-> LedgerTables (LedgerState y) DiffMK
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
mk (TxIn l) (TxOut l) -> LedgerTables l mk
LedgerTables
(DiffMK (TxIn (LedgerState y)) (TxOut (LedgerState y))
-> LedgerTables (LedgerState y) DiffMK)
-> (LedgerTables (LedgerState x) DiffMK
-> DiffMK (TxIn (LedgerState y)) (TxOut (LedgerState y)))
-> LedgerTables (LedgerState x) DiffMK
-> LedgerTables (LedgerState y) DiffMK
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Diff (TxIn (LedgerState y)) (TxOut (LedgerState y))
-> DiffMK (TxIn (LedgerState y)) (TxOut (LedgerState y))
forall k v. Diff k v -> DiffMK k v
DiffMK
(Diff (TxIn (LedgerState y)) (TxOut (LedgerState y))
-> DiffMK (TxIn (LedgerState y)) (TxOut (LedgerState y)))
-> (LedgerTables (LedgerState x) DiffMK
-> Diff (TxIn (LedgerState y)) (TxOut (LedgerState y)))
-> LedgerTables (LedgerState x) DiffMK
-> DiffMK (TxIn (LedgerState y)) (TxOut (LedgerState y))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map (TxIn (LedgerState y)) (Delta (TxOut (LedgerState y)))
-> Diff (TxIn (LedgerState y)) (TxOut (LedgerState y))
forall k v. Map k (Delta v) -> Diff k v
Diff.Diff
(Map (TxIn (LedgerState y)) (Delta (TxOut (LedgerState y)))
-> Diff (TxIn (LedgerState y)) (TxOut (LedgerState y)))
-> (LedgerTables (LedgerState x) DiffMK
-> Map (TxIn (LedgerState y)) (Delta (TxOut (LedgerState y))))
-> LedgerTables (LedgerState x) DiffMK
-> Diff (TxIn (LedgerState y)) (TxOut (LedgerState y))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxIn (LedgerState x) -> TxIn (LedgerState y))
-> Map (TxIn (LedgerState x)) (Delta (TxOut (LedgerState y)))
-> Map (TxIn (LedgerState y)) (Delta (TxOut (LedgerState y)))
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeys (TranslateLedgerTables x y
-> TxIn (LedgerState x) -> TxIn (LedgerState y)
forall x y.
TranslateLedgerTables x y
-> TxIn (LedgerState x) -> TxIn (LedgerState y)
translateTxInWith TranslateLedgerTables x y
f)
(Map (TxIn (LedgerState x)) (Delta (TxOut (LedgerState y)))
-> Map (TxIn (LedgerState y)) (Delta (TxOut (LedgerState y))))
-> (LedgerTables (LedgerState x) DiffMK
-> Map (TxIn (LedgerState x)) (Delta (TxOut (LedgerState y))))
-> LedgerTables (LedgerState x) DiffMK
-> Map (TxIn (LedgerState y)) (Delta (TxOut (LedgerState y)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Diff (TxIn (LedgerState x)) (TxOut (LedgerState y))
-> Map (TxIn (LedgerState x)) (Delta (TxOut (LedgerState y)))
forall {k} {v}. Diff k v -> Map k (Delta v)
getDiff
(Diff (TxIn (LedgerState x)) (TxOut (LedgerState y))
-> Map (TxIn (LedgerState x)) (Delta (TxOut (LedgerState y))))
-> (LedgerTables (LedgerState x) DiffMK
-> Diff (TxIn (LedgerState x)) (TxOut (LedgerState y)))
-> LedgerTables (LedgerState x) DiffMK
-> Map (TxIn (LedgerState x)) (Delta (TxOut (LedgerState y)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DiffMK (TxIn (LedgerState x)) (TxOut (LedgerState y))
-> Diff (TxIn (LedgerState x)) (TxOut (LedgerState y))
forall k v. DiffMK k v -> Diff k v
getDiffMK
(DiffMK (TxIn (LedgerState x)) (TxOut (LedgerState y))
-> Diff (TxIn (LedgerState x)) (TxOut (LedgerState y)))
-> (LedgerTables (LedgerState x) DiffMK
-> DiffMK (TxIn (LedgerState x)) (TxOut (LedgerState y)))
-> LedgerTables (LedgerState x) DiffMK
-> Diff (TxIn (LedgerState x)) (TxOut (LedgerState y))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TxOut (LedgerState x) -> TxOut (LedgerState y))
-> DiffMK (TxIn (LedgerState x)) (TxOut (LedgerState x))
-> DiffMK (TxIn (LedgerState x)) (TxOut (LedgerState y))
forall v v' k. (v -> v') -> DiffMK k v -> DiffMK k v'
forall (mk :: * -> * -> *) v v' k.
CanMapMK mk =>
(v -> v') -> mk k v -> mk k v'
mapMK (TranslateLedgerTables x y
-> TxOut (LedgerState x) -> TxOut (LedgerState y)
forall x y.
TranslateLedgerTables x y
-> TxOut (LedgerState x) -> TxOut (LedgerState y)
translateTxOutWith TranslateLedgerTables x y
f)
(DiffMK (TxIn (LedgerState x)) (TxOut (LedgerState x))
-> DiffMK (TxIn (LedgerState x)) (TxOut (LedgerState y)))
-> (LedgerTables (LedgerState x) DiffMK
-> DiffMK (TxIn (LedgerState x)) (TxOut (LedgerState x)))
-> LedgerTables (LedgerState x) DiffMK
-> DiffMK (TxIn (LedgerState x)) (TxOut (LedgerState y))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerTables (LedgerState x) DiffMK
-> DiffMK (TxIn (LedgerState x)) (TxOut (LedgerState x))
forall (l :: (* -> * -> *) -> *) (mk :: * -> * -> *).
LedgerTables l mk -> mk (TxIn l) (TxOut l)
getLedgerTables
where
getDiff :: Diff k v -> Map k (Delta v)
getDiff (Diff.Diff Map k (Delta v)
m) = Map k (Delta v)
m
data TransitionInfo =
TransitionUnknown !(WithOrigin SlotNo)
| TransitionKnown !EpochNo
| 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
$cshowsPrec :: Int -> TransitionInfo -> ShowS
showsPrec :: Int -> TransitionInfo -> ShowS
$cshow :: TransitionInfo -> String
show :: TransitionInfo -> String
$cshowList :: [TransitionInfo] -> ShowS
showList :: [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
$cfrom :: forall x. TransitionInfo -> Rep TransitionInfo x
from :: forall x. TransitionInfo -> Rep TransitionInfo x
$cto :: forall x. Rep TransitionInfo x -> TransitionInfo
to :: forall x. Rep TransitionInfo x -> TransitionInfo
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
$cnoThunks :: Context -> TransitionInfo -> IO (Maybe ThunkInfo)
noThunks :: Context -> TransitionInfo -> IO (Maybe ThunkInfo)
$cwNoThunks :: Context -> TransitionInfo -> IO (Maybe ThunkInfo)
wNoThunks :: Context -> TransitionInfo -> IO (Maybe ThunkInfo)
$cshowTypeOf :: Proxy TransitionInfo -> String
showTypeOf :: Proxy TransitionInfo -> String
NoThunks)