Guard queries with their eras

cardano-api/gen/Test/Gen/Cardano/Api/Typed.hs

@@ -451,7 +451,7 @@ genOperationalCertificateWithCounter = do
     case issueOperationalCertificate kesVKey stkPoolOrGenDelExtSign kesP iCounter of
       -- This case should be impossible as we clearly derive the verification
       -- key from the generated signing key.
-      Left err -> fail $ prettyToString $ prettyError err
+      Left err -> fail $ docToString $ prettyError err
       Right pair -> return pair
   where
     convert :: VerificationKey GenesisDelegateExtendedKey
@@ -750,7 +750,7 @@ genTxBody :: ShelleyBasedEra era -> Gen (TxBody era)
 genTxBody era = do
   res <- Api.createAndValidateTransactionBody era <$> genTxBodyContent era
   case res of
-    Left err -> fail (prettyToString (prettyError err))
+    Left err -> fail (docToString (prettyError err))
     Right txBody -> pure txBody
 
 -- | Generate a 'Featured' for the given 'CardanoEra' with the provided generator.

cardano-api/gen/Test/Hedgehog/Golden/ErrorMessage.hs

@@ -78,4 +78,4 @@ testErrorMessage_ goldenFilesLocation moduleName typeName constructorName err =
   let fqtn = moduleName <> "." <> typeName
   testProperty constructorName . withTests 1 . property $ do
     H.note_ "Incorrect error message in golden file"
-    H.diffVsGoldenFile (prettyToString (prettyError err)) (goldenFilesLocation </> fqtn </> constructorName <> ".txt")
+    H.diffVsGoldenFile (docToString (prettyError err)) (goldenFilesLocation </> fqtn </> constructorName <> ".txt")

cardano-api/internal/Cardano/Api/Convenience/Query.hs

