Skip to content

Commit a8deedc

Browse files
Jimbo4350Jimbo4350
authored
Merge pull request #1247 from IntersectMBO/jordan/refactoring-20250707
Refactoring 2025-07-07
2 parents 3c4e8a3 + 8f15e8a commit a8deedc

File tree

20 files changed

+466
-478
lines changed

20 files changed

+466
-478
lines changed

‎cardano-cli/src/Cardano/CLI/Environment.hs‎

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@
55
module Cardano.CLI.Environment
66
( EnvCli (..)
77
, envCliAnyEon
8+
, envCliEra
89
, getEnvCli
910
, getEnvNetworkId
1011
, getEnvSocketPath
@@ -20,6 +21,7 @@ import Cardano.Api
2021
, NetworkMagic (..)
2122
, forEraInEonMaybe
2223
)
24+
import Cardano.Api.Experimental qualified as Exp
2325

2426
import Data.Typeable
2527
import Data.Word (Word32)
@@ -51,6 +53,21 @@ envCliAnyEon envCli = do
5153
AnyCardanoEra era <- envCliAnyCardanoEra envCli
5254
forEraInEonMaybe era EraInEon
5355

56+
anyCardanoEraToEra :: AnyCardanoEra -> Maybe (Exp.Era Exp.ConwayEra)
57+
anyCardanoEraToEra (AnyCardanoEra era) =
58+
case era of
59+
ByronEra -> Nothing
60+
ShelleyEra -> Nothing
61+
AllegraEra -> Nothing
62+
MaryEra -> Nothing
63+
AlonzoEra -> Nothing
64+
BabbageEra -> Nothing
65+
ConwayEra -> Just Exp.ConwayEra
66+
67+
envCliEra :: EnvCli -> Maybe (Exp.Era Exp.ConwayEra)
68+
envCliEra envCli = do
69+
anyCardanoEraToEra =<< envCliAnyCardanoEra envCli
70+
5471
-- | If the environment variable @CARDANO_NODE_NETWORK_ID@ is set, then return the network id therein.
5572
-- Otherwise, return 'Nothing'.
5673
getEnvNetworkId :: IO (Maybe NetworkId)

‎cardano-cli/src/Cardano/CLI/EraBased/Common/Option.hs‎

Lines changed: 18 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -15,12 +15,12 @@
1515
module Cardano.CLI.EraBased.Common.Option where
1616

1717
import Cardano.Api
18-
import Cardano.Api.Experimental
18+
import Cardano.Api.Experimental as Exp
1919
import Cardano.Api.Ledger qualified as L
2020
import Cardano.Api.Network qualified as Consensus
2121
import Cardano.Api.Parser.Text qualified as P
2222

23-
import Cardano.CLI.Environment (EnvCli (..), envCliAnyEon)
23+
import Cardano.CLI.Environment (EnvCli (..), envCliAnyEon, envCliEra)
2424
import Cardano.CLI.EraBased.Script.Certificate.Type qualified as Certifying
2525
import Cardano.CLI.EraBased.Script.Mint.Type
2626
import Cardano.CLI.EraBased.Script.Proposal.Type qualified as Proposing
@@ -147,11 +147,14 @@ pNetworkId envCli =
147147
pure <$> maybeToList (envCliNetworkId envCli)
148148
]
149149

150-
pTarget :: ShelleyBasedEra era -> Parser (Consensus.Target ChainPoint)
151-
pTarget sbe =
152-
maybe (pure Consensus.VolatileTip) pTargetFromConway (forShelleyBasedEraMaybeEon sbe)
150+
pTarget :: forall era. IsEra era => Parser (Consensus.Target ChainPoint)
151+
pTarget =
152+
maybe
153+
(pure Consensus.VolatileTip)
154+
pTargetFromConway
155+
(forShelleyBasedEraMaybeEon $ convert (useEra @era))
153156
where
154-
pTargetFromConway :: ConwayEraOnwards era -> Parser (Consensus.Target ChainPoint)
157+
pTargetFromConway :: Era era -> Parser (Consensus.Target ChainPoint)
155158
pTargetFromConway _ =
156159
asum $
157160
mconcat
@@ -357,13 +360,20 @@ pAnyShelleyBasedEra envCli =
357360
mconcat [Opt.long "alonzo-era", Opt.help $ "Specify the Alonzo era" <> deprecationText]
358361
, Opt.flag' (EraInEon ShelleyBasedEraBabbage) $
359362
mconcat [Opt.long "babbage-era", Opt.help $ "Specify the Babbage era (default)" <> deprecationText]
360-
, Opt.flag' (EraInEon ShelleyBasedEraConway) $
361-
mconcat [Opt.long "conway-era", Opt.help "Specify the Conway era"]
363+
, fmap (EraInEon . convert) $ pConwayEra envCli
362364
]
363365
, maybeToList $ pure <$> envCliAnyEon envCli
364366
, pure $ pure $ EraInEon ShelleyBasedEraConway
365367
]
366368

