WIP code-review

ouroboros-consensus-cardano/app/snapshot-converter.hs

@@ -233,10 +233,10 @@ store Config{to = LMDB, outpath} fs@(SomeHasFS hasFS) ccfg state = do
         LMDB.readWriteTransaction dbEnv $
             lttraverse Disk.getDb (ltpure $ K2 "utxo")
     LMDB.readWriteTransaction dbEnv $
-        Disk.withDbStateRWMaybeNull dbState $ \case
+        Disk.withDbSeqNoRWMaybeNull dbState $ \case
             Nothing ->
                 ltzipWith3A Disk.initLMDBTable dbBackingTables codecLedgerTables (projectLedgerTables state)
-                    $> ((), Disk.DbState{Disk.dbsSeq = pointSlot $ getTip state})
+                    $> ((), Disk.DbSeqNo{Disk.dbsSeq = pointSlot $ getTip state})
             Just _ -> liftIO $ throwIO $ Disk.LMDBErrInitialisingAlreadyHasState
 
 main :: IO ()

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -187,22 +188,20 @@ instance IsLedger (LedgerState ByronBlock) where
 type instance TxIn  (LedgerState ByronBlock) = Void
 type instance TxOut (LedgerState ByronBlock) = Void
 
-instance HasLedgerTables (LedgerState ByronBlock) where
-  projectLedgerTables = trivialProjectLedgerTables
-  withLedgerTables = trivialWithLedgerTables
-instance HasLedgerTables (Ticked1 (LedgerState ByronBlock)) where
-  projectLedgerTables = trivialProjectLedgerTables
-  withLedgerTables = trivialWithLedgerTables
-instance CanSerializeLedgerTables (LedgerState ByronBlock) where
-  codecLedgerTables = defaultCodecLedgerTables
-instance CanStowLedgerTables (LedgerState ByronBlock) where
-  stowLedgerTables = trivialStowLedgerTables
-  unstowLedgerTables = trivialUnstowLedgerTables
 instance LedgerTablesAreTrivial (LedgerState ByronBlock) where
   convertMapKind (ByronLedgerState x y z) = ByronLedgerState x y z
 instance LedgerTablesAreTrivial (Ticked1 (LedgerState ByronBlock)) where
   convertMapKind (TickedByronLedgerState x y) = TickedByronLedgerState x y
 
+deriving via TrivialLedgerTables (LedgerState ByronBlock)
+    instance HasLedgerTables (LedgerState ByronBlock)
+deriving via TrivialLedgerTables (Ticked1 (LedgerState ByronBlock))
+    instance HasLedgerTables (Ticked1 (LedgerState ByronBlock))
+deriving via TrivialLedgerTables (LedgerState ByronBlock)
+    instance CanSerializeLedgerTables (LedgerState ByronBlock)
+deriving via TrivialLedgerTables (LedgerState ByronBlock)
+    instance CanStowLedgerTables (LedgerState ByronBlock)
+
 {-------------------------------------------------------------------------------
   Supporting the various consensus interfaces
 -------------------------------------------------------------------------------}

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

@@ -1,3 +1,5 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -122,23 +124,20 @@ instance IsLedger (LedgerState ByronSpecBlock) where
 
 type instance TxIn  (LedgerState ByronSpecBlock) = Void
 type instance TxOut (LedgerState ByronSpecBlock) = Void
-instance HasLedgerTables (LedgerState ByronSpecBlock) where
-  projectLedgerTables = trivialProjectLedgerTables
-  withLedgerTables = trivialWithLedgerTables
-instance HasLedgerTables (Ticked1 (LedgerState ByronSpecBlock)) where
-  projectLedgerTables = trivialProjectLedgerTables
-  withLedgerTables = trivialWithLedgerTables
-instance CanSerializeLedgerTables (LedgerState ByronSpecBlock) where
-  codecLedgerTables = defaultCodecLedgerTables
 instance LedgerTablesAreTrivial (LedgerState ByronSpecBlock) where
   convertMapKind (ByronSpecLedgerState x y) =
       ByronSpecLedgerState x y
 instance LedgerTablesAreTrivial (Ticked1 (LedgerState ByronSpecBlock)) where
   convertMapKind (TickedByronSpecLedgerState x y) =
       TickedByronSpecLedgerState x y
