temp

IntersectMBO · May 30, 2023 · 8bccc9b · 8bccc9b
1 parent 0b8fbf0
commit 8bccc9b
Show file tree

Hide file tree

Showing 28 changed files with 603 additions and 680 deletions.
diff --git a/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs b/ouroboros-consensus/bench/mempool-bench/Bench/Consensus/Mempool/TestBlock.hs
@@ -42,7 +42,7 @@ import qualified Ouroboros.Consensus.Ledger.SupportsMempool as Ledger
 import           Ouroboros.Consensus.Ledger.Tables (CanSerializeLedgerTables,
                      CanStowLedgerTables, CodecMK (..), DiffMK (..), EmptyMK,
                      HasLedgerTables, HasTickedLedgerTables, IsMapKind (..),
-                     KeysMK (..), LedgerTables, NameMK (..), ValuesMK (..))
+                     KeysMK (..), LedgerTables (..), NameMK (..), ValuesMK (..))
 import qualified Ouroboros.Consensus.Ledger.Tables.Utils as Ledger
                      (rawAttachAndApplyDiffs)
 import qualified Ouroboros.Consensus.Mempool as Mempool
@@ -51,6 +51,7 @@ import           Test.Util.TestBlock (LedgerState (TestLedger),
                      TestBlockWith, Ticked1 (TickedTestLedger),
                      applyDirectlyToPayloadDependentState,
                      payloadDependentState)
+import Ouroboros.Consensus.Ledger.Tables.Functors (Key1, Key2)
 
 {-------------------------------------------------------------------------------
   MempoolTestBlock
@@ -124,7 +125,7 @@ instance PayloadSemantics Tx where
       fullDiff :: DiffMK Token ()
       fullDiff = DiffMK $ consumedDiff <> producedDiff
 
-  getPayloadKeySets tx = TestLedgerTables $ KeysMK $ consumed <> produced
+  getPayloadKeySets tx = LedgerTables $ KeysMK $ consumed <> produced
     where
       Tx {consumed, produced} = tx
 
@@ -151,55 +152,32 @@ data instance Block.StorageConfig TestBlock = TestBlockStorageConfig
   Ledger tables
 -------------------------------------------------------------------------------}
 
-instance HasLedgerTables (LedgerState TestBlock) where
-  newtype instance LedgerTables (LedgerState TestBlock) mk =
-    TestLedgerTables { getTestLedgerTables :: mk Token () }
-    deriving Generic
+type instance Key1 (LedgerState TestBlock) = Token
+type instance Key2 (LedgerState TestBlock) = ()
 
+instance HasLedgerTables (LedgerState TestBlock) where
   projectLedgerTables st =
-    TestLedgerTables $ getTestPLDS $ payloadDependentState st
+    LedgerTables $ getTestPLDS $ payloadDependentState st
   withLedgerTables st table = st {
         payloadDependentState = plds {
-            getTestPLDS = getTestLedgerTables table
+            getTestPLDS = getLedgerTables table
           }
       }
     where
       TestLedger { payloadDependentState = plds } = st
 
-  pureLedgerTables = TestLedgerTables
-  mapLedgerTables f (TestLedgerTables x) = TestLedgerTables (f x)
-  traverseLedgerTables f (TestLedgerTables x) = TestLedgerTables <$> f x
-  zipLedgerTables f (TestLedgerTables x) (TestLedgerTables y) =
-    TestLedgerTables (f x y)
-  zipLedgerTables3 f (TestLedgerTables x) (TestLedgerTables y) (TestLedgerTables z) =
-    TestLedgerTables (f x y z)
-  zipLedgerTablesA f (TestLedgerTables x) (TestLedgerTables y) =
-    TestLedgerTables <$> f x y
-  zipLedgerTables3A f (TestLedgerTables x) (TestLedgerTables y) (TestLedgerTables z) =
-    TestLedgerTables <$> f x y z
-  foldLedgerTables f (TestLedgerTables x) = f x
-  foldLedgerTables2 f (TestLedgerTables x) (TestLedgerTables y) = f x y
-  namesLedgerTables = TestLedgerTables $ NameMK "benchmempooltables"
-
 instance CanSerializeLedgerTables (LedgerState TestBlock) where
