Use MKs in Ledger.Query

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Compat.hs

@@ -24,6 +24,7 @@ import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.BlockchainTime
 import           Ouroboros.Consensus.HardFork.History.Summary (Bound, Summary,
                      initBound, neverForksSummary)
+import           Ouroboros.Consensus.Ledger.Query (FootprintL (..))
 import           Ouroboros.Consensus.Util.SOP
 
 import           Ouroboros.Consensus.HardFork.Abstract
@@ -38,41 +39,41 @@ import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry
 
 -- | Version of @Query (HardForkBlock xs)@ without the restriction to have
 -- at least two eras
-data HardForkCompatQuery blk :: Type -> Type where
+data HardForkCompatQuery blk :: FootprintL -> Type -> Type where
   CompatIfCurrent ::
-       BlockQuery blk result
-    -> HardForkCompatQuery blk result
+       BlockQuery          blk fp result
+    -> HardForkCompatQuery blk fp result
 
   CompatAnytime ::
-       QueryAnytime result
+       QueryAnytime            SmallL result
     -> EraIndex (HardForkIndices blk)
-    -> HardForkCompatQuery blk result
+    -> HardForkCompatQuery blk SmallL result
 
   CompatHardFork ::
-       QueryHardFork (HardForkIndices blk) result
-    -> HardForkCompatQuery blk result
+       QueryHardFork (HardForkIndices blk) SmallL result
+    -> HardForkCompatQuery blk             SmallL result
 
 {-------------------------------------------------------------------------------
   Convenience constructors for 'HardForkCompatQuery'
 -------------------------------------------------------------------------------}
 
 -- | Submit query to underlying ledger
 compatIfCurrent ::
-     BlockQuery blk result
-  -> HardForkCompatQuery blk result
+     BlockQuery          blk fp result
+  -> HardForkCompatQuery blk fp result
 compatIfCurrent = CompatIfCurrent
 
 -- | Get the start of the specified era, if known
 compatGetEraStart ::
      EraIndex (HardForkIndices blk)
-  -> HardForkCompatQuery blk (Maybe Bound)
+  -> HardForkCompatQuery blk SmallL (Maybe Bound)
 compatGetEraStart = CompatAnytime GetEraStart
 
 -- | Get an interpreter for history queries
 --
 -- I.e., this can be used for slot/epoch/time conversions.
 compatGetInterpreter ::
