[Git][ghc/ghc][master] hadrian: Improve option parsing
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Apr 3 12:16:53 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
53e4d513 by Krzysztof Gogolewski at 2023-04-03T08:16:35-04:00
hadrian: Improve option parsing
Several options in Hadrian had their argument marked as optional
(`OptArg`), but if the argument wasn't there they were just giving an
error. It's more idiomatic to mark the argument as required instead;
the code uses less Maybes, the parser can enforce that the argument
is present, --help gives better output.
- - - - -
1 changed file:
- hadrian/src/CommandLine.hs
Changes:
=====================================
hadrian/src/CommandLine.hs
=====================================
@@ -127,32 +127,26 @@ readBignum (Just ms) = Right $ \flags -> case break (== '-') (lower ms) of
("check",'-':backend) -> flags { bignum = Just backend, bignumCheck = True }
_ -> flags { bignum = Just (lower ms) }
-readBuildRoot :: Maybe FilePath -> Either String (CommandLineArgs -> CommandLineArgs)
+readBuildRoot :: FilePath -> Either String (CommandLineArgs -> CommandLineArgs)
readBuildRoot ms =
- maybe (Left "Cannot parse build-root") (Right . set) (go =<< ms)
- where
- go :: String -> Maybe BuildRoot
- go = Just . BuildRoot
- set :: BuildRoot -> CommandLineArgs -> CommandLineArgs
- set flag flags = flags { buildRoot = flag }
+ Right $ \flags -> flags { buildRoot = BuildRoot ms }
readFreeze1, readFreeze2, readSkipDepends :: Either String (CommandLineArgs -> CommandLineArgs)
readFreeze1 = Right $ \flags -> flags { freeze1 = True }
readFreeze2 = Right $ \flags -> flags { freeze1 = True, freeze2 = True }
readSkipDepends = Right $ \flags -> flags { skipDepends = True }
-readProgressInfo :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readProgressInfo :: String -> Either String (CommandLineArgs -> CommandLineArgs)
readProgressInfo ms =
- maybe (Left "Cannot parse progress-info") (Right . set) (go =<< lower <$> ms)
+ case lower ms of
+ "none" -> set None
+ "brief" -> set Brief
+ "normal" -> set Normal
+ "unicorn" -> set Unicorn
+ _ -> Left "Cannot parse progress-info"
where
- go :: String -> Maybe ProgressInfo
- go "none" = Just None
- go "brief" = Just Brief
- go "normal" = Just Normal
- go "unicorn" = Just Unicorn
- go _ = Nothing
- set :: ProgressInfo -> CommandLineArgs -> CommandLineArgs
- set flag flags = flags { progressInfo = flag }
+ set :: ProgressInfo -> Either String (CommandLineArgs -> CommandLineArgs)
+ set flag = Right $ \flags -> flags { progressInfo = flag }
readTestKeepFiles :: Either String (CommandLineArgs -> CommandLineArgs)
readTestKeepFiles = Right $ \flags -> flags { testArgs = (testArgs flags) { testKeepFiles = True } }
@@ -163,24 +157,16 @@ readTestAccept = Right $ \flags -> flags { testArgs = (testArgs flags) { testAcc
readTestHasInTreeFiles :: Either String (CommandLineArgs -> CommandLineArgs)
readTestHasInTreeFiles = Right $ \flags -> flags { testArgs = (testArgs flags) { testHasInTreeFiles = True } }
-readTestCompiler :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
-readTestCompiler compiler = maybe (Left "Cannot parse compiler") (Right . set) compiler
- where
- set compiler = \flags -> flags { testArgs = (testArgs flags) { testCompiler = compiler } }
+readTestCompiler :: String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestCompiler compiler = Right $ \flags -> flags { testArgs = (testArgs flags) { testCompiler = compiler } }
-readTestConfig :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
-readTestConfig config =
- case config of
- Nothing -> Right id
- Just conf -> Right $ \flags ->
+readTestConfig :: String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestConfig conf = Right $ \flags ->
let configs = conf : testConfigs (testArgs flags)
in flags { testArgs = (testArgs flags) { testConfigs = configs } }
-readTestConfigFile :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
-readTestConfigFile filepath =
- maybe (Left "Cannot parse test-config-file") (Right . set) filepath
- where
- set filepath flags = flags { testArgs = (testArgs flags) { testConfigFile = filepath } }
+readTestConfigFile :: String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestConfigFile filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testConfigFile = filepath } }
readTestJUnit :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestJUnit filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testJUnit = filepath } }
@@ -215,17 +201,16 @@ readTestRootDirs rootdirs = Right $ \flags ->
where rootdirs' = maybe [] (splitOn ":") rootdirs
rootdirs'' flags = testRootDirs (testArgs flags) ++ rootdirs'
-readTestSpeed :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestSpeed :: String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestSpeed ms =
- maybe (Left "Cannot parse test-speed") (Right . set) (go =<< lower <$> ms)
+ case lower ms of
+ "fast" -> set TestFast
+ "slow" -> set TestSlow
+ "normal" -> set TestNormal
+ _ -> Left "Cannot parse test-speed"
where
- go :: String -> Maybe TestSpeed
- go "fast" = Just TestFast
- go "slow" = Just TestSlow
- go "normal" = Just TestNormal
- go _ = Nothing
- set :: TestSpeed -> CommandLineArgs -> CommandLineArgs
- set flag flags = flags { testArgs = (testArgs flags) {testSpeed = flag} }
+ set :: TestSpeed -> Either String (CommandLineArgs -> CommandLineArgs)
+ set flag = Right $ \flags -> flags { testArgs = (testArgs flags) {testSpeed = flag} }
readTestSummary :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestSummary filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testSummary = filepath } }
@@ -233,19 +218,15 @@ readTestSummary filepath = Right $ \flags -> flags { testArgs = (testArgs flags)
readTestVerbose :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestVerbose verbose = Right $ \flags -> flags { testArgs = (testArgs flags) { testVerbosity = verbose } }
-readTestWay :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestWay :: String -> Either String (CommandLineArgs -> CommandLineArgs)
readTestWay way =
- case way of
- Nothing -> Right id
- Just way -> Right $ \flags ->
+ Right $ \flags ->
let newWays = way : testWays (testArgs flags)
in flags { testArgs = (testArgs flags) {testWays = newWays} }
-readBrokenTests :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
-readBrokenTests way =
- case way of
- Nothing -> Left "--broken-tests expects argument"
- Just tests -> Right $ \flags ->
+readBrokenTests :: String -> Either String (CommandLineArgs -> CommandLineArgs)
+readBrokenTests tests =
+ Right $ \flags ->
let newTests = words tests ++ brokenTests (testArgs flags)
in flags { testArgs = (testArgs flags) {brokenTests = newTests} }
@@ -255,33 +236,32 @@ readPrefix ms = Right $ \flags -> flags { prefix = ms }
readCompleteStg :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
readCompleteStg ms = Right $ \flags -> flags { completeStg = ms }
-readDocsArg :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
-readDocsArg ms = maybe (Left "Cannot parse docs argument") (Right . set) (go =<< ms)
+readDocsArg :: String -> Either String (CommandLineArgs -> CommandLineArgs)
+readDocsArg ms =
+ case ms of
+ "none" -> set (const Set.empty)
+ "no-haddocks" -> set (Set.delete Haddocks)
+ "no-sphinx-html" -> set (Set.delete SphinxHTML)
+ "no-sphinx-pdfs" -> set (Set.delete SphinxPDFs)
+ "no-sphinx-man" -> set (Set.delete SphinxMan)
+ "no-sphinx-info" -> set (Set.delete SphinxInfo)
+ "no-sphinx" -> set (Set.delete SphinxHTML
+ . Set.delete SphinxPDFs
+ . Set.delete SphinxMan
+ . Set.delete SphinxInfo)
+ _ -> Left "Cannot parse docs argument"
where
- go :: String -> Maybe (DocTargets -> DocTargets)
- go "none" = Just (const Set.empty)
- go "no-haddocks" = Just (Set.delete Haddocks)
- go "no-sphinx-html" = Just (Set.delete SphinxHTML)
- go "no-sphinx-pdfs" = Just (Set.delete SphinxPDFs)
- go "no-sphinx-man" = Just (Set.delete SphinxMan)
- go "no-sphinx-info" = Just (Set.delete SphinxInfo)
- go "no-sphinx" = Just (Set.delete SphinxHTML
- . Set.delete SphinxPDFs
- . Set.delete SphinxMan
- . Set.delete SphinxInfo)
- go _ = Nothing
-
- set :: (DocTargets -> DocTargets) -> CommandLineArgs -> CommandLineArgs
- set tweakTargets flags = flags
- { docTargets = tweakTargets (docTargets flags) }
+ set :: (DocTargets -> DocTargets) -> Either String (CommandLineArgs -> CommandLineArgs)
+ set tweakTargets = Right $ \flags ->
+ flags { docTargets = tweakTargets (docTargets flags) }
-- | Standard 'OptDescr' descriptions of Hadrian's command line arguments.
optDescrs :: [OptDescr (Either String (CommandLineArgs -> CommandLineArgs))]
optDescrs =
[ Option ['c'] ["configure"] (NoArg readConfigure)
"Deprecated: Run the boot and configure scripts."
- , Option ['o'] ["build-root"] (OptArg readBuildRoot "BUILD_ROOT")
+ , Option ['o'] ["build-root"] (ReqArg readBuildRoot "BUILD_ROOT")
"Where to store build artifacts. (Default _build)."
, Option [] ["flavour"] (OptArg readFlavour "FLAVOUR")
"Build flavour (Default, Devel1, Devel2, Perf, Prof, Quick or Quickest)."
@@ -293,17 +273,17 @@ optDescrs =
"Skip rebuilding dependency information."
, Option [] ["bignum"] (OptArg readBignum "BACKEND")
"Select ghc-bignum backend: native, gmp (default), check-gmp, ffi."
- , Option [] ["progress-info"] (OptArg readProgressInfo "STYLE")
+ , Option [] ["progress-info"] (ReqArg readProgressInfo "STYLE")
"Progress info style (None, Brief, Normal or Unicorn)."
- , Option [] ["docs"] (OptArg readDocsArg "TARGET")
+ , Option [] ["docs"] (ReqArg readDocsArg "TARGET")
"Strip down docs targets (none, no-haddocks, no-sphinx[-{html, pdfs, man}]."
, Option ['k'] ["keep-test-files"] (NoArg readTestKeepFiles)
"Keep all the files generated when running the testsuite."
- , Option [] ["test-compiler"] (OptArg readTestCompiler "TEST_COMPILER")
+ , Option [] ["test-compiler"] (ReqArg readTestCompiler "TEST_COMPILER")
"Use given compiler [Default=stage2]."
- , Option [] ["test-config-file"] (OptArg readTestConfigFile "CONFIG_FILE")
+ , Option [] ["test-config-file"] (ReqArg readTestConfigFile "CONFIG_FILE")
"configuration file for testsuite. Default=testsuite/config/ghc"
- , Option [] ["config"] (OptArg readTestConfig "EXTRA_TEST_CONFIG")
+ , Option [] ["config"] (ReqArg readTestConfig "EXTRA_TEST_CONFIG")
"Configurations to run test, in key=value format."
, Option [] ["summary-junit"] (OptArg readTestJUnit "TEST_SUMMARY_JUNIT")
"Output testsuite summary in JUnit format."
@@ -317,15 +297,15 @@ optDescrs =
"Skip performance tests."
, Option [] ["test-root-dirs"] (OptArg readTestRootDirs "DIR1:[DIR2:...:DIRn]")
"Test root directories to look at (all by default)."
- , Option [] ["test-speed"] (OptArg readTestSpeed "SPEED")
+ , Option [] ["test-speed"] (ReqArg readTestSpeed "SPEED")
"fast, slow or normal. Normal by default"
, Option [] ["summary"] (OptArg readTestSummary "TEST_SUMMARY")
"Where to output the test summary file."
, Option [] ["test-verbose"] (OptArg readTestVerbose "TEST_VERBOSE")
"A verbosity value between 0 and 5. 0 is silent, 4 and higher activates extra output."
- , Option [] ["test-way"] (OptArg readTestWay "TEST_WAY")
+ , Option [] ["test-way"] (ReqArg readTestWay "TEST_WAY")
"only run these ways"
- , Option [] ["broken-test"] (OptArg readBrokenTests "TEST_NAME")
+ , Option [] ["broken-test"] (ReqArg readBrokenTests "TEST_NAME")
"consider these tests to be broken"
, Option ['a'] ["test-accept"] (NoArg readTestAccept) "Accept new output of tests"
, Option [] ["test-have-intree-files"] (NoArg readTestHasInTreeFiles) "Run the in-tree tests even with an out of tree compiler"
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/53e4d513a55df3c13424e7b649ce85b8113fa4c2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/53e4d513a55df3c13424e7b649ce85b8113fa4c2
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230403/24181edb/attachment-0001.html>
More information about the ghc-commits
mailing list