From e0f552d2221b7564d1cecbd6ace4108b84b81c8f Mon Sep 17 00:00:00 2001
From: Nicolas Frisby <nick.frisby@iohk.io>
Date: Mon, 9 Dec 2024 14:20:14 -0800
Subject: [PATCH] consensus: abstact some query logic over UTxO HD footprints

---
 .../HardFork/Combinator/Ledger/Query.hs       | 59 +++++++++----------
 1 file changed, 28 insertions(+), 31 deletions(-)

diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs
index 1f463b9b8d..0875c53e6d 100644
--- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs
+++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Ledger/Query.hs
@@ -227,37 +227,34 @@ instance ( All SingleEraBlock xs
       lcfg = configLedger cfg
       ei   = State.epochInfoLedger lcfg hardForkState
 
-  answerBlockQueryLookup
-    (ExtLedgerCfg cfg)
-    qry
-    forker = do
-      hardForkState <- hardForkLedgerStatePerEra . ledgerState <$> atomically (roforkerGetLedgerState forker)
-      let ei   = State.epochInfoLedger lcfg hardForkState
-          cfgs = hmap ExtLedgerCfg $ distribTopLevelConfig ei cfg
-      case qry of
-        QueryIfCurrent queryIfCurrent ->
-          interpretQueryIfCurrentLookup
-                cfgs
-                queryIfCurrent
-                forker
-    where
-      lcfg = configLedger cfg
-
-  answerBlockQueryTraverse
-    (ExtLedgerCfg cfg)
-    qry
-    forker = do
-      hardForkState <- hardForkLedgerStatePerEra . ledgerState <$> atomically (roforkerGetLedgerState forker)
-      let ei   = State.epochInfoLedger lcfg hardForkState
-          cfgs = hmap ExtLedgerCfg $ distribTopLevelConfig ei cfg
-      case qry of
-        QueryIfCurrent queryIfCurrent ->
-          interpretQueryIfCurrentTraverse
-                cfgs
-                queryIfCurrent
-                forker
-    where
-      lcfg = configLedger cfg
+  answerBlockQueryLookup   cfg (QueryIfCurrent q) =
+      answerBlockQueryHelper interpretQueryIfCurrentLookup   cfg q
+  answerBlockQueryTraverse cfg (QueryIfCurrent q) =
+      answerBlockQueryHelper interpretQueryIfCurrentTraverse cfg q
+
+-- | NOT EXPORTED, for footprints other than 'QFNoTables'
+answerBlockQueryHelper ::
+       (MonadSTM m, BlockSupportsHFLedgerQuery xs, CanHardFork xs)
+    => (   NP ExtLedgerCfg xs
+        -> QueryIfCurrent xs footprint result
+        -> ReadOnlyForker' m (HardForkBlock xs)
+        -> m (HardForkQueryResult xs result)
+       )
+    -> ExtLedgerCfg (HardForkBlock xs)
+    -> QueryIfCurrent xs footprint result
+    -> ReadOnlyForker' m (HardForkBlock xs)
+    -> m (HardForkQueryResult xs result)
+answerBlockQueryHelper
+  f
+  (ExtLedgerCfg cfg)
+  qry
+  forker = do
+    hardForkState <- hardForkLedgerStatePerEra . ledgerState <$> atomically (roforkerGetLedgerState forker)
+    let ei   = State.epochInfoLedger lcfg hardForkState
+        cfgs = hmap ExtLedgerCfg $ distribTopLevelConfig ei cfg
+    f cfgs qry forker
+  where
+    lcfg = configLedger cfg
 
 -- | Precondition: the 'ledgerState' and 'headerState' should be from the same
 -- era. In practice, this is _always_ the case, unless the 'ExtLedgerState' was