-  codecLedgerTables = TestLedgerTables $ CodecMK toCBOR toCBOR fromCBOR fromCBOR
-
-deriving stock instance IsMapKind mk
-                     => Eq (LedgerTables (LedgerState TestBlock) mk)
-deriving stock instance IsMapKind mk
-                     => Show (LedgerTables (LedgerState TestBlock) mk)
-deriving anyclass instance IsMapKind mk
-                        => NoThunks (LedgerTables (LedgerState TestBlock) mk)
+  codecLedgerTables = LedgerTables $ CodecMK toCBOR toCBOR fromCBOR fromCBOR
 
 instance CanStowLedgerTables (LedgerState TestBlock) where
   stowLedgerTables     = error "unused: stowLedgerTables"
   unstowLedgerTables   = error "unused: unstowLedgerTables"
 
-instance HasTickedLedgerTables (LedgerState TestBlock) where
-  projectLedgerTablesTicked (TickedTestLedger st) =
+instance HasLedgerTables (Ticked1 (LedgerState TestBlock)) where
+  projectLedgerTables (TickedTestLedger st) = Ledger.castLedgerTables $
     Ledger.projectLedgerTables st
-  withLedgerTablesTicked (TickedTestLedger st) tables =
-    TickedTestLedger $ Ledger.withLedgerTables st tables
+  withLedgerTables (TickedTestLedger st) tables =
+    TickedTestLedger $ Ledger.withLedgerTables st (Ledger.castLedgerTables tables)
 
 {-------------------------------------------------------------------------------
   Mempool support
@@ -231,7 +209,7 @@ instance Ledger.LedgerSupportsMempool TestBlock where
 
   txForgetValidated (ValidatedGenTx tx) = tx
 
-  getTransactionKeySets (TestBlockGenTx tx) = TestLedgerTables $
+  getTransactionKeySets (TestBlockGenTx tx) = LedgerTables $
     KeysMK $ consumed tx
 
 newtype instance Ledger.TxId (Ledger.GenTx TestBlock) = TestBlockTxId Tx

diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal
@@ -167,6 +167,7 @@ library
     Ouroboros.Consensus.Ledger.SupportsPeerSelection
     Ouroboros.Consensus.Ledger.SupportsProtocol
     Ouroboros.Consensus.Ledger.Tables
+    Ouroboros.Consensus.Ledger.Tables.Functors
     Ouroboros.Consensus.Ledger.Tables.Utils
     Ouroboros.Consensus.Mempool
     Ouroboros.Consensus.Mempool.API

diff --git a/ouroboros-consensus/src/consensus-testlib/Test/Util/LedgerStateOnlyTables.hs b/ouroboros-consensus/src/consensus-testlib/Test/Util/LedgerStateOnlyTables.hs
@@ -20,14 +20,14 @@ module Test.Util.LedgerStateOnlyTables (
   ) where
 
 import           Cardano.Binary (FromCBOR (..), ToCBOR (..))
-import           GHC.Generics (Generic)
 import           NoThunks.Class (NoThunks)
 import           Ouroboros.Consensus.Ledger.Basics (LedgerState)
 import           Ouroboros.Consensus.Ledger.Tables
                      (CanSerializeLedgerTables (..), CanStowLedgerTables (..),
                      CodecMK (..), HasLedgerTables (..), MapKind, NameMK (..),
-                     ValuesMK)
+                     ValuesMK, LedgerTables (..))
 import           Ouroboros.Consensus.Ledger.Tables.Utils (emptyLedgerTables)
+import Ouroboros.Consensus.Ledger.Tables.Functors (Key1, Key2)
 
 {-------------------------------------------------------------------------------
   Simple ledger state
@@ -72,55 +72,17 @@ instance (Ord k, Eq v, Show k, Show v, NoThunks k, NoThunks v)
   Simple ledger tables
 -------------------------------------------------------------------------------}
 
+type instance Key1 (OTLedgerState k v) = k
+type instance Key2 (OTLedgerState k v) = v
+
+pattern OTLedgerTables :: mk k v -> OTLedgerTables k v mk
+pattern OTLedgerTables{otltLedgerTables} = LedgerTables otltLedgerTables
+
 instance (Ord k, Eq v, Show k, Show v, NoThunks k, NoThunks v)
       => HasLedgerTables (OTLedgerState k v) where