@@ -18,6 +18,7 @@ module Cardano.Api.Convenience.Query (
 
 import           Cardano.Api.Address
 import           Cardano.Api.Certificate
+import           Cardano.Api.Eon.BabbageEraOnwards
 import           Cardano.Api.Eon.ConwayEraOnwards (ConwayEraOnwards)
 import           Cardano.Api.Eon.ShelleyBasedEra
 import           Cardano.Api.Eras
@@ -113,14 +114,15 @@ queryStateForBalancedTx era allTxIns certs = runExceptT $ do
     & onLeft (left . QueryEraMismatch)
 
   stakeDelegDeposits <-
-    lift (queryStakeDelegDeposits sbe stakeCreds)
-      & onLeft (left . QceUnsupportedNtcVersion)
-      & onLeft (left . QueryEraMismatch)
+    forEraInEon @BabbageEraOnwards era (pure mempty) $ \beo ->
+      lift (queryStakeDelegDeposits beo stakeCreds)
+        & onLeft (left . QceUnsupportedNtcVersion)
+        & onLeft (left . QueryEraMismatch)
 
   drepDelegDeposits <-
-    forEraInEon @ConwayEraOnwards era (pure mempty) $ \_ ->
+    forEraInEon @ConwayEraOnwards era (pure mempty) $ \con ->
       Map.map (fromShelleyLovelace . drepDeposit) <$>
-      (lift (queryDRepState sbe drepCreds)
+      (lift (queryDRepState con drepCreds)
           & onLeft (left . QceUnsupportedNtcVersion)
           & onLeft (left . QueryEraMismatch))
 

cardano-api/internal/Cardano/Api/Eras/Core.hs

@@ -47,6 +47,7 @@ module Cardano.Api.Eras.Core
 
   , CardanoEraConstraints
   , cardanoEraConstraints
+  , anyCardanoEraFromStringLike
   ) where
 
 import           Cardano.Api.HasTypeProxy
@@ -57,6 +58,7 @@ import qualified Cardano.Ledger.Api as L
 import           Data.Aeson (FromJSON (..), ToJSON, toJSON, withText)
 import           Data.Kind
 import           Data.Maybe (isJust)
+import           Data.String (IsString)
 import qualified Data.Text as Text
 import           Data.Type.Equality (TestEquality (..), (:~:) (Refl))
 import           Data.Typeable (Typeable, showsTypeRep, typeOf)
@@ -177,8 +179,8 @@ monoidForEraInEon :: ()
 monoidForEraInEon sbe = forEraInEon sbe mempty
 
 monoidForEraInEonA :: ()
-  => Applicative f
   => Eon eon
+  => Applicative f
   => Monoid a
   => CardanoEra era
   -> (eon era -> f a)
@@ -242,16 +244,11 @@ deriving instance Eq    (CardanoEra era)
 deriving instance Ord   (CardanoEra era)
 deriving instance Show  (CardanoEra era)
 
-deriving via (ShowOf (CardanoEra era)) instance Pretty (CardanoEra era)
+instance Pretty (CardanoEra era) where
+  pretty = cardanoEraToStringLike
 
 instance ToJSON (CardanoEra era) where
-   toJSON ByronEra   = "Byron"
-   toJSON ShelleyEra = "Shelley"
-   toJSON AllegraEra = "Allegra"
-   toJSON MaryEra    = "Mary"
-   toJSON AlonzoEra  = "Alonzo"
-   toJSON BabbageEra = "Babbage"
-   toJSON ConwayEra  = "Conway"
+  toJSON = cardanoEraToStringLike
 
 instance TestEquality CardanoEra where
     testEquality ByronEra   ByronEra   = Just Refl
@@ -323,6 +320,9 @@ data AnyCardanoEra where
 
 deriving instance Show AnyCardanoEra
 
+instance Pretty AnyCardanoEra where
+  pretty (AnyCardanoEra e) = pretty e
+
 -- | Assumes that 'CardanoEra era' are singletons
 instance Eq AnyCardanoEra where
     AnyCardanoEra era == AnyCardanoEra era' =
@@ -363,17 +363,33 @@ instance ToJSON AnyCardanoEra where
    toJSON (AnyCardanoEra era) = toJSON era
 
 instance FromJSON AnyCardanoEra where
-   parseJSON = withText "AnyCardanoEra"
-     $ \case
-        "Byron" -> pure $ AnyCardanoEra ByronEra
-        "Shelley" -> pure $ AnyCardanoEra ShelleyEra
-        "Allegra" -> pure $ AnyCardanoEra AllegraEra
-        "Mary" -> pure $ AnyCardanoEra MaryEra
-        "Alonzo" -> pure $ AnyCardanoEra AlonzoEra
-        "Babbage" -> pure $ AnyCardanoEra BabbageEra
-        "Conway" -> pure $ AnyCardanoEra ConwayEra
-        wrong -> fail $ "Failed to parse unknown era: " <> Text.unpack wrong
-
+  parseJSON = withText "AnyCardanoEra"
+    $ (\case
+        Right era -> pure era
+        Left era -> fail $ "Failed to parse unknown era: " <> Text.unpack era
+      ) . anyCardanoEraFromStringLike
+
+
+cardanoEraToStringLike :: IsString a => CardanoEra era -> a
+cardanoEraToStringLike = \case
+  ByronEra   -> "Byron"
+  ShelleyEra -> "Shelley"
+  AllegraEra -> "Allegra"
+  MaryEra    -> "Mary"
+  AlonzoEra  -> "Alonzo"
+  BabbageEra -> "Babbage"
+  ConwayEra  -> "Conway"
+
+anyCardanoEraFromStringLike :: (IsString a, Eq a) => a -> Either a AnyCardanoEra
+anyCardanoEraFromStringLike = \case
+  "Byron" -> pure $ AnyCardanoEra ByronEra
+  "Shelley" -> pure $ AnyCardanoEra ShelleyEra
+  "Allegra" -> pure $ AnyCardanoEra AllegraEra
+  "Mary" -> pure $ AnyCardanoEra MaryEra
+  "Alonzo" -> pure $ AnyCardanoEra AlonzoEra
+  "Babbage" -> pure $ AnyCardanoEra BabbageEra
+  "Conway" -> pure $ AnyCardanoEra ConwayEra
+  wrong -> Left wrong
 
 -- | Like the 'AnyCardanoEra' constructor but does not demand a 'IsCardanoEra'
 -- class constraint.

cardano-api/internal/Cardano/Api/Error.hs

@@ -47,14 +47,14 @@ instance Error ErrorAsException where
 
 instance Show ErrorAsException where
   show (ErrorAsException e) =
-    prettyToString $ prettyError e
+    docToString $ prettyError e
 
 instance Exception ErrorAsException where
   displayException (ErrorAsException e) =
-    prettyToString $ prettyError e
+    docToString $ prettyError e
 
 displayError :: Error a => a -> String
-displayError = prettyToString . prettyError
+displayError = docToString . prettyError
 
 data FileError e = FileError FilePath e
                  | FileErrorTempFile

cardano-api/internal/Cardano/Api/Keys/Shelley.hs

@@ -1469,7 +1469,7 @@ instance FromJSON (Hash StakePoolKey) where
   parseJSON = withText "PoolId" $ \str ->
     case deserialiseFromBech32 (AsHash AsStakePoolKey) str of
       Left err ->
-        fail $ prettyToString $ mconcat
+        fail $ docToString $ mconcat
           [ "Error deserialising Hash StakePoolKey: " <> pretty str
           , " Error: " <> prettyError err
           ]
@@ -1590,7 +1590,7 @@ instance FromJSON (Hash DRepKey) where
   parseJSON = withText "DRepId" $ \str ->
     case deserialiseFromBech32 (AsHash AsDRepKey) str of
       Left err ->
-        fail $ prettyToString $ mconcat
+        fail $ docToString $ mconcat
           [ "Error deserialising Hash DRepKey: " <> pretty str
           , " Error: " <> prettyError err
           ]

cardano-api/internal/Cardano/Api/Pretty.hs

@@ -4,9 +4,9 @@ module Cardano.Api.Pretty
   , Pretty(..)
   , ShowOf(..)
   , viaShow
-  , prettyToLazyText
-  , prettyToText
-  , prettyToString
+  , docToLazyText
+  , docToText
+  , docToString
   , pshow
 
   , black
@@ -30,14 +30,14 @@ import           Prettyprinter.Render.Terminal
 -- of colored output. This is a type alias for AnsiStyle.
 type Ann = AnsiStyle
 
-prettyToString :: Doc AnsiStyle -> String
-prettyToString =  show
+docToString :: Doc AnsiStyle -> String
+docToString =  show
 
-prettyToLazyText :: Doc AnsiStyle -> TextLazy.Text
-prettyToLazyText = renderLazy . layoutPretty defaultLayoutOptions
+docToLazyText :: Doc AnsiStyle -> TextLazy.Text
+docToLazyText = renderLazy . layoutPretty defaultLayoutOptions
 
-prettyToText :: Doc AnsiStyle -> Text.Text
-prettyToText = TextLazy.toStrict . prettyToLazyText
+docToText :: Doc AnsiStyle -> Text.Text
+docToText = TextLazy.toStrict . docToLazyText
 
 black :: Doc AnsiStyle -> Doc AnsiStyle
 black = annotate (color Black)

cardano-api/internal/Cardano/Api/Query.hs

@@ -1,6 +1,5 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DerivingStrategies #-}
-{-# LANGUAGE EmptyCase #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
@@ -338,10 +337,12 @@ instance NodeToClientVersionOf (QueryInShelleyBasedEra era result) where
   nodeToClientVersionOf QueryDebugLedgerState = NodeToClientV_9
   nodeToClientVersionOf QueryProtocolState = NodeToClientV_9
   nodeToClientVersionOf QueryCurrentEpochState = NodeToClientV_9
+  -- Babbage >= v13
   nodeToClientVersionOf (QueryPoolState _) = NodeToClientV_14
   nodeToClientVersionOf (QueryPoolDistribution _) = NodeToClientV_14
   nodeToClientVersionOf (QueryStakeSnapshot _) = NodeToClientV_14
   nodeToClientVersionOf (QueryStakeDelegDeposits _) = NodeToClientV_15
+  -- Conway >= v16
   nodeToClientVersionOf QueryConstitution = NodeToClientV_16
   nodeToClientVersionOf QueryGovState = NodeToClientV_16
   nodeToClientVersionOf QueryDRepState{} = NodeToClientV_16

cardano-api/internal/Cardano/Api/Query/Expr.hs

@@ -37,6 +37,8 @@ module Cardano.Api.Query.Expr
 import           Cardano.Api.Address
 import           Cardano.Api.Block
 import           Cardano.Api.Certificate
+import           Cardano.Api.Eon.BabbageEraOnwards
+import           Cardano.Api.Eon.ConwayEraOnwards
 import           Cardano.Api.Eon.ShelleyBasedEra
 import           Cardano.Api.Eras
 import           Cardano.Api.GenesisParameters
@@ -108,17 +110,19 @@ queryGenesisParameters sbe =
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryGenesisParameters
 
 queryPoolDistribution :: ()
-  => ShelleyBasedEra era
+  => BabbageEraOnwards era
   -> Maybe (Set PoolId)
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolDistribution era)))
-queryPoolDistribution sbe mPoolIds =
+queryPoolDistribution era mPoolIds = do
+  let sbe = babbageEraOnwardsToShelleyBasedEra era
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryPoolDistribution mPoolIds
 
 queryPoolState :: ()
