Merge pull request #863 from IntersectMBO/smelc/drep-state-output-jso…

…n-instance Create toJSON instance for "query drep-state" output
IntersectMBO · Aug 13, 2024 · 08d89d1 · 08d89d1
2 parents 3435070 + 2a2986f
commit 08d89d1
Show file tree

Hide file tree

Showing 4 changed files with 56 additions and 23 deletions.
diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Commands/Query.hs
@@ -248,11 +248,6 @@ data QueryDRepStateCmdArgs era = QueryDRepStateCmdArgs
   }
   deriving Show
 
--- | Whether to include the stake, as queried by drep-stake-distribution, in
--- the output of drep-state. This is (computationally) expensive, but sometimes
--- convenient.
-data IncludeStake = WithStake | NoStake deriving Show
-
 data QueryDRepStakeDistributionCmdArgs era = QueryDRepStakeDistributionCmdArgs
   { eon :: !(ConwayEraOnwards era)
   , nodeSocketPath :: !SocketPath

diff --git a/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs b/cardano-cli/src/Cardano/CLI/EraBased/Run/Query.hs
@@ -41,6 +41,7 @@ where
 import           Cardano.Api hiding (QueryInShelleyBasedEra (..))
 import qualified Cardano.Api as Api
 import           Cardano.Api.Byron hiding (QueryInShelleyBasedEra (..))
+import           Cardano.Api.Ledger (strictMaybeToMaybe)
 import qualified Cardano.Api.Ledger as L
 import           Cardano.Api.Shelley hiding (QueryInShelleyBasedEra (..))
 
@@ -52,6 +53,7 @@ import           Cardano.CLI.Types.Errors.NodeEraMismatchError
 import           Cardano.CLI.Types.Errors.QueryCmdError
 import           Cardano.CLI.Types.Errors.QueryCmdLocalStateQueryError
 import           Cardano.CLI.Types.Key
+import           Cardano.CLI.Types.Output (QueryDRepStateOutput (..))
 import qualified Cardano.CLI.Types.Output as O
 import           Cardano.Crypto.Hash (hashToBytesAsHex)
 import qualified Cardano.Crypto.Hash.Blake2b as Blake2b
@@ -1651,27 +1653,24 @@ runQueryDRepState
             queryDRepStakeDistribution eon (Set.fromList $ L.DRepCredential <$> drepCreds)
         Cmd.NoStake -> return mempty
 
-    writeOutput mOutFile $
-      drepStateToJson drepStakeDistribution <$> Map.assocs drepState
+    let assocs :: [(L.Credential L.DRepRole StandardCrypto, L.DRepState StandardCrypto)] = Map.assocs drepState
+        toWrite = toDRepStateOutput drepStakeDistribution <$> assocs
+
+    writeOutput mOutFile toWrite
    where
-    drepStateToJson
+    toDRepStateOutput
       :: ()
-      => ToJSON a
-      => Map (L.DRep StandardCrypto) a
+      => Map (L.DRep StandardCrypto) L.Coin
       -> (L.Credential L.DRepRole StandardCrypto, L.DRepState StandardCrypto)
-      -> (L.Credential L.DRepRole StandardCrypto, A.Value)
-    drepStateToJson stakeDistr (cred, ds) =
-      ( cred
-      , A.object $
-          [ "expiry" .= (ds ^. L.drepExpiryL)
-          , "anchor" .= (ds ^. L.drepAnchorL)
-          , "deposit" .= (ds ^. L.drepDepositL)
-          ]
-            <> ( case includeStake of
-                  Cmd.WithStake -> ["stake" .= Map.lookup (L.DRepCredential cred) stakeDistr]
-                  Cmd.NoStake -> []
-               )
-      )
+      -> QueryDRepStateOutput
+    toDRepStateOutput stakeDistr (cred, ds) =
+      QueryDRepStateOutput
+        cred
+        (ds ^. L.drepExpiryL)
+        (strictMaybeToMaybe $ ds ^. L.drepAnchorL)
+        (ds ^. L.drepDepositL)
+        includeStake
+        (Map.lookup (L.DRepCredential cred) stakeDistr)
 
 runQueryDRepStakeDistribution
   :: Cmd.QueryDRepStakeDistributionCmdArgs era

diff --git a/cardano-cli/src/Cardano/CLI/Types/Common.hs b/cardano-cli/src/Cardano/CLI/Types/Common.hs
@@ -27,6 +27,7 @@ module Cardano.CLI.Types.Common
   , GenesisDir (..)
   , GenesisFile (..)
   , GenesisKeyFile (..)
+  , IncludeStake (..)
   , InputTxBodyOrTxFile (..)
   , KeyOutputFormat (..)
   , MetadataFile (..)
@@ -159,6 +160,11 @@ data StakeDelegators = StakeDelegators
   }
   deriving Show
 
+-- | Whether to include the stake, as queried by drep-stake-distribution, in
+-- the output of drep-state. This is (computationally) expensive, but sometimes
+-- convenient.
+data IncludeStake = WithStake | NoStake deriving Show
+
 data DRepCredentials = DRepCredentials
   { dRepCredentialGenerationMode :: !CredentialGenerationMode
   -- ^ Whether to write them to disk

diff --git a/cardano-cli/src/Cardano/CLI/Types/Output.hs b/cardano-cli/src/Cardano/CLI/Types/Output.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE LambdaCase #-}
@@ -6,6 +7,7 @@
 -- These types (and their encodings) are typically consumed by users of @cardano-cli@.
 module Cardano.CLI.Types.Output
   ( PlutusScriptCostError
+  , QueryDRepStateOutput (..)
   , QueryKesPeriodInfoOutput (..)
   , QueryTipLocalState (..)
   , QueryTipLocalStateOutput (..)
@@ -167,6 +169,37 @@ data QueryTipLocalStateOutput = QueryTipLocalStateOutput
   }
   deriving Show
 
+data QueryDRepStateOutput
+  = -- Not a record, because we want exhaustive warnings in the code of ToJSON below,
+    -- if we ever add more fields.
+    QueryDRepStateOutput
+      (L.Credential L.DRepRole L.StandardCrypto)
+      -- ^ Credential
+      EpochNo
+      -- ^ Expiry
+      (Maybe (L.Anchor L.StandardCrypto))
+      -- ^ Anchor
+      L.Coin
+      -- ^ Deposit
+      IncludeStake
+      (Maybe L.Coin)
+      -- ^ Stake
+
+instance ToJSON QueryDRepStateOutput where
+  toJSON (QueryDRepStateOutput credential expiry anchor deposit includeStake stake) =
+    toJSON
+      ( credential
+      , object $
+          [ "expiry" .= expiry
+          , "anchor" .= anchor
+          , "deposit" .= deposit
+          ]
+            <> ( case includeStake of
+                  WithStake -> ["stake" .= stake]
+                  NoStake -> []
+               )
+      )
+
 -- | A key-value pair difference list for encoding a JSON object.
 (..=) :: (KeyValue e kv, ToJSON v) => Aeson.Key -> v -> [kv] -> [kv]
 (..=) n v = (n .= v :)