-  newtype LedgerTables (OTLedgerState k v) mk = OTLedgerTables {
-      otltLedgerTables :: mk k v
-    } deriving Generic
 
   projectLedgerTables OTLedgerState{otlsLedgerTables} =
     otlsLedgerTables
 
   withLedgerTables st lt =
     st { otlsLedgerTables = lt }
-
-  pureLedgerTables f =
-    OTLedgerTables { otltLedgerTables = f }
-
-  mapLedgerTables f OTLedgerTables{otltLedgerTables} =
-    OTLedgerTables $ f otltLedgerTables
-
-  traverseLedgerTables f OTLedgerTables{otltLedgerTables} =
-    OTLedgerTables <$> f otltLedgerTables
-
-  zipLedgerTables f l r =
-    OTLedgerTables (f (otltLedgerTables l) (otltLedgerTables r))
-
-  zipLedgerTablesA f l r =
-    OTLedgerTables <$> f (otltLedgerTables l) (otltLedgerTables r)
-
-  zipLedgerTables3 f l m r =
-    OTLedgerTables $
-      f (otltLedgerTables l) (otltLedgerTables m) (otltLedgerTables r)
-
-  zipLedgerTables3A f l c r =
-    OTLedgerTables <$>
-      f (otltLedgerTables l) (otltLedgerTables c) (otltLedgerTables r)
-
-  foldLedgerTables f OTLedgerTables{otltLedgerTables} =
-    f otltLedgerTables
-
-  foldLedgerTables2 f l r =
-    f (otltLedgerTables l) (otltLedgerTables r)
-
-  namesLedgerTables =
-    OTLedgerTables { otltLedgerTables = NameMK "otltLedgerTables" }
-
-deriving stock instance (Eq (mk k v))
-               => Eq (OTLedgerTables k v mk)
-
-deriving stock instance (Show (mk k v))
-               => Show (OTLedgerTables k v mk)
-
-deriving newtype instance NoThunks (mk k v)
-               => NoThunks (OTLedgerTables k v mk)
diff --git a/ouroboros-consensus/src/consensus-testlib/Test/Util/TestBlock.hs b/ouroboros-consensus/src/consensus-testlib/Test/Util/TestBlock.hs
@@ -23,6 +23,7 @@
 {-# LANGUAGE ViewPatterns               #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# LANGUAGE InstanceSigs #-}
 -- | Minimal instantiation of the consensus layer to be able to run the ChainDB
 module Test.Util.TestBlock (
     -- * Blocks
@@ -133,6 +134,8 @@ import qualified System.Random as R
 import           Test.QuickCheck hiding (Result)
 import           Test.Util.Orphans.SignableRepresentation ()
 import           Test.Util.Orphans.ToExpr ()
+import Ouroboros.Consensus.Ledger.Tables.Functors (Key1, Key2)
+import Cardano.Prelude (Void)
 
 {-------------------------------------------------------------------------------
   Test infrastructure: test block
@@ -373,7 +376,7 @@ instance PayloadSemantics () where
 
   applyPayload _ _ = Right EmptyPLDS
 
-  getPayloadKeySets = const NoTestLedgerTables
+  getPayloadKeySets = const trivialLedgerTables
 
 -- | Apply the payload directly to the payload dependent state portion of a
 -- ticked state, leaving the rest of the input ticked state unaltered.
@@ -456,20 +459,22 @@ instance ( Typeable ptype
 
 type instance LedgerCfg (LedgerState TestBlock) = HardFork.EraParams
 
+type instance Key1 (LedgerState TestBlock) = Void
+type instance Key2 (LedgerState TestBlock) = Void
+
 instance HasLedgerTables (LedgerState TestBlock) where
-  data LedgerTables (LedgerState TestBlock) mk = NoTestLedgerTables
-    deriving stock    (Generic, Eq, Show)
-    deriving anyclass (NoThunks)
 
 instance LedgerTablesAreTrivial (LedgerState (TestBlockWith ())) where
   convertMapKind (TestLedger lap EmptyPLDS) = TestLedger lap EmptyPLDS
-  trivialLedgerTables = NoTestLedgerTables
+  trivialLedgerTables = pureLedgerTables emptyMK
 
 instance CanSerializeLedgerTables (LedgerState TestBlock) where
+  codecLedgerTables = LedgerTables $ CodecMK undefined undefined undefined undefined
 
-instance HasTickedLedgerTables (LedgerState TestBlock) where
-  withLedgerTablesTicked (TickedTestLedger st) tables =
-      TickedTestLedger $ withLedgerTables st tables
+instance HasLedgerTables (Ticked1 (LedgerState TestBlock)) where
+  projectLedgerTables (TickedTestLedger st) = castLedgerTables $ projectLedgerTables st
+  withLedgerTables (TickedTestLedger st) tables =
+      TickedTestLedger $ withLedgerTables st (castLedgerTables tables)
 
 instance CanStowLedgerTables (LedgerState TestBlock) where
 

diff --git a/ouroboros-consensus/src/mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs b/ouroboros-consensus/src/mock-block/Ouroboros/Consensus/Mock/Ledger/Block.hs
@@ -102,6 +102,7 @@ import           Ouroboros.Consensus.Util (ShowProxy (..), hashFromBytesShortE,
                      (..:))
 import           Ouroboros.Consensus.Util.Condense
 import           Ouroboros.Consensus.Util.Orphans ()
+import Ouroboros.Consensus.Ledger.Tables.Functors (Key1, Key2)
 
 {-------------------------------------------------------------------------------
   Definition of a block
@@ -380,7 +381,7 @@ instance MockProtocolSpecific c ext
 
   getBlockKeySets SimpleBlock{simpleBody = SimpleBody txs} =
     foldMap' id
-     [ SimpleLedgerTables $ KeysMK ins | Mock.Tx _ ins _ <- txs ]
+     [ LedgerTables $ KeysMK ins | Mock.Tx _ ins _ <- txs ]
 
 data instance LedgerState (SimpleBlock c ext) mk  = SimpleLedgerState {
       simpleLedgerState :: MockState (SimpleBlock c ext)
@@ -452,62 +453,21 @@ instance LedgerSupportsPeerSelection (SimpleBlock c ext) where
   LedgerTables
 -------------------------------------------------------------------------------}
 
-instance HasLedgerTables (LedgerState (SimpleBlock c ext)) where
-  newtype LedgerTables (LedgerState (SimpleBlock c ext)) mk = SimpleLedgerTables {
-      unSimpleLedgerTables :: mk Mock.TxIn Mock.TxOut
-    }
-    deriving (Generic)
+type instance Key1 (LedgerState (SimpleBlock c ext)) = Mock.TxIn
+type instance Key2 (LedgerState (SimpleBlock c ext)) = Mock.TxOut
 
+instance HasLedgerTables (LedgerState (SimpleBlock c ext)) where
   projectLedgerTables = simpleLedgerTables
 
   withLedgerTables (SimpleLedgerState s _) tbs' = SimpleLedgerState s tbs'
 
-  pureLedgerTables f = SimpleLedgerTables f
-
-  mapLedgerTables f (SimpleLedgerTables tbs) = SimpleLedgerTables (f tbs)
-
-  traverseLedgerTables f (SimpleLedgerTables tbs) = SimpleLedgerTables <$> f tbs
-
-  zipLedgerTables f (SimpleLedgerTables tbsL) (SimpleLedgerTables tbsR) =
-    SimpleLedgerTables (f tbsL tbsR)
-
-  zipLedgerTables3
-    f
-    (SimpleLedgerTables utxoL)
-    (SimpleLedgerTables utxoC)
-    (SimpleLedgerTables utxoR) =
-      SimpleLedgerTables (f utxoL utxoC utxoR)
-
-  zipLedgerTablesA f (SimpleLedgerTables utxoL) (SimpleLedgerTables utxoR) =
-      SimpleLedgerTables <$> f utxoL utxoR
-
-  zipLedgerTables3A
-    f
-    (SimpleLedgerTables utxoL)
-    (SimpleLedgerTables utxoC)
-    (SimpleLedgerTables utxoR) =
-      SimpleLedgerTables <$> f utxoL utxoC utxoR
-
-  foldLedgerTables f (SimpleLedgerTables utxo) = f utxo
-
-  foldLedgerTables2 f (SimpleLedgerTables utxoL) (SimpleLedgerTables utxoR) = f utxoL utxoR
-
-  namesLedgerTables = SimpleLedgerTables (NameMK "mock-utxo")
-
-deriving instance Eq (mk Mock.TxIn Mock.TxOut)
-               => Eq (LedgerTables (LedgerState (SimpleBlock c ext)) mk)
-deriving anyclass instance NoThunks (mk Mock.TxIn Mock.TxOut)
-                        => NoThunks (LedgerTables (LedgerState (SimpleBlock c ext)) mk)
-deriving instance Show (mk Mock.TxIn Mock.TxOut)
-               => Show (LedgerTables (LedgerState (SimpleBlock c ext)) mk)
-
-instance HasTickedLedgerTables (LedgerState (SimpleBlock c ext)) where
-  projectLedgerTablesTicked = simpleLedgerTables . getTickedSimpleLedgerState
-  withLedgerTablesTicked    (TickedSimpleLedgerState st) tables =
-      TickedSimpleLedgerState $ withLedgerTables st tables
+instance HasLedgerTables (Ticked1 (LedgerState (SimpleBlock c ext))) where
+  projectLedgerTables = castLedgerTables . simpleLedgerTables . getTickedSimpleLedgerState
+  withLedgerTables    (TickedSimpleLedgerState st) tables =
+      TickedSimpleLedgerState $ withLedgerTables st (castLedgerTables tables)
 
 instance CanSerializeLedgerTables (LedgerState (SimpleBlock c ext)) where
-    codecLedgerTables = SimpleLedgerTables (CodecMK toCBOR toCBOR fromCBOR fromCBOR)
+    codecLedgerTables = LedgerTables (CodecMK toCBOR toCBOR fromCBOR fromCBOR)
 
 instance CanStowLedgerTables (LedgerState (SimpleBlock c ext)) where
   stowLedgerTables st =
@@ -518,14 +478,14 @@ instance CanStowLedgerTables (LedgerState (SimpleBlock c ext)) where
     where
       SimpleLedgerState {
           simpleLedgerState
-        , simpleLedgerTables = SimpleLedgerTables (ValuesMK m)
+        , simpleLedgerTables = LedgerTables (ValuesMK m)
         } = st
 
   unstowLedgerTables st =
     SimpleLedgerState {
         simpleLedgerState = simpleLedgerState { mockUtxo = mempty }
       , simpleLedgerTables =
-          SimpleLedgerTables (ValuesMK (mockUtxo simpleLedgerState))
+          LedgerTables (ValuesMK (mockUtxo simpleLedgerState))
       }
     where
       SimpleLedgerState {
@@ -576,7 +536,7 @@ instance MockProtocolSpecific c ext
 
   getTransactionKeySets tx =
     let Mock.Tx _ ins _ = simpleGenTx tx
-    in SimpleLedgerTables $ KeysMK ins
+    in LedgerTables $ KeysMK ins
 
 newtype instance TxId (GenTx (SimpleBlock c ext)) = SimpleGenTxId {
       unSimpleGenTxId :: Mock.TxId

diff --git a/ouroboros-consensus/src/mock-block/Ouroboros/Consensus/Mock/Node/Serialisation.hs b/ouroboros-consensus/src/mock-block/Ouroboros/Consensus/Mock/Node/Serialisation.hs
@@ -55,7 +55,7 @@ instance Serialise ext => DecodeDisk (MockBlock ext) (Lazy.ByteString -> Header
 instance EncodeDisk (MockBlock ext) (LedgerState (MockBlock ext) EmptyMK) where
   encodeDisk _ = encode . simpleLedgerState
 instance DecodeDisk (MockBlock ext) (LedgerState (MockBlock ext) EmptyMK) where
-  decodeDisk _ = flip SimpleLedgerState (SimpleLedgerTables EmptyMK) <$> decode
+  decodeDisk _ = flip SimpleLedgerState (LedgerTables EmptyMK) <$> decode
 
 instance EncodeDisk (MockBlock ext) (AnnTip (MockBlock ext)) where
   encodeDisk _ = defaultEncodeAnnTip encode