-  => ShelleyBasedEra era
+  => BabbageEraOnwards era
   -> Maybe (Set PoolId)
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedPoolState era)))
-queryPoolState sbe mPoolIds =
+queryPoolState era mPoolIds = do
+  let sbe = babbageEraOnwardsToShelleyBasedEra era
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryPoolState mPoolIds
 
 queryProtocolParameters :: ()
@@ -155,12 +159,14 @@ queryStakeAddresses sbe stakeCredentials networkId =
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeAddresses stakeCredentials networkId
 
 queryStakeDelegDeposits :: ()
-  => ShelleyBasedEra era
+  => BabbageEraOnwards era
   -> Set StakeCredential
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either Consensus.EraMismatch (Map StakeCredential Lovelace)))
-queryStakeDelegDeposits sbe stakeCreds
+queryStakeDelegDeposits era stakeCreds
   | S.null stakeCreds = pure . pure $ pure mempty
-  | otherwise         = queryExpr $ QueryInEra . QueryInShelleyBasedEra sbe $ QueryStakeDelegDeposits stakeCreds
+  | otherwise         = do
+    let sbe = babbageEraOnwardsToShelleyBasedEra era
+    queryExpr $ QueryInEra . QueryInShelleyBasedEra sbe $ QueryStakeDelegDeposits stakeCreds
 
 queryStakeDistribution :: ()
   => ShelleyBasedEra era
