hadrian: Improve option parsingwip/hadrian-opts

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 files changed, 56 insertions, 76 deletions

diff --git a/hadrian/src/CommandLine.hs b/hadrian/src/CommandLine.hs
index 7d1edc8978..6fc74af5d3 100644
--- a/hadrian/src/CommandLine.hs
+++ b/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"