HFqueries

Author: jasagredo

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
@@ -95,6 +96,7 @@ import Ouroboros.Consensus.Ledger.SupportsProtocol
 import Ouroboros.Consensus.Ledger.Tables.Utils
 import Ouroboros.Consensus.Storage.LedgerDB
 import Ouroboros.Consensus.Util (ShowProxy (..))
+import Ouroboros.Consensus.Util.IndexedMemPack
 
 {-------------------------------------------------------------------------------
   LedgerState
@@ -199,19 +201,15 @@ instance IsLedger (LedgerState ByronBlock) where
             byronLedgerTransition
         }
 
--- type instance TxIn (LedgerState ByronBlock) = Void
 type instance TxOut ByronBlock = Void
 type instance TablesForBlock ByronBlock = '[]
 
--- 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
+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

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

@@ -1,24 +1,19 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilyDependencies #-}
+{-# LANGUAGE MonoLocalBinds #-}
 {-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE UndecidableSuperClasses #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module Ouroboros.Consensus.Cardano.QueryHF () where
 
+import Ouroboros.Consensus.Ledger.Tables.Utils
+import Lens.Micro ((.~), (&))
 import Data.Functor.Product
 import Data.SOP.BasicFunctors
 import Data.SOP.Constraint
@@ -91,12 +86,15 @@ shelleyCardanoFilter ::
   Bool
 shelleyCardanoFilter q = eliminateCardanoTxOut (\_ -> shelleyQFTraverseTablesPredicate q)
 
-instance CardanoHardForkConstraints c => BlockSupportsHFLedgerQuery (CardanoEras c) where
+instance
+  CardanoHardForkConstraints c =>
+  BlockSupportsHFLedgerQuery (CardanoEras c)
+  where
   answerBlockQueryHFLookup =
     answerCardanoQueryHF
       ( \idx ->
           answerShelleyLookupQueries
-            (undefined ) -- injectLedgerTables idx)
+            castKeys
             (ejectHardForkTxOut idx)
       )
   answerBlockQueryHFTraverse =
@@ -120,6 +118,12 @@ instance CardanoHardForkConstraints c => BlockSupportsHFLedgerQuery (CardanoEras
     IS (IS (IS (IS (IS (IS (IS IZ)))))) -> shelleyCardanoFilter q
     IS (IS (IS (IS (IS (IS (IS (IS idx'))))))) -> case idx' of {}
 
+castKeys :: forall blk blk'. (SListI (TablesForBlock blk), SingI (TablesForBlock blk), LedgerTablesConstraints blk') => LedgerTables blk KeysMK -> LedgerTables blk' KeysMK
+castKeys np =
+  emptyLedgerTables
+    & onUTxOTable (Proxy @blk') .~ maybe (Table (KeysMK mempty)) (\(Table (KeysMK km)) -> Table (KeysMK km)) (getTableByTag (sing @UTxOTable) np)
+    & onInstantStakeTable (Proxy @blk') .~ maybe (Table (KeysMK mempty)) (\(Table (KeysMK km)) -> Table (KeysMK km)) (getTableByTag (sing @InstantStakeTable) np)
+
 byronCardanoFilter ::
   BlockQuery ByronBlock QFTraverseTables result ->
   TxOut (HardForkBlock (CardanoEras c)) ->

ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Protocol/PBFT.hs

@@ -1,16 +1,14 @@
+{-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeFamilyDependencies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 #if __GLASGOW_HASKELL__ >= 908