@@ -183,10 +189,11 @@ queryStakePools sbe =
   queryExpr $ QueryInEra . QueryInShelleyBasedEra sbe $ QueryStakePools
 
 queryStakeSnapshot :: ()
-  => ShelleyBasedEra era
+  => BabbageEraOnwards era
   -> Maybe (Set PoolId)
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (SerialisedStakeSnapshots era)))
-queryStakeSnapshot sbe mPoolIds =
+queryStakeSnapshot era mPoolIds = do
+  let sbe = babbageEraOnwardsToShelleyBasedEra era
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeSnapshot mPoolIds
 
 querySystemStart :: ()
@@ -202,45 +209,53 @@ queryUtxo sbe utxoFilter =
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryUTxO utxoFilter
 
 queryConstitution :: ()
-  => ShelleyBasedEra era
+  => ConwayEraOnwards era
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (L.Constitution (ShelleyLedgerEra era)))))
-queryConstitution sbe =
+queryConstitution era = do
+  let sbe = conwayEraOnwardsToShelleyBasedEra era
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryConstitution
 
 queryGovState :: ()
-  => ShelleyBasedEra era
+  => ConwayEraOnwards era
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (L.GovState (ShelleyLedgerEra era))))
-queryGovState sbe =
+queryGovState era = do
+  let sbe = conwayEraOnwardsToShelleyBasedEra era
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe QueryGovState
 
 queryDRepState :: ()
