Turn Query into a GADT

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

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds               #-}
 {-# LANGUAGE FlexibleContexts        #-}
 {-# LANGUAGE TypeFamilies            #-}
+{-# LANGUAGE TypeOperators           #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 
 -- | Interface to the ledger layer
@@ -14,16 +15,20 @@ module Ouroboros.Consensus.Ledger.Abstract (
   , ProtocolLedgerView(..)
   , AnachronyFailure(..)
   , QueryLedger(..)
+  , ShowQuery(..)
   ) where
 
 import           Control.Monad.Except
+import           Data.Type.Equality ((:~:))
 import           GHC.Stack (HasCallStack)
 
 import           Cardano.Prelude (NoUnexpectedThunks)
 
 import           Ouroboros.Network.Block (ChainHash, HasHeader, Point, SlotNo,
                      pointHash, pointSlot)
 import           Ouroboros.Network.Point (WithOrigin)
+import           Ouroboros.Network.Protocol.LocalStateQuery.Type
+                     (ShowQuery (..))
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.Protocol.Abstract
@@ -174,15 +179,14 @@ data AnachronyFailure
 --
 -- Used by the LocalStateQuery protocol to allow clients to query the ledger
 -- state.
-class UpdateLedger blk => QueryLedger blk where
+class (UpdateLedger blk, ShowQuery (Query blk)) => QueryLedger blk where
 
-  -- | Different queries supported by the ledger
-  data family Query  blk :: *
-
-  -- | The result types for the queries
-  data family Result blk :: *
-  -- TODO index Result by Query so that we always get the expected result
-  -- type?
+  -- | Different queries supported by the ledger, indexed by the result type.
+  data family Query  blk :: * -> *
 
   -- | Answer the given query about the ledger state.
-  answerQuery :: Query blk -> LedgerState blk -> Result blk
+  answerQuery :: Query blk result -> LedgerState blk -> result
+
+  -- | Generalisation of value-level equality of two queries.
+  eqQuery :: Query blk result1 -> Query blk result2
+          -> Maybe (result1 :~: result2)

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

@@ -1,9 +1,11 @@
 {-# LANGUAGE DeriveAnyClass      #-}
 {-# LANGUAGE DeriveGeneric       #-}
 {-# LANGUAGE FlexibleInstances   #-}
-{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving  #-}
 {-# LANGUAGE TypeFamilies        #-}
 
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -14,7 +16,6 @@ module Ouroboros.Consensus.Ledger.Byron.Ledger (
     LedgerConfig(..)
   , LedgerState(..)
   , Query(..)
-  , Result(..)
   , initByronLedgerState
     -- * Serialisation
   , encodeByronLedgerState
@@ -36,6 +37,7 @@ import           Control.Monad.Except
 import           Data.ByteString (ByteString)
 import           Data.Sequence (Seq)
 import qualified Data.Sequence as Seq.Lazy
+import           Data.Type.Equality ((:~:) (Refl))
 import           GHC.Generics (Generic)
 
 import           Cardano.Prelude (NoUnexpectedThunks)
@@ -52,6 +54,7 @@ import qualified Cardano.Chain.ValidationMode as CC
 import           Ouroboros.Network.Block (Point (..), SlotNo (..), blockSlot)
 import           Ouroboros.Network.Point (WithOrigin (..))
 import qualified Ouroboros.Network.Point as Point
+import           Ouroboros.Network.Protocol.LocalStateQuery.Codec (Some (..))
 
 import           Ouroboros.Consensus.Ledger.Abstract
 import qualified Ouroboros.Consensus.Ledger.Byron.Auxiliary as Aux
@@ -125,16 +128,19 @@ initByronLedgerState genesis mUtxo = ByronLedgerState {
     override (Just utxo) st = st { CC.cvsUtxo = utxo }
 
 instance QueryLedger ByronBlock where
-  data Query ByronBlock
-    = GetUpdateInterfaceState
-    deriving (Eq, Show)
-
-  data Result ByronBlock
-    = UpdateInterfaceState UPI.State
-    deriving (Eq, Show)
+  data Query ByronBlock :: * -> * where
+    GetUpdateInterfaceState :: Query ByronBlock UPI.State
 
   answerQuery GetUpdateInterfaceState ledgerState =
-    UpdateInterfaceState (CC.cvsUpdateState (byronLedgerState ledgerState))
+    CC.cvsUpdateState (byronLedgerState ledgerState)
+
+  eqQuery GetUpdateInterfaceState GetUpdateInterfaceState = Just Refl
+
+deriving instance Eq (Query ByronBlock result)
+deriving instance Show (Query ByronBlock result)
+
+instance ShowQuery (Query ByronBlock) where
+  showResult GetUpdateInterfaceState = show
 
 instance ConfigContainsGenesis (LedgerConfig ByronBlock) where
   getGenesisConfig = unByronLedgerConfig
@@ -331,19 +337,22 @@ decodeByronLedgerState = do
       <$> decode
       <*> History.decodeDelegationHistory
 
-encodeByronQuery :: Query ByronBlock -> Encoding
+encodeByronQuery :: Query ByronBlock result -> Encoding
 encodeByronQuery query = case query of
     GetUpdateInterfaceState -> CBOR.encodeWord8 0
 
-decodeByronQuery :: Decoder s (Query ByronBlock)
+decodeByronQuery :: Decoder s (Some (Query ByronBlock))
 decodeByronQuery = do
     tag <- CBOR.decodeWord8
     case tag of
-      0 -> return GetUpdateInterfaceState
+      0 -> return $ Some GetUpdateInterfaceState
       _ -> fail $ "decodeByronQuery: invalid tag " <> show tag
 
-encodeByronResult :: Result ByronBlock -> Encoding
-encodeByronResult (UpdateInterfaceState state) = toCBOR state
+encodeByronResult :: Query ByronBlock result -> result -> Encoding
+encodeByronResult query = case query of
+    GetUpdateInterfaceState -> toCBOR
 
-decodeByronResult :: Decoder s (Result ByronBlock)
-decodeByronResult = UpdateInterfaceState <$> fromCBOR
+decodeByronResult :: Query ByronBlock result
+                  -> forall s. Decoder s result
+decodeByronResult query = case query of
+    GetUpdateInterfaceState -> fromCBOR

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

@@ -434,12 +434,14 @@ instance Bridge m a => ProtocolLedgerView (DualBlock m a) where
 
 -- | Not used in the tests: no constructors
 instance Bridge m a => QueryLedger (DualBlock m a) where
-  data Query (DualBlock m a)
-    deriving (Show)
-  data Result (DualBlock m a)
+  data Query (DualBlock m a) result
     deriving (Show)
 
-  answerQuery q _ledgerState = case q of {}
+  answerQuery = \case {}
+  eqQuery     = \case {}
+
+instance ShowQuery (Query (DualBlock m a)) where
+  showResult = \case {}
 
 {-------------------------------------------------------------------------------
   Mempool support

ouroboros-consensus/src/Ouroboros/Consensus/Ledger/Mock/Block.hs

@@ -2,9 +2,11 @@
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE EmptyCase                  #-}
+{-# LANGUAGE EmptyDataDeriving          #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE NamedFieldPuns             #-}
 {-# LANGUAGE RankNTypes                 #-}
@@ -38,9 +40,6 @@ module Ouroboros.Consensus.Ledger.Mock.Block (
     -- * 'ApplyTx' (mempool support)
   , GenTx(..)
   , mkSimpleGenTx
-    -- * 'QueryLedger'
-  , Query(..)
-  , Result(..)
     -- * Crypto
   , SimpleCrypto
   , SimpleStandardCrypto
@@ -334,13 +333,14 @@ mkSimpleGenTx tx = SimpleGenTx
 
 instance (SimpleCrypto c, Typeable ext, SupportedBlock (SimpleBlock c ext))
       => QueryLedger (SimpleBlock c ext) where
-  data Query  (SimpleBlock c ext) = QueryLedgerTip
-    deriving (Show, Generic, Serialise)
-  data Result (SimpleBlock c ext) = ResultLedgerTip (Point (SimpleBlock c ext))
-    deriving (Show, Generic, Serialise)
+  data Query (SimpleBlock c ext) result
+    deriving (Show)
+
+  answerQuery = \case {}
+  eqQuery     = \case {}
 
-  answerQuery QueryLedgerTip (SimpleLedgerState MockState { mockTip }) =
-    ResultLedgerTip mockTip
+instance ShowQuery (Query (SimpleBlock c ext)) where
+  showResult = \case {}
 
 {-------------------------------------------------------------------------------
   Crypto needed for simple blocks

ouroboros-consensus/src/Ouroboros/Consensus/LocalStateQueryServer.hs

@@ -24,13 +24,13 @@ import           Ouroboros.Storage.ChainDB (LedgerCursor (..),
 localStateQueryServer
   :: forall m blk. (IOLike m, QueryLedger blk)
   => m (LedgerCursor m blk)
-  -> LocalStateQueryServer blk (Query blk) (Result blk) m ()
+  -> LocalStateQueryServer blk (Query blk) m ()
 localStateQueryServer newLedgerCursor =
     LocalStateQueryServer $ idle <$> newLedgerCursor
   where
     idle
       :: LedgerCursor m blk
-      -> ServerStIdle blk (Query blk) (Result blk) m ()
+      -> ServerStIdle blk (Query blk) m ()
     idle ledgerCursor = ServerStIdle
       { recvMsgAcquire = handleAcquire ledgerCursor
       , recvMsgDone    = return ()
@@ -39,7 +39,7 @@ localStateQueryServer newLedgerCursor =
     handleAcquire
       :: LedgerCursor m blk
       -> Point blk
-      -> m (ServerStAcquiring blk (Query blk) (Result blk) m ())
+      -> m (ServerStAcquiring blk (Query blk) m ())
     handleAcquire ledgerCursor pt =
       ledgerCursorMove ledgerCursor pt <&> \case
         Left failure ->
@@ -50,7 +50,7 @@ localStateQueryServer newLedgerCursor =
     acquired
       :: LedgerState blk
       -> LedgerCursor m blk
-      -> ServerStAcquired blk (Query blk) (Result blk) m ()
+      -> ServerStAcquired blk (Query blk) m ()
     acquired ledgerState ledgerCursor = ServerStAcquired
       { recvMsgQuery     = handleQuery ledgerState ledgerCursor
       , recvMsgReAcquire = handleAcquire ledgerCursor
@@ -60,8 +60,8 @@ localStateQueryServer newLedgerCursor =
     handleQuery
       :: LedgerState blk
       -> LedgerCursor m blk
-      -> Query blk
-      -> m (ServerStQuerying blk (Query blk) (Result blk) m ())
+      -> Query blk result
+      -> m (ServerStQuerying blk (Query blk) m () result)
     handleQuery ledgerState ledgerCursor query = return $
       SendMsgResult
         (answerQuery query ledgerState)

ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Abstract.hs

@@ -21,6 +21,7 @@ import           Cardano.Crypto (ProtocolMagicId)
 import           Ouroboros.Network.Block (BlockNo, HeaderHash, SlotNo)
 import           Ouroboros.Network.BlockFetch (SizeInBytes)
 import           Ouroboros.Network.Magic (NetworkMagic)
+import           Ouroboros.Network.Protocol.LocalStateQuery.Codec (Some (..))
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.BlockchainTime (SystemStart)
@@ -128,8 +129,8 @@ class ( ProtocolLedgerView blk
   nodeEncodeLedgerState   :: NodeConfig (BlockProtocol blk) -> LedgerState blk -> Encoding
   nodeEncodeChainState    :: Proxy blk -> NodeConfig (BlockProtocol blk) -> ChainState (BlockProtocol blk) -> Encoding
   nodeEncodeApplyTxError  :: Proxy blk -> ApplyTxErr blk -> Encoding
-  nodeEncodeQuery         :: Query blk -> Encoding
-  nodeEncodeResult        :: Result blk -> Encoding
+  nodeEncodeQuery         :: Query blk result -> Encoding
+  nodeEncodeResult        :: Query blk result -> result -> Encoding
 
   -- Decoders
   nodeDecodeHeader        :: forall s. NodeConfig (BlockProtocol blk) -> Decoder s (Lazy.ByteString -> Header blk)
@@ -140,5 +141,5 @@ class ( ProtocolLedgerView blk
   nodeDecodeLedgerState   :: forall s. NodeConfig (BlockProtocol blk) -> Decoder s (LedgerState blk)
   nodeDecodeChainState    :: forall s. Proxy blk -> NodeConfig (BlockProtocol blk) -> Decoder s (ChainState (BlockProtocol blk))
   nodeDecodeApplyTxError  :: forall s. Proxy blk -> Decoder s (ApplyTxErr blk)
-  nodeDecodeQuery         :: forall s. Decoder s (Query blk)
-  nodeDecodeResult        :: forall s. Decoder s (Result blk)
+  nodeDecodeQuery         :: forall s. Decoder s (Some (Query blk))
+  nodeDecodeResult        :: Query blk result -> forall s. Decoder s result

ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/DualByron.hs

@@ -105,7 +105,7 @@ instance RunNode DualByronBlock where
                                let k = pbftSecurityParam $ pbftParams cfg
                                in decodeByronChainState k
   nodeDecodeQuery         = error "DualByron.nodeDecodeQuery"
-  nodeDecodeResult        = error "DualByron.nodeDecodeResult"
+  nodeDecodeResult        = \case {}
 
 extractEpochSlots :: NodeConfig DualByronProtocol -> EpochSlots
 extractEpochSlots = Byron.extractEpochSlots . dualNodeConfigMain

ouroboros-consensus/src/Ouroboros/Consensus/Node/Run/Mock.hs

@@ -1,5 +1,7 @@
+{-# LANGUAGE EmptyCase            #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
+{-# LANGUAGE LambdaCase           #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -64,8 +66,8 @@ instance ( ProtocolLedgerView (SimpleBlock SimpleMockCrypto ext)
   nodeEncodeLedgerState     = const encode
   nodeEncodeChainState      = const mockEncodeChainState
   nodeEncodeApplyTxError    = const encode
-  nodeEncodeQuery           = encode
-  nodeEncodeResult          = encode
+  nodeEncodeQuery           = \case {}
+  nodeEncodeResult          = \case {}
 
   nodeDecodeBlock           = const (const <$> decode)
   nodeDecodeHeader          = const (const <$> decode)
@@ -75,5 +77,5 @@ instance ( ProtocolLedgerView (SimpleBlock SimpleMockCrypto ext)
   nodeDecodeLedgerState     = const decode
   nodeDecodeChainState      = const mockDecodeChainState
   nodeDecodeApplyTxError    = const decode
-  nodeDecodeQuery           = decode
-  nodeDecodeResult          = decode
+  nodeDecodeQuery           = error "Mock.nodeDecodeQuery"
+  nodeDecodeResult          = \case {}

ouroboros-consensus/src/Ouroboros/Consensus/NodeNetwork.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes            #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
@@ -133,7 +134,7 @@ data ProtocolHandlers m peer blk = ProtocolHandlers {
         :: LocalTxSubmissionServer (GenTx blk) (ApplyTxErr blk) m ()
 
     , phLocalStateQueryServer
-        :: LocalStateQueryServer blk (Query blk) (Result blk) m ()
+        :: LocalStateQueryServer blk (Query blk) m ()
     }
 
 protocolHandlers
@@ -215,7 +216,7 @@ data ProtocolCodecs blk failure m
                                          failure m bytesLCS
   , pcLocalTxSubmissionCodec    :: Codec (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))
                                          failure m bytesLTX
-  , pcLocalStateQueryCodec      :: Codec (LocalStateQuery blk (Query blk) (Result blk))
+  , pcLocalStateQueryCodec      :: Codec (LocalStateQuery blk (Query blk))
                                          failure m bytesLSQ
   }
 
@@ -288,7 +289,7 @@ protocolCodecs cfg = ProtocolCodecs {
 
 -- | Id codecs used in tests.
 --
-protocolCodecsId :: Monad m
+protocolCodecsId :: (Monad m, QueryLedger blk)
                  => ProtocolCodecs blk CodecFailure m
                       (AnyMessage (ChainSync (Header blk) (Tip blk)))
                       (AnyMessage (ChainSync (Serialised (Header blk)) (Tip blk)))
@@ -297,7 +298,7 @@ protocolCodecsId :: Monad m
                       (AnyMessage (TxSubmission (GenTxId blk) (GenTx blk)))
                       (AnyMessage (ChainSync (Serialised blk) (Tip blk)))
                       (AnyMessage (LocalTxSubmission (GenTx blk) (ApplyTxErr blk)))
-                      (AnyMessage (LocalStateQuery blk (Query blk) (Result blk)))
+                      (AnyMessage (LocalStateQuery blk (Query blk)))
 protocolCodecsId = ProtocolCodecs {
       pcChainSyncCodec            = codecChainSyncId
     , pcChainSyncCodecSerialised  = codecChainSyncId
@@ -306,7 +307,7 @@ protocolCodecsId = ProtocolCodecs {
     , pcTxSubmissionCodec         = codecTxSubmissionId
     , pcLocalChainSyncCodec       = codecChainSyncId
     , pcLocalTxSubmissionCodec    = codecLocalTxSubmissionId
-    , pcLocalStateQueryCodec      = codecLocalStateQueryId
+    , pcLocalStateQueryCodec      = codecLocalStateQueryId eqQuery
     }
 
 -- | A record of 'Tracer's for the different protocols.
@@ -320,7 +321,7 @@ data ProtocolTracers' peer blk failure f = ProtocolTracers {
   , ptTxSubmissionTracer         :: f (TraceLabelPeer peer (TraceSendRecv (TxSubmission (GenTxId blk) (GenTx blk))))
   , ptLocalChainSyncTracer       :: f (TraceLabelPeer peer (TraceSendRecv (ChainSync (Serialised blk) (Tip blk))))
   , ptLocalTxSubmissionTracer    :: f (TraceLabelPeer peer (TraceSendRecv (LocalTxSubmission (GenTx blk) (ApplyTxErr blk))))
-  , ptLocalStateQueryTracer      :: f (TraceLabelPeer peer (TraceSendRecv (LocalStateQuery blk (Query blk) (Result blk))))
+  , ptLocalStateQueryTracer      :: f (TraceLabelPeer peer (TraceSendRecv (LocalStateQuery blk (Query blk))))
   }
 
 -- | Use a 'nullTracer' for each protocol.
@@ -342,8 +343,7 @@ showProtocolTracers :: ( Show blk
                        , Show (GenTx blk)
                        , Show (GenTxId blk)
                        , Show (ApplyTxErr blk)
-                       , Show (Query blk)
-                       , Show (Result blk)
+                       , ShowQuery (Query blk)
                        , HasHeader blk
                        )
                     => Tracer m String -> ProtocolTracers m peer blk failure