temp

cabal.project

@@ -93,7 +93,7 @@ source-repository-package
 source-repository-package
   type: git
   location: https://github.com/input-output-hk/cardano-ledger
-  tag: febddc58683186232db5fa376de65c58973f9686
+  tag: ff9982e22d6c8e5a3af4bd3e87794a3b27e91afa
   subdir:
    libs/cardano-ledger-binary
-  --sha256: 0q6c2f4ld5l85153q8xrm2qc64k8p0y66j6adcl8bga31yd0pl16
+  --sha256: 0nk2b5sv7cbdlf7rq3affjyc9xq8lhjk2mjb536rqxqyvd6kfgmi

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

@@ -402,7 +402,6 @@ library cardano-testlib
     , containers
     , microlens
     , mtl
-    , nothunks
     , ouroboros-consensus-cardano
     , ouroboros-consensus-diffusion:{ouroboros-consensus-diffusion, diffusion-testlib}
     , ouroboros-consensus-protocol:{ouroboros-consensus-protocol, protocol-testlib}

ouroboros-consensus-cardano/src/byron-testlib/Test/Consensus/Byron/Examples.hs

@@ -110,7 +110,7 @@ examples = Golden.Examples {
     , exampleChainDepState    = unlabelled exampleChainDepState
     , exampleExtLedgerState   = unlabelled $ forgetLedgerTables exampleExtLedgerState
     , exampleSlotNo           = unlabelled exampleSlotNo
-    , exampleLedgerTables     = unlabelled NoByronLedgerTables
+    , exampleLedgerTables     = unlabelled emptyLedgerTables
     }
   where
     regularAndEBB :: a -> a -> Labelled a

ouroboros-consensus-cardano/src/byron-testlib/Test/Consensus/Byron/Generators.hs

@@ -46,6 +46,7 @@ import           Ouroboros.Consensus.Config.SecurityParam
 import           Ouroboros.Consensus.HeaderValidation (AnnTip (..))
 import           Ouroboros.Consensus.Ledger.Abstract
 import           Ouroboros.Consensus.Ledger.SupportsMempool (GenTxId)
+import           Ouroboros.Consensus.Ledger.Tables.Utils (emptyLedgerTables)
 import           Ouroboros.Consensus.Protocol.PBFT.State (PBftState)
 import qualified Ouroboros.Consensus.Protocol.PBFT.State as PBftState
 import           Ouroboros.Network.SizeInBytes
@@ -291,8 +292,8 @@ genByronLedgerState = do
         Left _  -> pure Origin
         Right _ -> At <$> arbitrary
 
-instance Arbitrary (LedgerTables (LedgerState ByronBlock) mk) where
-  arbitrary = pure NoByronLedgerTables
+instance IsMapKind mk => Arbitrary (LedgerTables (LedgerState ByronBlock) mk) where
+  arbitrary = pure emptyLedgerTables
 
 genByronLedgerConfig :: Gen Byron.Config
 genByronLedgerConfig = hedgehog $ CC.genConfig protocolMagicId

ouroboros-consensus-cardano/src/byron/Ouroboros/Consensus/Byron/Ledger/Ledger.hs

@@ -62,6 +62,7 @@ import           Data.ByteString (ByteString)
 import           Data.Kind (Type)
 import           Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
+import           Data.Void (Void)
 import           GHC.Generics (Generic)
 import           NoThunks.Class (NoThunks)
 import           Ouroboros.Consensus.Block
@@ -181,21 +182,16 @@ instance IsLedger (LedgerState ByronBlock) where
             byronLedgerTransition
         }
 
-instance HasLedgerTables (LedgerState ByronBlock) where
-  data LedgerTables (LedgerState ByronBlock) mk = NoByronLedgerTables
-    deriving (Generic, Eq, Show, NoThunks)
+type instance Key   (LedgerState ByronBlock) = Void
+type instance Value (LedgerState ByronBlock) = Void
 
