Introduce queries about an era that can be answered in any era

Fixes #2346.

* Split `HardForkQuery` up into:
  1. `QueryIfCurrent`: queries about a certain era that only can be answered
     when the current ledger is in the respective era.
  2. `QueryAnytime`: queries about a certain era that can be answered when the
     current ledger is in *any* era. No queries about the first era can be
     asked to keep the HFC with a single ledger isomorphic to just the ledger.

     An example query is `EraStart`, which returns the start epoch/time/slot
     of an era.

* The pattern synonyms for `CardanoQuery` were renamed from `QueryByron` and
  `QueryShelley` to `QueryIfCurrentByron`, `QueryIfCurrentShelley`, and
  `QueryAnytimeShelley`.

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

@@ -44,7 +44,7 @@ module Ouroboros.Consensus.Cardano.Block (
   , OneEraTipInfo (TipInfoByron, TipInfoShelley)
     -- * Query
   , CardanoQuery
-  , Query (QueryByron, QueryShelley)
+  , Query (QueryIfCurrentByron, QueryIfCurrentShelley, QueryAnytimeShelley)
   , CardanoQueryResult
   , Either (QueryResultSuccess, QueryResultEraMismatch)
     -- * CodecConfig
@@ -296,20 +296,40 @@ pattern TipInfoShelley ti = OneEraTipInfo (S (Z (WrapTipInfo ti)))
 -- | The 'Query' of Cardano chain.
 --
 -- Thanks to the pattern synonyms, you can treat this as a sum type with
--- constructors 'QueryByron' and 'QueryShelley'.
+-- constructors 'QueryIfCurrentByron', 'QueryIfCurerntShelley', and
+-- 'QueryAnytimeShelley'.
 type CardanoQuery sc = Query (CardanoBlock sc)
 
-pattern QueryByron
+-- | Byron-specific query that can only be answered when the ledger in the
+-- Byron era.
+pattern QueryIfCurrentByron
   :: Query ByronBlock result
   -> CardanoQuery sc (CardanoQueryResult sc result)
-pattern QueryByron q = HardForkQuery (QZ q)
+pattern QueryIfCurrentByron q = QueryIfCurrent (QZ q)
 
-pattern QueryShelley
+-- | Shelley-specific query that can only be answered when the ledger in the
+-- Shelley era.
+pattern QueryIfCurrentShelley
   :: Query (ShelleyBlock sc) result
   -> CardanoQuery sc (CardanoQueryResult sc result)
-pattern QueryShelley q = HardForkQuery (QS (QZ q))
+pattern QueryIfCurrentShelley q = QueryIfCurrent (QS (QZ q))
 
-{-# COMPLETE QueryByron, QueryShelley #-}
+-- | Query about the Shelley era that can be answered anytime, i.e.,
+-- independent from where the tip of the ledger is.
+--
+-- For example, to ask for the start of the Shelley era (whether the tip of
+-- the ledger is in the Byron or Shelley era), use:
+--
+-- > QueryAnytimeShelley EraStart
+--
+pattern QueryAnytimeShelley
+  :: QueryAnytime result
+  -> CardanoQuery sc result
+pattern QueryAnytimeShelley q = QueryAnytime q (EraIndex (Z (K ())))
+
+{-# COMPLETE QueryIfCurrentByron
+           , QueryIfCurrentShelley
+           , QueryAnytimeShelley #-}
 
 -- | The result of a 'CardanoQuery'
 --

ouroboros-consensus-cardano/test/Test/Consensus/Cardano/Generators.hs

@@ -25,6 +25,7 @@ import           Ouroboros.Consensus.BlockchainTime (RelativeTime (..))
 import           Ouroboros.Consensus.HardFork.History (Bound (..))
 import           Ouroboros.Consensus.HeaderValidation
 import           Ouroboros.Consensus.Node.NetworkProtocolVersion
+import           Ouroboros.Consensus.Node.Serialisation (Some (..))
 import           Ouroboros.Consensus.Protocol.Abstract
 import           Ouroboros.Consensus.TypeFamilyWrappers
 
@@ -275,40 +276,53 @@ instance (sc ~ TPraosMockCrypto h, HashAlgorithm h, forall a. Arbitrary (Hash h
               <$> arbitrary)
       ]
 
+instance Arbitrary (Some QueryAnytime) where
+  arbitrary = return $ Some EraStart
+
 instance (sc ~ TPraosMockCrypto h, HashAlgorithm h)
       => Arbitrary (WithVersion (HardForkNodeToClientVersion (CardanoEras sc))
                                 (SomeBlock Query (CardanoBlock sc))) where
-  arbitrary = arbitraryNodeToClient injByron injShelley
+  arbitrary = frequency
+      [ (9, arbitraryNodeToClient injByron injShelley)
+      , (1, WithVersion (mostRecentSupportedNodeToClient pc) . injAnytimeShelley
+              <$> arbitrary)
+      ]
     where
-      injByron   (SomeBlock query) = SomeBlock (QueryByron   query)
-      injShelley (SomeBlock query) = SomeBlock (QueryShelley query)
+      injByron          (SomeBlock query) = SomeBlock (QueryIfCurrentByron   query)
+      injShelley        (SomeBlock query) = SomeBlock (QueryIfCurrentShelley query)
+      injAnytimeShelley (Some      query) = SomeBlock (QueryAnytimeShelley   query)
 
 instance (sc ~ TPraosMockCrypto h, HashAlgorithm h)
       => Arbitrary (WithVersion (HardForkNodeToClientVersion (CardanoEras sc))
                                 (SomeResult (CardanoBlock sc))) where
   arbitrary = frequency
       [ (8, arbitraryNodeToClient injByron injShelley)
-      , (2, WithVersion (mostRecentSupportedNodeToClient pc) <$> genQueryResultEraMismatch)
+      , (2, WithVersion (mostRecentSupportedNodeToClient pc) <$> genQueryIfCurrentResultEraMismatch)
+      , (1, WithVersion (mostRecentSupportedNodeToClient pc) <$> genQueryAnytimeResult)
       ]
     where
-      injByron   (SomeResult q r) = SomeResult (QueryByron   q) (QueryResultSuccess r)
-      injShelley (SomeResult q r) = SomeResult (QueryShelley q) (QueryResultSuccess r)
+      injByron   (SomeResult q r) = SomeResult (QueryIfCurrentByron   q) (QueryResultSuccess r)
+      injShelley (SomeResult q r) = SomeResult (QueryIfCurrentShelley q) (QueryResultSuccess r)
 
       -- In practice, when sending a Byron query you'll never get a mismatch
       -- saying that your query is from the Shelley era while the ledger is
       -- from Byron. Only the inverse. We ignore that in this generator, as it
       -- doesn't matter for serialisation purposes, we just generate a random
       -- 'MismatchEraInfo'.
-      genQueryResultEraMismatch :: Gen (SomeResult (CardanoBlock sc))
-      genQueryResultEraMismatch = oneof
+      genQueryIfCurrentResultEraMismatch :: Gen (SomeResult (CardanoBlock sc))
+      genQueryIfCurrentResultEraMismatch = oneof
           [ (\(SomeResult q (_ :: result)) mismatch ->
-                SomeResult (QueryByron q) (Left @_ @result mismatch))
+                SomeResult (QueryIfCurrentByron q) (Left @_ @result mismatch))
               <$> arbitrary <*> arbitrary
           , (\(SomeResult q (_ :: result)) mismatch ->
-                SomeResult (QueryShelley q) (Left @_ @result mismatch))
+                SomeResult (QueryIfCurrentShelley q) (Left @_ @result mismatch))
               <$> arbitrary <*> arbitrary
           ]
 
+      genQueryAnytimeResult :: Gen (SomeResult (CardanoBlock sc))
+      genQueryAnytimeResult =
+          SomeResult (QueryAnytimeShelley EraStart) <$> arbitrary
+
 instance (sc ~ TPraosMockCrypto h, HashAlgorithm h)
       => Arbitrary (MismatchEraInfo (CardanoEras sc)) where
   arbitrary = MismatchEraInfo <$> elements

ouroboros-consensus/src/Ouroboros/Consensus/HardFork/Combinator/Abstract/SingleEraBlock.hs

@@ -1,12 +1,27 @@
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE EmptyCase            #-}
+{-# LANGUAGE FlexibleContexts     #-}
+{-# LANGUAGE ScopedTypeVariables  #-}
+{-# LANGUAGE TypeApplications     #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock (
+    -- * Single era block
     SingleEraBlock(..)
   , singleEraTransition'
   , proxySingle
+    -- * Era index
+  , EraIndex(..)
+  , emptyEraIndex
   ) where
 
+import           Codec.Serialise
+import           Data.Either (isRight)
 import           Data.Proxy
+import           Data.SOP.BasicFunctors (K (..))
+import           Data.SOP.Strict
+import qualified Data.Text as Text
+import           Data.Void
 
 import           Ouroboros.Consensus.Block
 import           Ouroboros.Consensus.HardFork.History (Bound, EraParams)
@@ -15,9 +30,11 @@ import           Ouroboros.Consensus.Ledger.CommonProtocolParams
 import           Ouroboros.Consensus.Ledger.SupportsMempool
 import           Ouroboros.Consensus.Ledger.SupportsProtocol
 import           Ouroboros.Consensus.Storage.ChainDB.Serialisation
+import           Ouroboros.Consensus.Util.SOP
 
 import           Ouroboros.Consensus.HardFork.Combinator.Info
 import           Ouroboros.Consensus.HardFork.Combinator.PartialConfig
+import           Ouroboros.Consensus.HardFork.Combinator.Util.Match
 
 {-------------------------------------------------------------------------------
   SingleEraBlock
@@ -67,3 +84,37 @@ singleEraTransition' :: SingleEraBlock blk
                      -> Bound
                      -> LedgerState blk -> Maybe EpochNo
 singleEraTransition' = singleEraTransition . unwrapPartialLedgerConfig
+
+{-------------------------------------------------------------------------------
+  Era index
+-------------------------------------------------------------------------------}
+
+newtype EraIndex xs = EraIndex {
+      getEraIndex :: NS (K ()) xs
+    }
+
+instance Eq (EraIndex xs) where
+  EraIndex era == EraIndex era' = isRight (matchNS era era')
+
+instance All SingleEraBlock xs => Show (EraIndex xs) where
+  show = hcollapse . hcmap proxySingle getEraName . getEraIndex
+    where
+      getEraName :: forall blk. SingleEraBlock blk
+                 => K () blk -> K String blk
+      getEraName _ =
+            K
+          . ("EraIndex " <>)
+          . Text.unpack
+          . singleEraName
+          $ singleEraInfo (Proxy @blk)
+
+instance SListI xs => Serialise (EraIndex xs) where
+  encode = encode . nsToIndex . getEraIndex
+  decode = do
+    idx <- decode
+    case nsFromIndex idx of
+      Nothing       -> fail $ "EraIndex: invalid index " <> show idx
+      Just eraIndex -> return (EraIndex eraIndex)
+
+emptyEraIndex :: EraIndex '[] -> Void
+emptyEraIndex (EraIndex ns) = case ns of {}

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

@@ -291,8 +291,8 @@ deriving via LiftNP WrapExtraForgeState xs instance CanHardFork xs => Show (PerE
 
 deriving via LiftNS WrapApplyTxErr      xs instance CanHardFork xs => Eq   (OneEraApplyTxErr xs)
 
-deriving via LiftMismatch SingleEraInfo LedgerEraInfo xs instance CanHardFork xs => Eq   (MismatchEraInfo xs)
-deriving via LiftMismatch SingleEraInfo LedgerEraInfo xs instance CanHardFork xs => Show (MismatchEraInfo xs)
+deriving via LiftMismatch SingleEraInfo LedgerEraInfo xs instance All SingleEraBlock xs => Eq   (MismatchEraInfo xs)
+deriving via LiftMismatch SingleEraInfo LedgerEraInfo xs instance All SingleEraBlock xs => Show (MismatchEraInfo xs)
 
 deriving newtype instance All (Trivial `Compose` WrapChainIndepState)  xs => Trivial (PerEraChainIndepState xs)
 deriving newtype instance All (Trivial `Compose` WrapExtraForgeState)  xs => Trivial (PerEraExtraForgeState xs)