From 656f371ce1f61a3ef900dfd51c1dde2ff6fe7d76 Mon Sep 17 00:00:00 2001 From: Arnaud Bailly Date: Tue, 28 Mar 2023 07:15:04 +0000 Subject: [PATCH] Propagate dual crypto types to leaf use sites --- .../src/Cardano/Api/Protocol/Types.hs | 11 ++++---- .../Cardano/Tools/DBAnalyser/Block/Cardano.hs | 28 ++++++++++--------- 2 files changed, 21 insertions(+), 18 deletions(-) diff --git a/ouroboros-consensus-cardano-tools/src/Cardano/Api/Protocol/Types.hs b/ouroboros-consensus-cardano-tools/src/Cardano/Api/Protocol/Types.hs index 0f3f828d334..b2619881125 100644 --- a/ouroboros-consensus-cardano-tools/src/Cardano/Api/Protocol/Types.hs +++ b/ouroboros-consensus-cardano-tools/src/Cardano/Api/Protocol/Types.hs @@ -6,6 +6,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- DUPLICATE -- adapted from: cardano-api/src/Cardano/Api/Protocol/Types.hs @@ -58,8 +59,8 @@ instance IOLike m => Protocol m ByronBlockHFC where data ProtocolInfoArgs m ByronBlockHFC = ProtocolInfoArgsByron ProtocolParamsByron protocolInfo (ProtocolInfoArgsByron params) = inject $ protocolInfoByron params -instance (CardanoHardForkConstraints StandardCrypto, IOLike m) => Protocol m (CardanoBlock StandardCrypto) where - data ProtocolInfoArgs m (CardanoBlock StandardCrypto) = +instance (CardanoHardForkConstraints StandardCrypto StandardCrypto, IOLike m) => Protocol m (CardanoBlock StandardCrypto StandardCrypto) where + data ProtocolInfoArgs m (CardanoBlock StandardCrypto StandardCrypto) = ProtocolInfoArgsCardano ProtocolParamsByron (ProtocolParamsShelleyBased StandardShelley) @@ -113,8 +114,8 @@ instance ProtocolClient ByronBlockHFC where protocolClientInfo (ProtocolClientInfoArgsByron epochSlots) = inject $ protocolClientInfoByron epochSlots -instance CardanoHardForkConstraints StandardCrypto => ProtocolClient (CardanoBlock StandardCrypto) where - data ProtocolClientInfoArgs (CardanoBlock StandardCrypto) = +instance CardanoHardForkConstraints StandardCrypto StandardCrypto => ProtocolClient (CardanoBlock StandardCrypto StandardCrypto) where + data ProtocolClientInfoArgs (CardanoBlock StandardCrypto StandardCrypto) = ProtocolClientInfoArgsCardano EpochSlots protocolClientInfo (ProtocolClientInfoArgsCardano epochSlots) = protocolClientInfoCardano epochSlots @@ -143,7 +144,7 @@ instance Consensus.LedgerSupportsProtocol data BlockType blk where ByronBlockType :: BlockType ByronBlockHFC ShelleyBlockType :: BlockType (ShelleyBlockHFC (Consensus.TPraos StandardCrypto) StandardShelley) - CardanoBlockType :: BlockType (CardanoBlock StandardCrypto) + CardanoBlockType :: BlockType (CardanoBlock StandardCrypto StandardCrypto) deriving instance Eq (BlockType blk) deriving instance Show (BlockType blk) diff --git a/ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBAnalyser/Block/Cardano.hs b/ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBAnalyser/Block/Cardano.hs index 4e4020f4adf..170ce97f3ba 100644 --- a/ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBAnalyser/Block/Cardano.hs +++ b/ouroboros-consensus-cardano-tools/src/Cardano/Tools/DBAnalyser/Block/Cardano.hs @@ -73,9 +73,11 @@ import Ouroboros.Consensus.Shelley.Node.Praos import System.Directory (makeAbsolute) import System.FilePath (takeDirectory, ()) +type CBlock = CardanoBlock StandardCrypto StandardCrypto + analyseBlock :: (forall blk. HasAnalysis blk => blk -> a) - -> CardanoBlock StandardCrypto -> a + -> CBlock -> a analyseBlock f = hcollapse . hcmap p (K . f . unI) @@ -90,7 +92,7 @@ analyseBlock f = analyseWithLedgerState :: forall a. (forall blk. HasAnalysis blk => WithLedgerState blk -> a) -> - WithLedgerState (CardanoBlock StandardCrypto) -> + WithLedgerState (CBlock) -> a analyseWithLedgerState f (WithLedgerState cb sb sa) = hcollapse @@ -109,8 +111,8 @@ analyseWithLedgerState f (WithLedgerState cb sb sa) = oeb = getOneEraBlock . getHardForkBlock $ cb goLS :: - LedgerState (CardanoBlock StandardCrypto) -> - NP (Maybe :.: LedgerState) (CardanoEras StandardCrypto) + LedgerState CBlock -> + NP (Maybe :.: LedgerState) (CardanoEras StandardCrypto StandardCrypto) goLS = hexpand (Comp Nothing) . hmap (Comp . Just . currentState) @@ -118,8 +120,8 @@ analyseWithLedgerState f (WithLedgerState cb sb sa) = . getHardForkState . hardForkLedgerStatePerEra -instance HasProtocolInfo (CardanoBlock StandardCrypto) where - data Args (CardanoBlock StandardCrypto) = CardanoBlockArgs { +instance HasProtocolInfo (CBlock) where + data Args (CBlock) = CardanoBlockArgs { configFile :: FilePath , threshold :: Maybe PBftSignatureThreshold } @@ -182,7 +184,7 @@ data CardanoConfig = CardanoConfig { , conwayGenesisPath :: FilePath -- | @Test*HardForkAtEpoch@ for each Shelley era - , hardForkTriggers :: NP ShelleyTransitionArguments (CardanoShelleyEras StandardCrypto) + , hardForkTriggers :: NP ShelleyTransitionArguments (CardanoShelleyEras StandardCrypto StandardCrypto) } instance AdjustFilePaths CardanoConfig where @@ -274,7 +276,7 @@ instance Aeson.FromJSON CardanoConfig where , hardForkTriggers = hardForkTriggers } -instance (HasAnnTip (CardanoBlock StandardCrypto), GetPrevHash (CardanoBlock StandardCrypto)) => HasAnalysis (CardanoBlock StandardCrypto) where +instance (HasAnnTip (CBlock), GetPrevHash (CBlock)) => HasAnalysis (CBlock) where countTxOutputs = analyseBlock countTxOutputs blockTxSizes = analyseBlock blockTxSizes knownEBBs _ = @@ -285,7 +287,7 @@ instance (HasAnnTip (CardanoBlock StandardCrypto), GetPrevHash (CardanoBlock Sta blockStats = analyseBlock blockStats -type CardanoBlockArgs = Args (CardanoBlock StandardCrypto) +type CardanoBlockArgs = Args (CBlock) mkCardanoProtocolInfo :: Byron.Genesis.Config @@ -294,8 +296,8 @@ mkCardanoProtocolInfo :: -> SL.AlonzoGenesis -> SL.ConwayGenesis StandardCrypto -> Nonce - -> NP ShelleyTransitionArguments (CardanoShelleyEras StandardCrypto) - -> ProtocolInfo IO (CardanoBlock StandardCrypto) + -> NP ShelleyTransitionArguments (CardanoShelleyEras StandardCrypto StandardCrypto) + -> ProtocolInfo IO (CBlock) mkCardanoProtocolInfo genesisByron signatureThreshold genesisShelley genesisAlonzo genesisConway initialNonce hardForkTriggers = protocolInfoCardano ProtocolParamsByron { @@ -364,11 +366,11 @@ mkCardanoProtocolInfo genesisByron signatureThreshold genesisShelley genesisAlon castHeaderHash :: HeaderHash ByronBlock - -> HeaderHash (CardanoBlock StandardCrypto) + -> HeaderHash (CBlock) castHeaderHash = OneEraHash . toShortRawHash (Proxy @ByronBlock) castChainHash :: ChainHash ByronBlock - -> ChainHash (CardanoBlock StandardCrypto) + -> ChainHash (CBlock) castChainHash GenesisHash = GenesisHash castChainHash (BlockHash h) = BlockHash $ castHeaderHash h