-instance CanSerializeLedgerTables (LedgerState ByronBlock) where
-
-instance LedgerTablesAreTrivial (LedgerState ByronBlock) where
-  convertMapKind ByronLedgerState{..} = ByronLedgerState{..}
-  trivialLedgerTables = NoByronLedgerTables
-
-instance HasTickedLedgerTables (LedgerState ByronBlock) where
-  withLedgerTablesTicked (TickedByronLedgerState st trans) NoByronLedgerTables =
-    TickedByronLedgerState st trans
-
-instance CanStowLedgerTables (LedgerState ByronBlock) where
+instance HasLedgerTables (LedgerState ByronBlock)
+instance HasLedgerTables (Ticked1 (LedgerState ByronBlock))
+instance HasTickedLedgerTables (LedgerState ByronBlock)
+instance CanSerializeLedgerTables (LedgerState ByronBlock)
+instance CanStowLedgerTables (LedgerState ByronBlock)
+instance LedgerTablesAreTrivial (LedgerState ByronBlock)
+instance LedgerTablesAreTrivial (Ticked1 (LedgerState ByronBlock))
 
 {-------------------------------------------------------------------------------
   Supporting the various consensus interfaces
@@ -220,7 +216,7 @@ data instance BlockQuery ByronBlock :: Type -> Type where
 instance QueryLedger ByronBlock where
   answerBlockQuery _cfg GetUpdateInterfaceState (DiskLedgerView (ExtLedgerState ledgerState _) _ _ _) =
     pure $ CC.cvsUpdateState (byronLedgerState ledgerState)
-  getQueryKeySets _ = NoByronLedgerTables
+  getQueryKeySets _ = trivialLedgerTables
   tableTraversingQuery _ = Nothing
 
 instance SameDepIndex (BlockQuery ByronBlock) where

ouroboros-consensus-cardano/src/byronspec/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs

@@ -24,6 +24,7 @@ import qualified Byron.Spec.Ledger.Update as Spec
 import           Codec.Serialise
 import           Control.Monad.Except
 import qualified Control.State.Transition as Spec
+import           Data.Void (Void)
 import           GHC.Generics (Generic)
 import           NoThunks.Class (AllowThunk (..), NoThunks)
 import           Ouroboros.Consensus.Block
@@ -121,39 +122,15 @@ instance IsLedger (LedgerState ByronSpecBlock) where
   Ledger Tables
 -------------------------------------------------------------------------------}
 
-instance HasLedgerTables (LedgerState ByronSpecBlock) where
-  data LedgerTables (LedgerState ByronSpecBlock) mk = NoByronSpecLedgerTables
-    deriving (Generic, Eq, Show, NoThunks)
-
-instance CanSerializeLedgerTables (LedgerState ByronSpecBlock) where
-    codecLedgerTables = NoByronSpecLedgerTables
-
-instance HasTickedLedgerTables (LedgerState ByronSpecBlock) where
-  projectLedgerTablesTicked _st                     = NoByronSpecLedgerTables
-  withLedgerTablesTicked st NoByronSpecLedgerTables =
-      TickedByronSpecLedgerState { untickedByronSpecLedgerTip
-                                 , tickedByronSpecLedgerState
-                                 }
-    where
-      TickedByronSpecLedgerState { untickedByronSpecLedgerTip
-                                 , tickedByronSpecLedgerState
-                                 } = st
-
-instance LedgerTablesAreTrivial (LedgerState ByronSpecBlock) where
-  convertMapKind st =
-      ByronSpecLedgerState { byronSpecLedgerTip
-                           , byronSpecLedgerState
-                           }
-    where
-      ByronSpecLedgerState { byronSpecLedgerTip
-                           , byronSpecLedgerState
-                           } = st
-
-  trivialLedgerTables = NoByronSpecLedgerTables
-
-instance CanStowLedgerTables (LedgerState ByronSpecBlock) where
-  stowLedgerTables     = convertMapKind
-  unstowLedgerTables   = convertMapKind
+type instance Key   (LedgerState ByronSpecBlock) = Void
+type instance Value (LedgerState ByronSpecBlock) = Void
+instance HasLedgerTables (LedgerState ByronSpecBlock)
+instance HasLedgerTables (Ticked1 (LedgerState ByronSpecBlock))
+instance CanSerializeLedgerTables (LedgerState ByronSpecBlock)
+instance HasTickedLedgerTables (LedgerState ByronSpecBlock)
+instance LedgerTablesAreTrivial (LedgerState ByronSpecBlock)
+instance LedgerTablesAreTrivial (Ticked1 (LedgerState ByronSpecBlock))
+instance CanStowLedgerTables (LedgerState ByronSpecBlock)
 
 {-------------------------------------------------------------------------------
   Applying blocks

ouroboros-consensus-cardano/src/cardano-testlib/Test/Consensus/Cardano/Examples.hs

@@ -45,7 +45,7 @@ import           Ouroboros.Consensus.HeaderValidation (AnnTip)
 import           Ouroboros.Consensus.Ledger.Extended
 import           Ouroboros.Consensus.Ledger.SupportsMempool (ApplyTxErr)
 import           Ouroboros.Consensus.Ledger.Tables (EmptyMK, IsMapKind,
-                     ValuesMK)
+                     ValuesMK, castLedgerTables)
 import           Ouroboros.Consensus.Protocol.Praos.Translate ()
 import           Ouroboros.Consensus.Protocol.TPraos (TPraos)
 import           Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock)
