WIP: Js/multiple tables

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

@@ -179,6 +179,40 @@ library
     validation,
     vector-map,
 
+library snapshot-conversion
+  import: common-lib
+  visibility: public
+  hs-source-dirs: src/snapshot-conversion
+  other-modules:
+    Ouroboros.Consensus.Cardano.StreamingLedgerTables
+
+  exposed-modules:
+    Ouroboros.Consensus.Cardano.SnapshotConversion
+
+  build-depends:
+    ansi-terminal,
+    base,
+    cardano-ledger-binary,
+    cardano-ledger-core,
+    cardano-ledger-shelley,
+    cborg,
+    directory,
+    filepath,
+    fs-api,
+    microlens,
+    mtl,
+    optparse-applicative,
+    ouroboros-consensus:{ouroboros-consensus, ouroboros-consensus-lmdb, ouroboros-consensus-lsm},
+    ouroboros-consensus-cardano,
+    random,
+    resource-registry,
+    serialise,
+    sop-core,
+    sop-extras,
+    strict-sop-core,
+    terminal-progress-bar,
+    text,
+
 library unstable-byronspec
   import: common-lib
   visibility: public
@@ -695,35 +729,14 @@ executable immdb-server
 executable snapshot-converter
   import: common-exe
   hs-source-dirs: app
-  other-modules:
-    Ouroboros.Consensus.Cardano.StreamingLedgerTables
-
   main-is: snapshot-converter.hs
   build-depends:
-    ansi-terminal,
     base,
     cardano-crypto-class,
-    cardano-ledger-binary,
-    cardano-ledger-core,
-    cardano-ledger-shelley,
-    cborg,
-    directory,
-    filepath,
-    fs-api,
-    microlens,
     mtl,
     optparse-applicative,
-    ouroboros-consensus:{ouroboros-consensus, ouroboros-consensus-lmdb, ouroboros-consensus-lsm},
-    ouroboros-consensus-cardano,
-    ouroboros-consensus-cardano:unstable-cardano-tools,
-    random,
-    resource-registry,
-    serialise,
-    sop-core,
-    sop-extras,
-    strict-sop-core,
-    terminal-progress-bar,
-    text,
+    ouroboros-consensus,
+    ouroboros-consensus-cardano:{ouroboros-consensus-cardano, snapshot-conversion, unstable-cardano-tools},
     with-utf8,
 
   other-modules:

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

@@ -3,14 +3,14 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE EmptyCase #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Ouroboros.Consensus.Byron.ByronHFC
@@ -25,9 +25,10 @@ import qualified Cardano.Chain.Update as CC.Update
 import Control.Monad
 import qualified Data.Map.Strict as Map
 import Data.Maybe (listToMaybe, mapMaybe)
-import Data.MemPack
+import Data.SOP.Constraint
 import Data.SOP.Index (Index (..))
-import Data.Void (Void, absurd)
+import qualified Data.Singletons as S
+import Data.Void (Void)
 import Data.Word
 import GHC.Generics
 import NoThunks.Class
@@ -46,7 +47,6 @@ import Ouroboros.Consensus.Node.NetworkProtocolVersion
 import Ouroboros.Consensus.Node.Serialisation
 import Ouroboros.Consensus.Protocol.PBFT (PBft, PBftCrypto)
 import Ouroboros.Consensus.Storage.Serialisation
-import Ouroboros.Consensus.Util.IndexedMemPack
 
 {-------------------------------------------------------------------------------
   Synonym for convenience
@@ -287,30 +287,19 @@ instance SerialiseNodeToClient ByronBlock ByronPartialLedgerConfig where
   Canonical TxIn
 -------------------------------------------------------------------------------}
 