-  => ShelleyBasedEra era
+  => ConwayEraOnwards era
   -> Set (L.Credential L.DRepRole L.StandardCrypto)
   -- ^ An empty credentials set means that states for all DReps will be returned
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.Credential L.DRepRole L.StandardCrypto) (L.DRepState L.StandardCrypto))))
-queryDRepState sbe drepCreds = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryDRepState drepCreds
+queryDRepState era drepCreds = do
+  let sbe = conwayEraOnwardsToShelleyBasedEra era
+  queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryDRepState drepCreds
 
 queryDRepStakeDistribution :: ()
-  => ShelleyBasedEra era
+  => ConwayEraOnwards era
   -> Set (L.DRep L.StandardCrypto)
   -- ^ An empty DRep set means that distributions for all DReps will be returned
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map (L.DRep L.StandardCrypto) Lovelace)))
-queryDRepStakeDistribution sbe dreps = queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryDRepStakeDistr dreps
+queryDRepStakeDistribution era dreps = do
+  let sbe = conwayEraOnwardsToShelleyBasedEra era
+  queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryDRepStakeDistr dreps
 
 -- | Returns info about committee members filtered by: cold credentials, hot credentials and statuses.
 -- If empty sets are passed as filters, then no filtering is done.
 queryCommitteeMembersState :: ()
-  => ShelleyBasedEra era
+  => ConwayEraOnwards era
   -> Set (L.Credential L.ColdCommitteeRole L.StandardCrypto)
   -> Set (L.Credential L.HotCommitteeRole L.StandardCrypto)
   -> Set L.MemberStatus
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Maybe (L.CommitteeMembersState L.StandardCrypto))))
-queryCommitteeMembersState sbe coldCreds hotCreds statuses =
+queryCommitteeMembersState era coldCreds hotCreds statuses = do
+  let sbe = conwayEraOnwardsToShelleyBasedEra era
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe (QueryCommitteeMembersState coldCreds hotCreds statuses)
 
 queryStakeVoteDelegatees :: ()
-  => ShelleyBasedEra era
+  => ConwayEraOnwards era
   -> Set StakeCredential
   -> LocalStateQueryExpr block point QueryInMode r IO (Either UnsupportedNtcVersionError (Either EraMismatch (Map StakeCredential (L.DRep L.StandardCrypto))))
-queryStakeVoteDelegatees sbe stakeCredentials =
+queryStakeVoteDelegatees era stakeCredentials = do
+  let sbe = conwayEraOnwardsToShelleyBasedEra era
   queryExpr $ QueryInEra $ QueryInShelleyBasedEra sbe $ QueryStakeVoteDelegatees stakeCredentials

cardano-api/internal/Cardano/Api/SerialiseUsing.hs

@@ -112,7 +112,7 @@ instance SerialiseAsBech32 a => IsString (UsingBech32 a) where
       case deserialiseFromBech32 ttoken (Text.pack str) of
         Right x  -> UsingBech32 x
         Left  e ->
-          error $ prettyToString $
+          error $ docToString $
             "fromString: " <> pretty str <> ": " <> prettyError e
       where
         ttoken :: AsType a
@@ -126,7 +126,7 @@ instance SerialiseAsBech32 a => FromJSON (UsingBech32 a) where
       Aeson.withText tname $ \str ->
         case deserialiseFromBech32 ttoken str of
           Right x -> return (UsingBech32 x)
-          Left  e -> fail $ prettyToString $ pretty str <> ": " <> prettyError e
+          Left  e -> fail $ docToString $ pretty str <> ": " <> prettyError e
       where
         ttoken = proxyToAsType (Proxy :: Proxy a)
         tname  = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a)