@@ -164,8 +164,8 @@ injectWrapLedgerTables ::
    -> Index xs x
    -> WrapLedgerTables x
    -> WrapLedgerTables (HardForkBlock xs)
-injectWrapLedgerTables _startBounds idx (WrapLedgerTables (ExtLedgerStateTables lt)) =
-    WrapLedgerTables $ ExtLedgerStateTables $ injectLedgerTables lt
+injectWrapLedgerTables _startBounds idx (WrapLedgerTables lt) =
+    WrapLedgerTables $ castLedgerTables $ injectLedgerTables (castLedgerTables lt)
   where
     injectLedgerTables ::
          (IsMapKind mk)

ouroboros-consensus-cardano/src/cardano-testlib/Test/ThreadNet/Infra/ShelleyBasedHardFork.hs

@@ -53,8 +53,6 @@ import qualified Data.SOP.Strict as SOP
 import qualified Data.SOP.Tails as Tails
 import qualified Data.SOP.Telescope as Telescope
 import           Data.Void (Void)
-import           GHC.Generics (Generic)
-import           NoThunks.Class (NoThunks)
 import           Ouroboros.Consensus.Cardano.CanHardFork
                      (ShelleyPartialLedgerConfig (..), forecastAcrossShelley,
                      translateChainDepStateAcrossShelley)
@@ -196,13 +194,13 @@ instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2
               . Comp
               . Flip
           , translateLedgerTablesWith =
-                ShelleyLedgerTables
+                LedgerTables
               . fmap
                 ( unTxOutWrapper
                 . SL.translateEra' (shelleyLedgerTranslationContext (unwrapLedgerConfig cfg2))
                 . TxOutWrapper
                 )
-              . shelleyUTxOTable
+              . getLedgerTables
         }
 
       forecastAcrossShelleyWrapper ::
@@ -319,20 +317,15 @@ withLedgerTablesHelper with (HardForkState tele) tbs =
                         tbs
               }
 
+
+type instance Key   (LedgerStateShelley proto1 era1 proto2 era2) = SL.TxIn (EraCrypto era1)
+type instance Value (LedgerStateShelley proto1 era1 proto2 era2) = ShelleyTxOut '[era1, era2]
+
 -- Note that this is a HardForkBlock instance, but it's not compositional. This
 -- is because the LedgerTables relies on knowledge specific to Shelley and we
 -- have so far not found a pleasant way to express that compositionally.
 instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2
       => HasLedgerTables (LedgerStateShelley proto1 era1 proto2 era2) where
