Propagate dual crypto types to leaf use sites

IntersectMBO · Mar 31, 2023 · 656f371 · 656f371
1 parent 5186676
commit 656f371
Show file tree

Hide file tree

Showing 2 changed files with 21 additions and 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
@@ -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
@@ -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,17 +111,17 @@ 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)
         . Telescope.tip
         . 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