-instance CanStowLedgerTables (LedgerState ByronSpecBlock) where
-  stowLedgerTables = trivialStowLedgerTables
-  unstowLedgerTables = trivialUnstowLedgerTables
+deriving via TrivialLedgerTables (LedgerState ByronSpecBlock)
+    instance HasLedgerTables (LedgerState ByronSpecBlock)
+deriving via TrivialLedgerTables (Ticked1 (LedgerState ByronSpecBlock))
+    instance HasLedgerTables (Ticked1 (LedgerState ByronSpecBlock))
+deriving via TrivialLedgerTables (LedgerState ByronSpecBlock)
+    instance CanSerializeLedgerTables (LedgerState ByronSpecBlock)
+deriving via TrivialLedgerTables (LedgerState ByronSpecBlock)
+    instance CanStowLedgerTables (LedgerState ByronSpecBlock)
 
 {-------------------------------------------------------------------------------
   Applying blocks

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/A.hs

@@ -201,21 +201,18 @@ newtype instance Ticked1 (LedgerState BlockA) mk = TickedLedgerStateA {
 type instance TxIn  (LedgerState BlockA) = Void
 type instance TxOut (LedgerState BlockA) = Void
 
-instance HasLedgerTables (LedgerState BlockA) where
-  projectLedgerTables = trivialProjectLedgerTables
-  withLedgerTables = trivialWithLedgerTables
-instance HasLedgerTables (Ticked1 (LedgerState BlockA)) where
-  projectLedgerTables = trivialProjectLedgerTables
-  withLedgerTables = trivialWithLedgerTables
-instance CanSerializeLedgerTables (LedgerState BlockA) where
-  codecLedgerTables = defaultCodecLedgerTables
-instance CanStowLedgerTables (LedgerState BlockA) where
-  stowLedgerTables = trivialStowLedgerTables
-  unstowLedgerTables = trivialUnstowLedgerTables
 instance LedgerTablesAreTrivial (LedgerState BlockA) where
   convertMapKind (LgrA x y) = LgrA x y
 instance LedgerTablesAreTrivial (Ticked1 (LedgerState BlockA)) where
   convertMapKind (TickedLedgerStateA x) = TickedLedgerStateA (convertMapKind x)
+deriving via TrivialLedgerTables (LedgerState BlockA)
+    instance HasLedgerTables (LedgerState BlockA)
+deriving via TrivialLedgerTables (Ticked1 (LedgerState BlockA))
+    instance HasLedgerTables (Ticked1 (LedgerState BlockA))
+deriving via TrivialLedgerTables (LedgerState BlockA)
+    instance CanSerializeLedgerTables (LedgerState BlockA)
+deriving via TrivialLedgerTables (LedgerState BlockA)
+    instance CanStowLedgerTables (LedgerState BlockA)
 
 data PartialLedgerConfigA = LCfgA {
       lcfgA_k           :: SecurityParam

ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/HardFork/Combinator/B.hs

@@ -175,22 +175,20 @@ data instance LedgerState BlockB mk = LgrB {
 type instance TxIn  (LedgerState BlockB) = Void
 type instance TxOut (LedgerState BlockB) = Void
 
-instance HasLedgerTables (LedgerState BlockB) where
-  projectLedgerTables = trivialProjectLedgerTables
-  withLedgerTables = trivialWithLedgerTables
-instance HasLedgerTables (Ticked1 (LedgerState BlockB)) where
-  projectLedgerTables = trivialProjectLedgerTables
-  withLedgerTables = trivialWithLedgerTables
-instance CanSerializeLedgerTables (LedgerState BlockB) where
-  codecLedgerTables = defaultCodecLedgerTables
-instance CanStowLedgerTables (LedgerState BlockB) where
-  stowLedgerTables = trivialStowLedgerTables
-  unstowLedgerTables = trivialUnstowLedgerTables
 instance LedgerTablesAreTrivial (LedgerState BlockB) where
   convertMapKind (LgrB x) = LgrB x
 instance LedgerTablesAreTrivial (Ticked1 (LedgerState BlockB)) where
   convertMapKind (TickedLedgerStateB x) = TickedLedgerStateB (convertMapKind x)
 
+deriving via TrivialLedgerTables (LedgerState BlockB)
+    instance HasLedgerTables (LedgerState BlockB)
+deriving via TrivialLedgerTables (Ticked1 (LedgerState BlockB))
+    instance HasLedgerTables (Ticked1 (LedgerState BlockB))
+deriving via TrivialLedgerTables (LedgerState BlockB)
+    instance CanSerializeLedgerTables (LedgerState BlockB)
+deriving via TrivialLedgerTables (LedgerState BlockB)
+    instance CanStowLedgerTables (LedgerState BlockB)
+
 type instance LedgerCfg (LedgerState BlockB) = ()
 
 -- | Ticking has no state on the B ledger state

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Ledger/Tables.hs

@@ -173,13 +173,9 @@ module Ouroboros.Consensus.Ledger.Tables (
     -- * Basic LedgerState classes
     -- ** Stowing ledger tables
   , CanStowLedgerTables (..)
-  , trivialStowLedgerTables
-  , trivialUnstowLedgerTables
     -- ** Extracting and injecting ledger tables
   , HasLedgerTables (..)
   , HasTickedLedgerTables
-  , trivialProjectLedgerTables
-  , trivialWithLedgerTables
     -- * Serialization
   , CanSerializeLedgerTables
   , codecLedgerTables
@@ -188,6 +184,7 @@ module Ouroboros.Consensus.Ledger.Tables (
   , valuesMKEncoder
     -- * Special classes
   , LedgerTablesAreTrivial
+  , TrivialLedgerTables(..)
   , convertMapKind
   , trivialLedgerTables
   ) where
@@ -197,7 +194,7 @@ import qualified Codec.CBOR.Decoding as CBOR
 import qualified Codec.CBOR.Encoding as CBOR
 import qualified Control.Exception as Exn
 import           Control.Monad (replicateM)
-import           Data.Kind (Constraint)
+import           Data.Kind (Constraint, Type)
 import qualified Data.Map.Strict as Map
 import           Data.Void (Void)
 import           NoThunks.Class (NoThunks (..))
@@ -246,19 +243,6 @@ class ( Ord (TxIn l)
     -> LedgerTables l mk
     -> l mk
 
-trivialProjectLedgerTables ::
-     (ZeroableMK mk, LedgerTablesAreTrivial l)
-  => l mk
-  -> LedgerTables l mk
-trivialProjectLedgerTables _ = trivialLedgerTables
-
-trivialWithLedgerTables ::
-     LedgerTablesAreTrivial l
-  => l any
-  -> LedgerTables l mk
-  -> l mk
-trivialWithLedgerTables st _ = convertMapKind st
-
 instance ( Ord (TxIn l)
          , Eq (TxOut l)
          , Show (TxIn l)
@@ -290,18 +274,6 @@ class CanStowLedgerTables l where
   stowLedgerTables     :: l ValuesMK -> l EmptyMK
   unstowLedgerTables   :: l EmptyMK  -> l ValuesMK
 
-trivialStowLedgerTables ::
-     (LedgerTablesAreTrivial l)
-  => l ValuesMK
-  -> l EmptyMK
-trivialStowLedgerTables = convertMapKind
-
-trivialUnstowLedgerTables ::
-     (LedgerTablesAreTrivial l)
-  => l EmptyMK
-  -> l ValuesMK
-trivialUnstowLedgerTables = convertMapKind
-
 {-------------------------------------------------------------------------------
   Serialization Codecs
 -------------------------------------------------------------------------------}
@@ -392,3 +364,25 @@ trivialLedgerTables ::
      (ZeroableMK mk, LedgerTablesAreTrivial l)
   => LedgerTables l mk
 trivialLedgerTables = LedgerTables emptyMK
+
+-- | A newtype to @derive via@ the instances for blocks with trivial ledger
+-- tables.
+type TrivialLedgerTables :: LedgerStateKind -> MapKind -> Type
+newtype TrivialLedgerTables l mk = TrivialLedgerTables { untrivialLedgerTables :: l mk }
+
+type instance TxIn  (TrivialLedgerTables l) = TxIn  l
+type instance TxOut (TrivialLedgerTables l) = TxOut l
+
+instance LedgerTablesAreTrivial l => LedgerTablesAreTrivial (TrivialLedgerTables l) where
+  convertMapKind = TrivialLedgerTables . convertMapKind . untrivialLedgerTables
+
+instance LedgerTablesAreTrivial l => HasLedgerTables (TrivialLedgerTables l) where
+  projectLedgerTables _ = trivialLedgerTables
+  withLedgerTables st _ = convertMapKind st
+
+instance LedgerTablesAreTrivial l => CanStowLedgerTables (TrivialLedgerTables l) where
+  stowLedgerTables = convertMapKind
+  unstowLedgerTables = convertMapKind
+
+instance LedgerTablesAreTrivial l => CanSerializeLedgerTables (TrivialLedgerTables l) where
+  codecLedgerTables = defaultCodecLedgerTables

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Impl/Common.hs

@@ -222,9 +222,8 @@ initMempoolEnv :: ( IOLike m
 initMempoolEnv ledgerInterface cfg capacityOverride tracer = do
     st <- atomically $ getCurrentLedgerState ledgerInterface
     let (slot, st') = tickLedgerState cfg (ForgeInUnknownSlot st)
-    isVar <-
-        newTMVarIO
-      $ initInternalState capacityOverride TxSeq.zeroTicketNo cfg slot st'
+    isVar <- newTMVarIO
+           $ initInternalState capacityOverride TxSeq.zeroTicketNo cfg slot st'
     addTxRemoteFifo <- newMVar ()
     addTxAllFifo    <- newMVar ()
     return MempoolEnv