{-# LANGUAGE DataKinds #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock ( -- * Single era block SingleEraBlock (..) , proxySingle , singleEraTransition' -- * Era index , EraIndex (..) , eraIndexEmpty , eraIndexFromIndex , eraIndexFromNS , eraIndexSucc , eraIndexToInt , eraIndexZero ) where import Codec.Serialise import Data.Either (isRight) import Data.Proxy import Data.SOP.Strict import qualified Data.Text as Text import Data.Void import Ouroboros.Consensus.Block import Ouroboros.Consensus.Config.SupportsNode import Ouroboros.Consensus.HardFork.History (Bound, EraParams) import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Ledger.CommonProtocolParams import Ouroboros.Consensus.Ledger.Inspect import Ouroboros.Consensus.Ledger.Query import Ouroboros.Consensus.Ledger.SupportsMempool import Ouroboros.Consensus.Ledger.SupportsPeerSelection import Ouroboros.Consensus.Ledger.SupportsProtocol import Ouroboros.Consensus.Node.InitStorage import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.SOP import Ouroboros.Consensus.HardFork.Combinator.Info import Ouroboros.Consensus.HardFork.Combinator.PartialConfig import Ouroboros.Consensus.HardFork.Combinator.Util.Match {------------------------------------------------------------------------------- SingleEraBlock -------------------------------------------------------------------------------} -- | Blocks from which we can assemble a hard fork class ( LedgerSupportsProtocol blk , InspectLedger blk , LedgerSupportsMempool blk , HasTxId (GenTx blk) , QueryLedger blk , HasPartialConsensusConfig (BlockProtocol blk) , HasPartialLedgerConfig blk , ConvertRawHash blk , ReconstructNestedCtxt Header blk , CommonProtocolParams blk , LedgerSupportsPeerSelection blk , ConfigSupportsNode blk , NodeInitStorage blk , BlockSupportsMetrics blk -- Instances required to support testing , Eq (GenTx blk) , Eq (Validated (GenTx blk)) , Eq (ApplyTxErr blk) , Show blk , Show (Header blk) , Show (CannotForge blk) , Show (ForgeStateInfo blk) , Show (ForgeStateUpdateError blk) ) => SingleEraBlock blk where -- | Era transition -- -- This should only report the transition point once it is stable (rollback -- cannot affect it anymore). -- -- Since we need this to construct the 'HardForkSummary' (and hence the -- 'EpochInfo'), this takes the /partial/ config, not the full config -- (or we'd end up with a catch-22). singleEraTransition :: PartialLedgerConfig blk -> EraParams -- ^ Current era parameters -> Bound -- ^ Start of this era -> LedgerState blk -> Maybe EpochNo -- | Era information (for use in error messages) singleEraInfo :: proxy blk -> SingleEraInfo blk proxySingle :: Proxy SingleEraBlock proxySingle :: Proxy SingleEraBlock proxySingle = Proxy SingleEraBlock forall k (t :: k). Proxy t Proxy singleEraTransition' :: SingleEraBlock blk => WrapPartialLedgerConfig blk -> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo singleEraTransition' :: WrapPartialLedgerConfig blk -> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo singleEraTransition' = PartialLedgerConfig blk -> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo forall blk. SingleEraBlock blk => PartialLedgerConfig blk -> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo singleEraTransition (PartialLedgerConfig blk -> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo) -> (WrapPartialLedgerConfig blk -> PartialLedgerConfig blk) -> WrapPartialLedgerConfig blk -> EraParams -> Bound -> LedgerState blk -> Maybe EpochNo forall b c a. (b -> c) -> (a -> b) -> a -> c . WrapPartialLedgerConfig blk -> PartialLedgerConfig blk forall blk. WrapPartialLedgerConfig blk -> PartialLedgerConfig blk unwrapPartialLedgerConfig {------------------------------------------------------------------------------- Era index -------------------------------------------------------------------------------} newtype EraIndex xs = EraIndex { EraIndex xs -> NS (K ()) xs getEraIndex :: NS (K ()) xs } instance Eq (EraIndex xs) where EraIndex NS (K ()) xs era == :: EraIndex xs -> EraIndex xs -> Bool == EraIndex NS (K ()) xs era' = Either (Mismatch (K ()) (K ()) xs) (NS (Product (K ()) (K ())) xs) -> Bool forall a b. Either a b -> Bool isRight (NS (K ()) xs -> NS (K ()) xs -> Either (Mismatch (K ()) (K ()) xs) (NS (Product (K ()) (K ())) xs) forall k (f :: k -> *) (xs :: [k]) (g :: k -> *). NS f xs -> NS g xs -> Either (Mismatch f g xs) (NS (Product f g) xs) matchNS NS (K ()) xs era NS (K ()) xs era') instance All SingleEraBlock xs => Show (EraIndex xs) where show :: EraIndex xs -> String show = NS (K String) xs -> String forall k l (h :: (k -> *) -> l -> *) (xs :: l) a. (HCollapse h, SListIN h xs) => h (K a) xs -> CollapseTo h a hcollapse (NS (K String) xs -> String) -> (EraIndex xs -> NS (K String) xs) -> EraIndex xs -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . Proxy SingleEraBlock -> (forall a. SingleEraBlock a => K () a -> K String a) -> NS (K ()) xs -> NS (K String) xs forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint) (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *) (f' :: k -> *). (AllN (Prod h) c xs, HAp h) => proxy c -> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs hcmap Proxy SingleEraBlock proxySingle forall a. SingleEraBlock a => K () a -> K String a getEraName (NS (K ()) xs -> NS (K String) xs) -> (EraIndex xs -> NS (K ()) xs) -> EraIndex xs -> NS (K String) xs forall b c a. (b -> c) -> (a -> b) -> a -> c . EraIndex xs -> NS (K ()) xs forall (xs :: [*]). EraIndex xs -> NS (K ()) xs getEraIndex where getEraName :: forall blk. SingleEraBlock blk => K () blk -> K String blk getEraName :: K () blk -> K String blk getEraName K () blk _ = String -> K String blk forall k a (b :: k). a -> K a b K (String -> K String blk) -> (SingleEraInfo blk -> String) -> SingleEraInfo blk -> K String blk forall b c a. (b -> c) -> (a -> b) -> a -> c . (\String name -> String "<EraIndex " String -> ShowS forall a. Semigroup a => a -> a -> a <> String name String -> ShowS forall a. Semigroup a => a -> a -> a <> String ">") ShowS -> (SingleEraInfo blk -> String) -> SingleEraInfo blk -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> String Text.unpack (Text -> String) -> (SingleEraInfo blk -> Text) -> SingleEraInfo blk -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . SingleEraInfo blk -> Text forall blk. SingleEraInfo blk -> Text singleEraName (SingleEraInfo blk -> K String blk) -> SingleEraInfo blk -> K String blk forall a b. (a -> b) -> a -> b $ Proxy blk -> SingleEraInfo blk forall blk (proxy :: * -> *). SingleEraBlock blk => proxy blk -> SingleEraInfo blk singleEraInfo (Proxy blk forall k (t :: k). Proxy t Proxy @blk) instance All SingleEraBlock xs => Condense (EraIndex xs) where condense :: EraIndex xs -> String condense = NS (K String) xs -> String forall k l (h :: (k -> *) -> l -> *) (xs :: l) a. (HCollapse h, SListIN h xs) => h (K a) xs -> CollapseTo h a hcollapse (NS (K String) xs -> String) -> (EraIndex xs -> NS (K String) xs) -> EraIndex xs -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . Proxy SingleEraBlock -> (forall a. SingleEraBlock a => K () a -> K String a) -> NS (K ()) xs -> NS (K String) xs forall k l (h :: (k -> *) -> l -> *) (c :: k -> Constraint) (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *) (f' :: k -> *). (AllN (Prod h) c xs, HAp h) => proxy c -> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs hcmap Proxy SingleEraBlock proxySingle forall a. SingleEraBlock a => K () a -> K String a getEraName (NS (K ()) xs -> NS (K String) xs) -> (EraIndex xs -> NS (K ()) xs) -> EraIndex xs -> NS (K String) xs forall b c a. (b -> c) -> (a -> b) -> a -> c . EraIndex xs -> NS (K ()) xs forall (xs :: [*]). EraIndex xs -> NS (K ()) xs getEraIndex where getEraName :: forall blk. SingleEraBlock blk => K () blk -> K String blk getEraName :: K () blk -> K String blk getEraName K () blk _ = String -> K String blk forall k a (b :: k). a -> K a b K (String -> K String blk) -> (SingleEraInfo blk -> String) -> SingleEraInfo blk -> K String blk forall b c a. (b -> c) -> (a -> b) -> a -> c . Text -> String Text.unpack (Text -> String) -> (SingleEraInfo blk -> Text) -> SingleEraInfo blk -> String forall b c a. (b -> c) -> (a -> b) -> a -> c . SingleEraInfo blk -> Text forall blk. SingleEraInfo blk -> Text singleEraName (SingleEraInfo blk -> K String blk) -> SingleEraInfo blk -> K String blk forall a b. (a -> b) -> a -> b $ Proxy blk -> SingleEraInfo blk forall blk (proxy :: * -> *). SingleEraBlock blk => proxy blk -> SingleEraInfo blk singleEraInfo (Proxy blk forall k (t :: k). Proxy t Proxy @blk) instance SListI xs => Serialise (EraIndex xs) where encode :: EraIndex xs -> Encoding encode = Word8 -> Encoding forall a. Serialise a => a -> Encoding encode (Word8 -> Encoding) -> (EraIndex xs -> Word8) -> EraIndex xs -> Encoding forall b c a. (b -> c) -> (a -> b) -> a -> c . NS (K ()) xs -> Word8 forall k (xs :: [k]) (f :: k -> *). SListI xs => NS f xs -> Word8 nsToIndex (NS (K ()) xs -> Word8) -> (EraIndex xs -> NS (K ()) xs) -> EraIndex xs -> Word8 forall b c a. (b -> c) -> (a -> b) -> a -> c . EraIndex xs -> NS (K ()) xs forall (xs :: [*]). EraIndex xs -> NS (K ()) xs getEraIndex decode :: Decoder s (EraIndex xs) decode = do Word8 idx <- Decoder s Word8 forall a s. Serialise a => Decoder s a decode case Word8 -> Maybe (NS (K ()) xs) forall k (xs :: [k]). SListI xs => Word8 -> Maybe (NS (K ()) xs) nsFromIndex Word8 idx of Maybe (NS (K ()) xs) Nothing -> String -> Decoder s (EraIndex xs) forall (m :: * -> *) a. MonadFail m => String -> m a fail (String -> Decoder s (EraIndex xs)) -> String -> Decoder s (EraIndex xs) forall a b. (a -> b) -> a -> b $ String "EraIndex: invalid index " String -> ShowS forall a. Semigroup a => a -> a -> a <> Word8 -> String forall a. Show a => a -> String show Word8 idx Just NS (K ()) xs eraIndex -> EraIndex xs -> Decoder s (EraIndex xs) forall (m :: * -> *) a. Monad m => a -> m a return (NS (K ()) xs -> EraIndex xs forall (xs :: [*]). NS (K ()) xs -> EraIndex xs EraIndex NS (K ()) xs eraIndex) eraIndexEmpty :: EraIndex '[] -> Void eraIndexEmpty :: EraIndex '[] -> Void eraIndexEmpty (EraIndex NS (K ()) '[] ns) = case NS (K ()) '[] ns of {} eraIndexFromNS :: SListI xs => NS f xs -> EraIndex xs eraIndexFromNS :: NS f xs -> EraIndex xs eraIndexFromNS = NS (K ()) xs -> EraIndex xs forall (xs :: [*]). NS (K ()) xs -> EraIndex xs EraIndex (NS (K ()) xs -> EraIndex xs) -> (NS f xs -> NS (K ()) xs) -> NS f xs -> EraIndex xs forall b c a. (b -> c) -> (a -> b) -> a -> c . (forall a. f a -> K () a) -> NS f xs -> NS (K ()) 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 (K () a -> f a -> K () a forall a b. a -> b -> a const (() -> K () a forall k a (b :: k). a -> K a b K ())) eraIndexFromIndex :: Index xs blk -> EraIndex xs eraIndexFromIndex :: Index xs blk -> EraIndex xs eraIndexFromIndex Index xs blk index = NS (K ()) xs -> EraIndex xs forall (xs :: [*]). NS (K ()) xs -> EraIndex xs EraIndex (NS (K ()) xs -> EraIndex xs) -> NS (K ()) xs -> EraIndex xs forall a b. (a -> b) -> a -> b $ Index xs blk -> K () blk -> NS (K ()) xs forall k (f :: k -> *) (x :: k) (xs :: [k]). Index xs x -> f x -> NS f xs injectNS Index xs blk index (() -> K () blk forall k a (b :: k). a -> K a b K ()) eraIndexZero :: EraIndex (x ': xs) eraIndexZero :: EraIndex (x : xs) eraIndexZero = NS (K ()) (x : xs) -> EraIndex (x : xs) forall (xs :: [*]). NS (K ()) xs -> EraIndex xs EraIndex (K () x -> NS (K ()) (x : xs) forall a (f :: a -> *) (x :: a) (xs :: [a]). f x -> NS f (x : xs) Z (() -> K () x forall k a (b :: k). a -> K a b K ())) eraIndexSucc :: EraIndex xs -> EraIndex (x ': xs) eraIndexSucc :: EraIndex xs -> EraIndex (x : xs) eraIndexSucc (EraIndex NS (K ()) xs ix) = NS (K ()) (x : xs) -> EraIndex (x : xs) forall (xs :: [*]). NS (K ()) xs -> EraIndex xs EraIndex (NS (K ()) xs -> NS (K ()) (x : xs) forall a (f :: a -> *) (xs :: [a]) (x :: a). NS f xs -> NS f (x : xs) S NS (K ()) xs ix) eraIndexToInt :: EraIndex xs -> Int eraIndexToInt :: EraIndex xs -> Int eraIndexToInt = NS (K ()) xs -> Int forall k (f :: k -> *) (xs :: [k]). NS f xs -> Int index_NS (NS (K ()) xs -> Int) -> (EraIndex xs -> NS (K ()) xs) -> EraIndex xs -> Int forall b c a. (b -> c) -> (a -> b) -> a -> c . EraIndex xs -> NS (K ()) xs forall (xs :: [*]). EraIndex xs -> NS (K ()) xs getEraIndex