More progress with multiple cryptos [wip]

CanHardFork now compiles 🎉

ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal

@@ -45,6 +45,7 @@ library
                      , cardano-binary
                      , cardano-crypto-class
                      , cardano-data
+                     , cardano-ledger-alonzo
                      , cardano-ledger-byron
                      , cardano-ledger-core
                      , cardano-ledger-mary

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/CanHardFork.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE ConstraintKinds       #-}
-{-# LANGUAGE AllowAmbiguousTypes       #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DeriveAnyClass        #-}
 {-# LANGUAGE DeriveGeneric         #-}
@@ -76,8 +75,10 @@ import           Ouroboros.Consensus.Shelley.ShelleyHFC
 
 import           Cardano.Ledger.Crypto (ADDRHASH, Crypto, DSIGN, HASH)
 import qualified Cardano.Ledger.Era as SL
+import Cardano.Ledger.Alonzo.Core(Tx)
 import           Cardano.Ledger.Mary.Translation ()
 import qualified Cardano.Ledger.Shelley.API as SL
+import qualified Cardano.Ledger.BaseTypes as BaseTypes
 import           Cardano.Ledger.Shelley.Translation
                      (toFromByronTranslationContext)
 import qualified Cardano.Protocol.TPraos.API as SL
@@ -379,9 +380,10 @@ translateHeaderHashByronToShelley ::
      ( ShelleyCompatible (TPraos c) (ShelleyEra c)
      , HASH c ~ Blake2b_256
      )
-  => HeaderHash ByronBlock
+  => Proxy c
+  -> HeaderHash ByronBlock
   -> ShelleyHash c
-translateHeaderHashByronToShelley =
+translateHeaderHashByronToShelley _ =
       fromShortRawHash (Proxy @(ShelleyBlock (TPraos c) (ShelleyEra c)))
     . toShortRawHash   (Proxy @ByronBlock)
   where
@@ -403,7 +405,7 @@ translatePointByronToShelley point bNo =
       (BlockPoint s h, NotOrigin n) -> NotOrigin ShelleyTip {
           shelleyTipSlotNo  = s
         , shelleyTipBlockNo = n
-        , shelleyTipHash    = translateHeaderHashByronToShelley h
+        , shelleyTipHash    = translateHeaderHashByronToShelley (Proxy @c) h
         }
       _otherwise ->
         error "translatePointByronToShelley: invalid Byron state"
@@ -709,7 +711,7 @@ translateValidatedTxAlonzoToBabbageWrapper ctxt = InjectValidatedTx $
 
 translateLedgerStateBabbageToConwayWrapper ::
      forall c1 c2.
-     (PraosCrypto c1, PraosCrypto c2, HASH c1 ~ HASH c2)
+     (PraosCrypto c1, PraosCrypto c2, HASH c1 ~ HASH c2, ADDRHASH c1 ~  ADDRHASH c2, DSIGN c1 ~ DSIGN c2)
   => RequiringBoth
        WrapLedgerConfig
        (Translate LedgerState)
@@ -720,17 +722,32 @@ translateLedgerStateBabbageToConwayWrapper =
       Translate $ \_epochNo ->
         unComp . SL.translateEra' (getConwayTranslationContext cfgConway) . Comp . transPraosLS
   where
-    transPraosLS ::
-      (HASH c1 ~ HASH c2)
-      => LedgerState (ShelleyBlock (Praos c1) (BabbageEra c1)) ->
+    transPraosLS ::        LedgerState (ShelleyBlock (Praos c1) (BabbageEra c1)) ->
          LedgerState (ShelleyBlock (Praos c2)  (BabbageEra c2))
     transPraosLS (ShelleyLedgerState wo nes st) =
       ShelleyLedgerState
         { shelleyLedgerTip        = fmap castShelleyTip wo
-        , shelleyLedgerState      = nes
+        , shelleyLedgerState      = translateNewEpochState nes
         , shelleyLedgerTransition = st
         }
 
+translateNewEpochState :: (ADDRHASH c1 ~  ADDRHASH c2, DSIGN c1 ~ DSIGN c2) => SL.NewEpochState (BabbageEra c1) -> SL.NewEpochState (BabbageEra c2)
+translateNewEpochState
+  SL.NewEpochState {nesEL, nesBprev, nesBcur, nesEs, nesRu, nesPd,
+                 stashedAVVMAddresses}
+  = SL.NewEpochState {nesEL, nesBprev = translateBlocksMade nesBprev, nesBcur = translateBlocksMade nesBcur, nesEs = translateEpochState nesEs, nesRu = undefined , nesPd=undefined ,
+                 stashedAVVMAddresses}
+
+translateBlocksMade :: (ADDRHASH c1 ~  ADDRHASH c2, DSIGN c1 ~ DSIGN c2) => BaseTypes.BlocksMade c1 -> BaseTypes.BlocksMade c2
+translateBlocksMade BaseTypes.BlocksMade {unBlocksMade} =
+  BaseTypes.BlocksMade $ Map.mapKeysMonotonic translateKeyHash unBlocksMade
+
+translateKeyHash :: (ADDRHASH c1 ~  ADDRHASH c2, DSIGN c1 ~ DSIGN c2) => SL.KeyHash 'SL.StakePool c1 -> SL.KeyHash 'SL.StakePool c2
+translateKeyHash (SL.KeyHash hash) = SL.KeyHash hash
+
+translateEpochState :: SL.EpochState (BabbageEra c1) -> SL.EpochState (BabbageEra c2)
+translateEpochState = undefined
+
 getConwayTranslationContext ::
      WrapLedgerConfig (ShelleyBlock (Praos c) (ConwayEra c))
   -> SL.TranslationContext (ConwayEra c)
@@ -750,7 +767,7 @@ translateTxBabbageToConwayWrapper ctxt = InjectTx $
     transPraosTx
       :: GenTx (ShelleyBlock (Praos c1) (BabbageEra c1))
       -> GenTx (ShelleyBlock (Praos c2) (BabbageEra c2))
-    transPraosTx (ShelleyTx ti tx) = ShelleyTx (_bar ti) (_foo tx)
+    transPraosTx (ShelleyTx ti tx) = ShelleyTx (translateTxId ti) (translateTx tx)
 
 translateValidatedTxBabbageToConwayWrapper ::
      forall c1 c2 .
@@ -767,4 +784,13 @@ translateValidatedTxBabbageToConwayWrapper ctxt = InjectValidatedTx $
     -> WrapValidatedGenTx (ShelleyBlock (Praos c2) (BabbageEra c2))
   transPraosValidatedTx (WrapValidatedGenTx x) = case x of
     ShelleyValidatedTx txid vtx -> WrapValidatedGenTx $
-      ShelleyValidatedTx (_bar txid) (_foo vtx)
+      ShelleyValidatedTx (translateTxId txid) (translateValidatedTx vtx)
+
+translateTx :: Tx (BabbageEra c1) -> Tx (BabbageEra c2)
+translateTx = undefined
+
+translateValidatedTx :: SL.Validated (Tx (BabbageEra c1)) -> SL.Validated (Tx (BabbageEra c2))
+translateValidatedTx = undefined
+
+translateTxId :: SL.TxId c1 -> SL.TxId c2
+translateTxId = undefined

ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Condense.hs

@@ -23,4 +23,4 @@ instance CondenseConstraints ByronBlock
 
 instance ShelleyCompatible proto era => CondenseConstraints (ShelleyBlock proto era)
 
-instance CardanoHardForkConstraints c => CondenseConstraints (CardanoBlock c)
+instance CardanoHardForkConstraints c1 c2 => CondenseConstraints (CardanoBlock c1 c2)