-instance HasCanonicalTxIn '[ByronBlock] where
-  newtype CanonicalTxIn '[ByronBlock] = ByronHFCTxIn
-    { getByronHFCTxIn :: Void
-    }
-    deriving stock (Show, Eq, Ord)
-    deriving newtype (NoThunks, MemPack)
-
-  injectCanonicalTxIn IZ key = absurd key
-  injectCanonicalTxIn (IS idx') _ = case idx' of {}
-
-  ejectCanonicalTxIn _ key = absurd $ getByronHFCTxIn key
-
-instance HasHardForkTxOut '[ByronBlock] where
+instance
+  ( All (TableConstraints (HardForkBlock '[ByronBlock])) (TablesForBlock (HardForkBlock '[ByronBlock]))
+  , S.SingI
+      (TablesForBlock (HardForkBlock '[ByronBlock]))
+  ) =>
+  HasHardForkTxOut '[ByronBlock]
+  where
   type HardForkTxOut '[ByronBlock] = Void
-  injectHardForkTxOut IZ txout = absurd txout
+  injectHardForkTxOut IZ txout = txout
   injectHardForkTxOut (IS idx') _ = case idx' of {}
-  ejectHardForkTxOut IZ txout = absurd txout
+  ejectHardForkTxOut IZ txout = txout
   ejectHardForkTxOut (IS idx') _ = case idx' of {}
 
-deriving via
-  Void
-  instance
-    IndexedMemPack (LedgerState (HardForkBlock '[ByronBlock]) EmptyMK) Void
-
 instance BlockSupportsHFLedgerQuery '[ByronBlock] where
   answerBlockQueryHFLookup IZ _cfg (q :: BlockQuery ByronBlock QFLookupTables result) _dlv = case q of {}
   answerBlockQueryHFLookup (IS is) _cfg _q _dlv = case is of {}
@@ -320,8 +309,3 @@ instance BlockSupportsHFLedgerQuery '[ByronBlock] where
 
   queryLedgerGetTraversingFilter IZ (q :: BlockQuery ByronBlock QFTraverseTables result) = case q of {}
   queryLedgerGetTraversingFilter (IS is) _q = case is of {}
-
-deriving via
-  TrivialLedgerTables (LedgerState (HardForkBlock '[ByronBlock]))
-  instance
-    SerializeTablesWithHint (LedgerState (HardForkBlock '[ByronBlock]))

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

@@ -15,6 +15,7 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE TypeApplications #-}
 
 -- | Instances requires for consensus/ledger integration
 module Ouroboros.Consensus.Byron.Ledger.Ledger
@@ -70,7 +71,8 @@ import qualified Control.State.Transition.Extended as STS
 import Data.ByteString (ByteString)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
-import Data.Void (Void)
+import Data.SOP.Strict
+import Data.Void
 import GHC.Generics (Generic)
 import NoThunks.Class (NoThunks)
 import Ouroboros.Consensus.Block
@@ -87,6 +89,7 @@ import Ouroboros.Consensus.HeaderValidation
 import Ouroboros.Consensus.Ledger.Abstract
 import Ouroboros.Consensus.Ledger.CommonProtocolParams
 import Ouroboros.Consensus.Ledger.Extended
+import Ouroboros.Consensus.Ledger.LedgerStateType
 import Ouroboros.Consensus.Ledger.Query
 import Ouroboros.Consensus.Ledger.SupportsPeerSelection
 import Ouroboros.Consensus.Ledger.SupportsProtocol
@@ -123,8 +126,6 @@ data ByronTransition
     ByronTransitionInfo !(Map Update.ProtocolVersion BlockNo)
   deriving (Eq, Show, Generic, NoThunks)
 
-instance UpdateLedger ByronBlock
-
 type instance LedgerCfg (LedgerState ByronBlock) = Gen.Config
 
 initByronLedgerState ::
@@ -200,46 +201,39 @@ instance IsLedger (LedgerState ByronBlock) where
             byronLedgerTransition
         }
 
-type instance TxIn (LedgerState ByronBlock) = Void
-type instance TxOut (LedgerState ByronBlock) = Void
-
-instance LedgerTablesAreTrivial (LedgerState ByronBlock) where
-  convertMapKind (ByronLedgerState x y z) = ByronLedgerState x y z
-instance LedgerTablesAreTrivial (Ticked (LedgerState ByronBlock)) where
-  convertMapKind (TickedByronLedgerState x y) = TickedByronLedgerState x y
-
-deriving via
-  Void
-  instance
-    IndexedMemPack (LedgerState ByronBlock EmptyMK) Void
-
-deriving via
-  TrivialLedgerTables (LedgerState ByronBlock)
-  instance
-    HasLedgerTables (LedgerState ByronBlock)
-deriving via
-  TrivialLedgerTables (Ticked (LedgerState ByronBlock))
-  instance
-    HasLedgerTables (Ticked (LedgerState ByronBlock))
-deriving via
-  TrivialLedgerTables (LedgerState ByronBlock)
-  instance
-    CanStowLedgerTables (LedgerState ByronBlock)
-deriving via
-  TrivialLedgerTables (LedgerState ByronBlock)
-  instance
-    SerializeTablesWithHint (LedgerState ByronBlock)
+type instance TxOut ByronBlock = Void
+type instance TablesForBlock ByronBlock = '[]
+
+instance IndexedMemPack LedgerState ByronBlock UTxOTable where
+  type IndexedValue LedgerState UTxOTable ByronBlock  = Value UTxOTable ByronBlock
+  indexedPackM _ _ _ _ = absurd
+  indexedUnpackM _ _ _ _ = error "absurd"
+  indexedPackedByteCount _ _ _ _ = absurd
+  indexedTypeName _ _ _ = typeName @Void
+
+instance HasLedgerTables LedgerState ByronBlock where
+  projectLedgerTables _ = LedgerTables Nil
+  withLedgerTables ByronLedgerState{..} _ = ByronLedgerState{..}
+
+instance HasLedgerTables (TickedL LedgerState) ByronBlock where
+  projectLedgerTables _ = LedgerTables Nil
+  withLedgerTables (TickedL TickedByronLedgerState{..}) _ = TickedL TickedByronLedgerState{..}
+
+instance CanStowLedgerTables (LedgerState ByronBlock) where
+  stowLedgerTables ByronLedgerState{..} = ByronLedgerState{..}
+  unstowLedgerTables ByronLedgerState{..} = ByronLedgerState{..}
 
 {-------------------------------------------------------------------------------
   Supporting the various consensus interfaces
 -------------------------------------------------------------------------------}
 
-instance ApplyBlock (LedgerState ByronBlock) ByronBlock where
+instance ApplyBlock LedgerState ByronBlock where
   applyBlockLedgerResultWithValidation doValidation opts =
     fmap pureLedgerResult ..: applyByronBlock doValidation opts
   applyBlockLedgerResult = defaultApplyBlockLedgerResult
   reapplyBlockLedgerResult = defaultReapplyBlockLedgerResult validationErrorImpossible
 
+instance GetBlockKeySets ByronBlock where
   getBlockKeySets _ = emptyLedgerTables
 
 data instance BlockQuery ByronBlock fp result where
@@ -575,5 +569,5 @@ decodeByronResult ::
 decodeByronResult query = case query of
   GetUpdateInterfaceState -> fromByronCBOR
 
-instance CanUpgradeLedgerTables (LedgerState ByronBlock) where
+instance CanUpgradeLedgerTables LedgerState ByronBlock where
   upgradeTables _ _ = id

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

@@ -1,6 +1,8 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -59,7 +61,7 @@ import Ouroboros.Consensus.Protocol.PBFT
 import qualified Ouroboros.Consensus.Protocol.PBFT.State as S
 import Ouroboros.Consensus.Storage.ChainDB.Init (InitChainDB (..))
 import Ouroboros.Consensus.Storage.ImmutableDB (simpleChunkInfo)
-import Ouroboros.Consensus.Util ((....:))
+import Ouroboros.Consensus.Util
 import Ouroboros.Network.Magic (NetworkMagic (..))
 
 {-------------------------------------------------------------------------------