-  newtype LedgerTables (LedgerStateShelley proto1 era1 proto2 era2) mk =
-    ShelleyBasedHardForkLedgerTables {
-        shelleyBasedHardForkUTxOTable ::
-            mk
-              (SL.TxIn (EraCrypto era1))
-              (ShelleyTxOut '[era1, era2])
-      }
-    deriving (Generic)
-
   projectLedgerTables (HardForkLedgerState hfstate) =
       projectLedgerTablesHelper
         (projectLedgerTables . unFlip)
@@ -345,79 +338,41 @@ instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2
           hfstate
           tables
 
-  pureLedgerTables = ShelleyBasedHardForkLedgerTables
-  mapLedgerTables      f (ShelleyBasedHardForkLedgerTables x) =
-    ShelleyBasedHardForkLedgerTables (f x)
-  traverseLedgerTables f (ShelleyBasedHardForkLedgerTables x) =
-    ShelleyBasedHardForkLedgerTables <$> f x
-  zipLedgerTables      f (ShelleyBasedHardForkLedgerTables l)
-                         (ShelleyBasedHardForkLedgerTables r) =
-    ShelleyBasedHardForkLedgerTables (f l r)
-  zipLedgerTables3     f (ShelleyBasedHardForkLedgerTables l)
-                         (ShelleyBasedHardForkLedgerTables c)
-                         (ShelleyBasedHardForkLedgerTables r) =
-    ShelleyBasedHardForkLedgerTables (f l c r)
-  zipLedgerTablesA     f (ShelleyBasedHardForkLedgerTables l)
-                         (ShelleyBasedHardForkLedgerTables r) =
-    ShelleyBasedHardForkLedgerTables <$> f l r
-  zipLedgerTables3A    f (ShelleyBasedHardForkLedgerTables l)
-                         (ShelleyBasedHardForkLedgerTables c)
-                         (ShelleyBasedHardForkLedgerTables r) =
-    ShelleyBasedHardForkLedgerTables <$> f l c r
-  foldLedgerTables     f (ShelleyBasedHardForkLedgerTables x) = f x
-  foldLedgerTables2    f (ShelleyBasedHardForkLedgerTables l)
-                         (ShelleyBasedHardForkLedgerTables r) = f l r
-  namesLedgerTables = ShelleyBasedHardForkLedgerTables {
-      shelleyBasedHardForkUTxOTable = NameMK "shelleyBasedHardForkUTxOTable"
-    }
-
-type ShelleyTables proto1 era1 proto2 era2 mk =
-     LedgerTables (LedgerStateShelley proto1 era1 proto2 era2) mk
-
-deriving instance ( ShelleyBasedHardForkConstraints proto1 era1 proto2 era2
-                  , IsMapKind mk
-                  ) => Eq (ShelleyTables proto1 era1 prot2 era2 mk)
-deriving instance ( ShelleyBasedHardForkConstraints proto1 era1 proto2 era2
-                  , IsMapKind mk
-                  ) => NoThunks (ShelleyTables proto1 era1 proto2 era2 mk)
-deriving instance ( ShelleyBasedHardForkConstraints proto1 era1 proto2 era2
-                  , IsMapKind mk
-                  ) => Show (ShelleyTables proto1 era1 proto2 era2 mk)
-
 instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2
       => CanSerializeLedgerTables (LedgerStateShelley proto1 era1 proto2 era2) where
     codecLedgerTables =
-      ShelleyBasedHardForkLedgerTables (CodecMK
-                                         (Core.toEraCBOR @era1)
-                                         toCBOR
-                                         (Core.fromEraCBOR @era2)
-                                         fromCBOR)
-
+      LedgerTables (CodecMK
+                     (Core.toEraCBOR @era1)
+                     toCBOR
+                     (Core.fromEraCBOR @era2)
+                     fromCBOR)
 
 instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2
-      => HasTickedLedgerTables (LedgerStateShelley proto1 era1 proto2 era2) where
-
-  projectLedgerTablesTicked st =
+      => HasLedgerTables (Ticked1 (LedgerStateShelley proto1 era1 proto2 era2)) where
+  projectLedgerTables st = castLedgerTables $
       projectLedgerTablesHelper
-        (\(FlipTickedLedgerState st') -> projectLedgerTablesTicked st')
+        (\(FlipTickedLedgerState st') -> castLedgerTables $ projectLedgerTables st')
         (tickedHardForkLedgerStatePerEra st)
 
-  withLedgerTablesTicked ths tables =
+  withLedgerTables ths tables =
       TickedHardForkLedgerState {
           tickedHardForkLedgerStateTransition
         , tickedHardForkLedgerStatePerEra     =
             withLedgerTablesHelper
               (\(FlipTickedLedgerState st) tables' ->
-                 FlipTickedLedgerState $ withLedgerTablesTicked st tables')
+                 FlipTickedLedgerState $ withLedgerTables st $ castLedgerTables tables')
               tickedHardForkLedgerStatePerEra
-              tables
+              (castLedgerTables tables)
         }
     where
       TickedHardForkLedgerState {
           tickedHardForkLedgerStateTransition
         , tickedHardForkLedgerStatePerEra
         } = ths
 
+instance ShelleyBasedHardForkConstraints proto1 era1 proto2 era2
+      => HasTickedLedgerTables (LedgerStateShelley proto1 era1 proto2 era2)
+
 instance
      ShelleyBasedHardForkConstraints proto1 era1 proto2 era2
   => LedgerTablesCanHardFork (ShelleyBasedHardForkEras proto1 era1 proto2 era2) where
@@ -437,17 +392,17 @@ instance
       shelley idx =
           InjectLedgerTables
           { applyInjectLedgerTables =
-                ShelleyBasedHardForkLedgerTables
+                LedgerTables
               . mapMK (ShelleyTxOut . SOP.injectNS idx . TxOutWrapper)
-              . shelleyUTxOTable
+              . getLedgerTables
           , applyDistribLedgerTables =
-                ShelleyLedgerTables
+                LedgerTables
               . mapMK ( unTxOutWrapper
                       . SOP.apFn (projectNP idx translations)
                       . SOP.K
                       . unShelleyTxOut
                       )
-              . shelleyBasedHardForkUTxOTable
+              . getLedgerTables
           }
 
 translations ::