369+
pConwayEra :: EnvCli -> Parser (Era ConwayEra)
370+
pConwayEra envCli =
371+
asum $
372+
mconcat
373+
[ [Opt.flag' Exp.ConwayEra $ mconcat [Opt.long "conway-era", Opt.help "Specify the Conway era"]]
374+
, maybeToList $ pure <$> envCliEra envCli
375+
]
376+
367377
deprecationText :: String
368378
deprecationText = " - DEPRECATED - will be removed in the future"
369379

‎cardano-cli/src/Cardano/CLI/EraBased/Genesis/Command.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -76,7 +76,7 @@ data GenesisCreateCardanoCmdArgs era = GenesisCreateCardanoCmdArgs
7676
deriving Show
7777

7878
data GenesisCreateStakedCmdArgs era = GenesisCreateStakedCmdArgs
79-
{ eon :: !(ShelleyBasedEra era)
79+
{ eon :: !(Exp.Era era)
8080
, keyOutputFormat :: !(Vary [FormatBech32, FormatTextEnvelope])
8181
, genesisDir :: !GenesisDir
8282
, numGenesisKeys :: !Word

‎cardano-cli/src/Cardano/CLI/EraBased/Genesis/Option.hs‎

Lines changed: 42 additions & 56 deletions
Original file line numberDiff line numberDiff line change
@@ -26,93 +26,79 @@ import Options.Applicative hiding (help, str)
2626
import Options.Applicative qualified as Opt
2727

2828
pGenesisCmds
29-
:: ()
30-
=> ShelleyBasedEra era
31-
-> EnvCli
29+
:: Exp.IsEra era
30+
=> EnvCli
3231
-> Maybe (Parser (GenesisCmds era))
33-
pGenesisCmds era envCli =
32+
pGenesisCmds envCli =
3433
subInfoParser
3534
"genesis"
3635
( Opt.progDesc $
3736
mconcat
3837
[ "Genesis block commands."
3938
]
4039
)
41-
[ Just $
42-
Opt.hsubparser $
40+
$ map
41+
Just
42+
[ Opt.hsubparser $
4343
commandWithMetavar "key-gen-genesis" $
4444
Opt.info pGenesisKeyGen $
4545
Opt.progDesc "Create a Shelley genesis key pair"
46-
, Just $
47-
Opt.hsubparser $
46+
, Opt.hsubparser $
4847
commandWithMetavar "key-gen-delegate" $
4948
Opt.info pGenesisDelegateKeyGen $
5049
Opt.progDesc "Create a Shelley genesis delegate key pair"
51-
, Just $
52-
Opt.hsubparser $
50+
, Opt.hsubparser $
5351
commandWithMetavar "key-gen-utxo" $
5452
Opt.info pGenesisUTxOKeyGen $
5553
Opt.progDesc "Create a Shelley genesis UTxO key pair"
56-
, Just $
57-
Opt.hsubparser $
54+
, Opt.hsubparser $
5855
commandWithMetavar "key-hash" $
5956
Opt.info pGenesisKeyHash $
6057
Opt.progDesc "Print the identifier (hash) of a public key"
61-
, Just $
62-
Opt.hsubparser $
58+
, Opt.hsubparser $
6359
commandWithMetavar "get-ver-key" $
6460
Opt.info pGenesisVerKey $
6561
Opt.progDesc "Derive the verification key from a signing key"
66-
, Just $
67-
Opt.hsubparser $
62+
, Opt.hsubparser $
6863
commandWithMetavar "initial-addr" $
6964
Opt.info (pGenesisAddr envCli) $
7065
Opt.progDesc "Get the address for an initial UTxO based on the verification key"
71-
, Just $
72-
Opt.hsubparser $
66+
, Opt.hsubparser $
7367
commandWithMetavar "initial-txin" $
7468
Opt.info (pGenesisTxIn envCli) $
7569
Opt.progDesc "Get the TxIn for an initial UTxO based on the verification key"
76-
, forShelleyBasedEraInEonMaybe
77-
era
78-
( \sbe ->
79-
Opt.hsubparser $
80-
commandWithMetavar "create-cardano" $
81-
Opt.info (pGenesisCreateCardano sbe envCli) $
82-
Opt.progDesc $
83-
mconcat
84-
[ "Create a Byron and Shelley genesis file from a genesis "
85-
, "template and genesis/delegation/spending keys."
86-
]
87-
)
88-
, forShelleyBasedEraInEonMaybe era $ \sbe ->
89-
Opt.hsubparser $
70+
, Opt.hsubparser $
71+
commandWithMetavar "create-cardano" $
72+
Opt.info (pGenesisCreateCardano envCli) $
73+
Opt.progDesc $
74+
mconcat
75+
[ "Create a Byron and Shelley genesis file from a genesis "
76+
, "template and genesis/delegation/spending keys."
77+
]
78+
, Opt.hsubparser $
9079
commandWithMetavar "create" $
91-
Opt.info (pGenesisCreate sbe envCli) $
80+
Opt.info (pGenesisCreate envCli) $
9281
Opt.progDesc $
9382
mconcat
9483
[ "Create a Shelley genesis file from a genesis "
9584
, "template and genesis/delegation/spending keys."
9685
]
97-
, forShelleyBasedEraInEonMaybe era $ \sbe ->
98-
Opt.hsubparser $
86+
, Opt.hsubparser $
9987
commandWithMetavar "create-staked" $
100-
Opt.info (pGenesisCreateStaked sbe envCli) $
88+
Opt.info (pGenesisCreateStaked envCli) $
10189
Opt.progDesc $
10290
mconcat
10391
[ "Create a staked Shelley genesis file from a genesis "
10492
, "template and genesis/delegation/spending keys."
10593
]
106-
, forShelleyBasedEraInEonMaybe era $ \sbe ->
107-
Opt.hsubparser $
94+
, Opt.hsubparser $
10895
commandWithMetavar "create-testnet-data" $
109-
Opt.info (pGenesisCreateTestNetData sbe envCli) $
96+
Opt.info (pGenesisCreateTestNetData envCli) $
11097
Opt.progDesc $
11198
mconcat
11299
[ "Create data to use for starting a testnet."
113100
]
114-
, Just $
115-
Opt.hsubparser $
101+
, Opt.hsubparser $
116102
commandWithMetavar "hash" $
117103
Opt.info pGenesisHash $
118104
Opt.progDesc $
@@ -122,7 +108,7 @@ pGenesisCmds era envCli =
122108
, "instead. "
123109
, "Compute the hash of a genesis file."
124110
]
125-
]
111+
]
126112

127113
pGenesisKeyGen :: Parser (GenesisCmds era)
128114
pGenesisKeyGen =
@@ -174,10 +160,10 @@ pGenesisTxIn envCli =
174160
<*> pNetworkId envCli
175161
<*> pMaybeOutputFile
176162

177-
pGenesisCreateCardano :: ShelleyBasedEra era -> EnvCli -> Parser (GenesisCmds era)
178-
pGenesisCreateCardano sbe envCli =
163+
pGenesisCreateCardano :: Exp.IsEra era => EnvCli -> Parser (GenesisCmds era)
164+
pGenesisCreateCardano envCli =
179165
fmap GenesisCreateCardano $
180-
GenesisCreateCardanoCmdArgs sbe
166+
GenesisCreateCardanoCmdArgs (convert Exp.useEra)
181167
<$> pGenesisDir
182168
<*> pGenesisNumGenesisKeys
183169
<*> pGenesisNumUTxOKeys
@@ -201,10 +187,10 @@ pGenesisCreateCardano sbe envCli =
201187
"JSON file with genesis defaults for conway."
202188
<*> pNodeConfigTemplate
203189

204-
pGenesisCreate :: ShelleyBasedEra era -> EnvCli -> Parser (GenesisCmds era)
205-
pGenesisCreate sbe envCli =
190+
pGenesisCreate :: Exp.IsEra era => EnvCli -> Parser (GenesisCmds era)
191+
pGenesisCreate envCli =
206192
fmap GenesisCreate $
207-
GenesisCreateCmdArgs sbe
193+
GenesisCreateCmdArgs (convert Exp.useEra)
208194
<$> pKeyOutputFormat
209195
<*> pGenesisDir
210196
<*> pGenesisNumGenesisKeys
@@ -213,10 +199,10 @@ pGenesisCreate sbe envCli =
213199
<*> pInitialSupplyNonDelegated
214200
<*> pNetworkId envCli
215201

216-
pGenesisCreateStaked :: ShelleyBasedEra era -> EnvCli -> Parser (GenesisCmds era)
217-
pGenesisCreateStaked sbe envCli =
202+
pGenesisCreateStaked :: Exp.IsEra era => EnvCli -> Parser (GenesisCmds era)
203+
pGenesisCreateStaked envCli =
218204
fmap GenesisCreateStaked $
219-
GenesisCreateStakedCmdArgs sbe
205+
GenesisCreateStakedCmdArgs (convert Exp.useEra)
220206
<$> pKeyOutputFormat
221207
<*> pGenesisDir
222208
<*> pGenesisNumGenesisKeys
@@ -236,18 +222,18 @@ pGenesisCreateStaked sbe envCli =
236222
pRelayJsonFp =
237223
parseFilePath "relay-specification-file" "JSON file that specifies the relays of each stake pool."
238224

239-
pGenesisCreateTestNetData :: Exp.Era era -> EnvCli -> Parser (GenesisCmds era)
240-
pGenesisCreateTestNetData era envCli =
225+
pGenesisCreateTestNetData :: forall era. Exp.IsEra era => EnvCli -> Parser (GenesisCmds era)
226+
pGenesisCreateTestNetData envCli =
241227
fmap GenesisCreateTestNetData $
242-
GenesisCreateTestNetDataCmdArgs era
228+
GenesisCreateTestNetDataCmdArgs (convert $ Exp.useEra @era)
243229
<$> optional (pSpecFile "shelley")
244230
<*> optional (pSpecFile "alonzo")
245231
<*> optional (pSpecFile "conway")
246232
<*> pNumGenesisKeys
247233
<*> pNumPools
248234
<*> pNumStakeDelegs
249-
<*> (case era of Exp.ConwayEra -> pNumCommittee) -- Committee doesn't exist in babbage
250-
<*> (case era of Exp.ConwayEra -> pNumDReps) -- DReps don't exist in babbage
235+
<*> (case Exp.useEra @era of Exp.ConwayEra -> pNumCommittee) -- Committee doesn't exist in babbage
236+
<*> (case Exp.useEra @era of Exp.ConwayEra -> pNumDReps) -- DReps don't exist in babbage
251237
<*> pNumStuffedUtxoCount
252238
<*> pNumUtxoKeys
253239
<*> pSupply

‎cardano-cli/src/Cardano/CLI/EraBased/Option.hs‎

Lines changed: 2 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,6 @@ module Cardano.CLI.EraBased.Option
66
)
77
where
88

9-
import Cardano.Api (Convert (..))
109
import Cardano.Api.Experimental
1110

1211
import Cardano.CLI.Environment
@@ -34,12 +33,12 @@ pCmds envCli = do
3433
catMaybes
3534
[ Just (AddressCmds <$> pAddressCmds envCli)
3635
, Just (KeyCmds <$> pKeyCmds)
37-
, fmap GenesisCmds <$> pGenesisCmds (convert useEra) envCli
36+
, fmap GenesisCmds <$> pGenesisCmds envCli
3837
, fmap GovernanceCmds <$> pGovernanceCmds
3938
, Just (NodeCmds <$> pNodeCmds)
4039
, fmap QueryCmds <$> pQueryCmds envCli
4140
, fmap StakeAddressCmds <$> pStakeAddressCmds envCli
42-
, fmap StakePoolCmds <$> pStakePoolCmds (convert useEra) envCli
41+
, fmap StakePoolCmds <$> pStakePoolCmds envCli
4342
, fmap TextViewCmds <$> pTextViewCmds
4443
, fmap TransactionCmds <$> pTransactionCmds envCli
4544
]

0 commit comments

Comments
 (0)