-    HardForkCompatQuery blk (Qry.Interpreter (HardForkIndices blk))
+    HardForkCompatQuery blk SmallL (Qry.Interpreter (HardForkIndices blk))
 compatGetInterpreter = CompatHardFork GetInterpreter
 
 {-------------------------------------------------------------------------------
@@ -83,12 +84,12 @@ compatGetInterpreter = CompatHardFork GetInterpreter
 -- at least two eras
 forwardCompatQuery ::
        forall m x xs. IsNonEmpty xs
-    => (forall result. BlockQuery (HardForkBlock (x ': xs)) result -> m result)
+    => (forall fp result. BlockQuery (HardForkBlock (x ': xs)) fp result -> m result)
     -- ^ Submit a query through the LocalStateQuery protocol.
-    -> (forall result. HardForkCompatQuery (HardForkBlock (x ': xs)) result -> m result)
+    -> (forall fp result. HardForkCompatQuery (HardForkBlock (x ': xs)) fp result -> m result)
 forwardCompatQuery f = go
   where
-    go :: HardForkCompatQuery (HardForkBlock (x ': xs)) result -> m result
+    go :: HardForkCompatQuery (HardForkBlock (x ': xs)) fp result -> m result
     go (CompatIfCurrent qry)    = f qry
     go (CompatAnytime   qry ix) = f (QueryAnytime qry ix)
     go (CompatHardFork  qry)    = f (QueryHardFork qry)
@@ -99,20 +100,20 @@ singleEraCompatQuery ::
        forall m blk era. (Monad m, HardForkIndices blk ~ '[era])
     => EpochSize
     -> SlotLength
-    -> (forall result. BlockQuery blk result -> m result)
+    -> (forall fp result. BlockQuery blk fp result -> m result)
     -- ^ Submit a query through the LocalStateQuery protocol.
-    -> (forall result. HardForkCompatQuery blk result -> m result)
+    -> (forall fp result. HardForkCompatQuery blk fp result -> m result)
 singleEraCompatQuery epochSize slotLen f = go
   where
-    go :: HardForkCompatQuery blk result -> m result
+    go :: HardForkCompatQuery blk fp result -> m result
     go (CompatIfCurrent qry)    = f qry
     go (CompatAnytime   qry ix) = const (goAnytime qry) (trivialIndex ix)
     go (CompatHardFork  qry)    = goHardFork qry
 
-    goAnytime :: QueryAnytime result -> m result
+    goAnytime :: QueryAnytime fp result -> m result
     goAnytime GetEraStart = return $ Just initBound
 
-    goHardFork :: QueryHardFork '[era] result -> m result
+    goHardFork :: QueryHardFork '[era] fp result -> m result
     goHardFork GetInterpreter = return $ Qry.mkInterpreter summary
     goHardFork GetCurrentEra  = return $ eraIndexZero
 

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Degenerate.hs

@@ -141,8 +141,8 @@ pattern DegenTipInfo x <- (project' (Proxy @(WrapTipInfo b)) -> x)
 pattern DegenQuery ::
      ()
   => HardForkQueryResult '[b] result ~ a
-  => BlockQuery b result
-  -> BlockQuery (HardForkBlock '[b]) a
+  => BlockQuery b fp result
+  -> BlockQuery (HardForkBlock '[b]) fp a
 pattern DegenQuery x <- (projQuery' -> ProjHardForkQuery x)
   where
     DegenQuery x = injQuery x

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Embed/Nary.hs

@@ -1,13 +1,12 @@
-{-# LANGUAGE DataKinds                #-}
-{-# LANGUAGE DisambiguateRecordFields #-}
-{-# LANGUAGE EmptyCase                #-}
-{-# LANGUAGE FlexibleContexts         #-}
-{-# LANGUAGE FlexibleInstances        #-}
-{-# LANGUAGE GADTs                    #-}
-{-# LANGUAGE RecordWildCards          #-}
-{-# LANGUAGE ScopedTypeVariables      #-}
-{-# LANGUAGE TypeApplications         #-}
-{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE EmptyCase           #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeOperators       #-}
 module Ouroboros.Consensus.HardFork.Combinator.Embed.Nary (
     Inject (..)
   , inject'
@@ -31,6 +30,7 @@ import           Ouroboros.Consensus.HeaderValidation (AnnTip, HeaderState (..),
                      genesisHeaderState)
 import           Ouroboros.Consensus.Ledger.Basics
 import           Ouroboros.Consensus.Ledger.Extended (ExtLedgerState (..))
+import           Ouroboros.Consensus.Ledger.Query
 import           Ouroboros.Consensus.Ledger.Tables.Utils
 import           Ouroboros.Consensus.Storage.Serialisation
 import           Ouroboros.Consensus.TypeFamilyWrappers
@@ -148,8 +148,8 @@ instance Inject WrapApplyTxErr where
       (WrapApplyTxErr . HardForkApplyTxErrFromEra)
         .: injectNS' (Proxy @WrapApplyTxErr)
 
-instance Inject (SomeSecond BlockQuery) where
-  inject _ idx (SomeSecond q) = SomeSecond (QueryIfCurrent (injectQuery idx q))
+instance Inject (Some2 :.: BlockQuery) where
+  inject _ idx (Comp (Some2 q)) = Comp $ Some2 $ QueryIfCurrent (injectQuery idx q)
 
 instance Inject AnnTip where
   inject _ = undistribAnnTip .: injectNS' (Proxy @AnnTip)

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Embed/Unary.hs

@@ -617,10 +617,10 @@ instance Isomorphic SerialisedHeader where
 -- | Project 'BlockQuery'
 --
 -- Not an instance of 'Isomorphic' because the types change.
-projQuery :: BlockQuery (HardForkBlock '[b]) result
+projQuery :: BlockQuery (HardForkBlock '[b]) fp result
           -> (forall result'.
                   (result :~: HardForkQueryResult '[b] result')
-               -> BlockQuery b result'
+               -> BlockQuery b fp result'
                -> a)
           -> a
 projQuery qry k =
@@ -630,24 +630,24 @@ projQuery qry k =
       (\Refl prfNonEmpty _ _ -> case prfNonEmpty of {})
       (\Refl prfNonEmpty _   -> case prfNonEmpty of {})
   where
-    aux :: QueryIfCurrent '[b] result -> BlockQuery b result
+    aux :: QueryIfCurrent '[b] fp result -> BlockQuery b fp result
     aux (QZ q) = q
     aux (QS q) = case q of {}
 
-projQuery' :: BlockQuery (HardForkBlock '[b]) result
-           -> ProjHardForkQuery b result
+projQuery' :: BlockQuery (HardForkBlock '[b]) fp result
+           -> ProjHardForkQuery b fp result
 projQuery' qry = projQuery qry $ \Refl -> ProjHardForkQuery
 
-data ProjHardForkQuery b :: Type -> Type where
+data ProjHardForkQuery b :: FootprintL -> Type -> Type where
   ProjHardForkQuery ::
-       BlockQuery b result'
-    -> ProjHardForkQuery b (HardForkQueryResult '[b] result')
+       BlockQuery b fp result'
+    -> ProjHardForkQuery b fp (HardForkQueryResult '[b] result')
 
 -- | Inject 'BlockQuery'
 --
 -- Not an instance of 'Isomorphic' because the types change.
-injQuery :: BlockQuery b result
-         -> BlockQuery (HardForkBlock '[b]) (HardForkQueryResult '[b] result)
+injQuery :: BlockQuery b fp result
+         -> BlockQuery (HardForkBlock '[b]) fp (HardForkQueryResult '[b] result)
 injQuery = QueryIfCurrent . QZ
 
 projQueryResult :: HardForkQueryResult '[b] result -> result