hadrian: Add --broken-test flag

This exposes the flag of the same name supported by the testsuite
driver.

4 files changed, 25 insertions, 0 deletions

diff --git a/.gitlab/ci.sh b/.gitlab/ci.sh
index 13ec55f389..851eb27933 100755
--- a/.gitlab/ci.sh
+++ b/.gitlab/ci.sh
@@ -405,6 +405,7 @@ function run_hadrian() {
   run hadrian/build.cabal.sh \
     --flavour="$FLAVOUR" \
     -j"$cores" \
+    --broken-test="$BROKEN_TESTS" \
     $HADRIAN_ARGS \
     $@
 }
diff --git a/hadrian/doc/testsuite.md b/hadrian/doc/testsuite.md
index 12ad4cb87c..65202dc038 100644
--- a/hadrian/doc/testsuite.md
+++ b/hadrian/doc/testsuite.md
@@ -131,6 +131,16 @@ build test --test-speed=normal
 build test --test-speed=fast
 ```
 
+## Considering tests to be broken
+
+Sometimes it is necessary to mark tests as broken in a particular test
+environment (e.g. a particular Linux distribution). While usually one would
+want to declare this in the test definition using the `expect_broken` modifier,
+this is sometimes not possible.
+
+For these cases one can use Hadrian's `--broken-test` flag to tell the
+testsuite driver to consider a test to be broken during the testsuite run.
+
 ## Test ways
 
 You can specify which test ways to use using `--test-way=<way>`,
diff --git a/hadrian/src/CommandLine.hs b/hadrian/src/CommandLine.hs
index 00bfc5d910..1b111d0b2f 100644
--- a/hadrian/src/CommandLine.hs
+++ b/hadrian/src/CommandLine.hs
@@ -61,6 +61,7 @@ data TestArgs = TestArgs
     , testSummary    :: Maybe FilePath
     , testVerbosity  :: Maybe String
     , testWays       :: [String]
+    , brokenTests    :: [String]
     , testAccept     :: Bool}
     deriving (Eq, Show)
 
@@ -81,6 +82,7 @@ defaultTestArgs = TestArgs
     , testSummary    = Nothing
     , testVerbosity  = Nothing
     , testWays       = []
+    , brokenTests    = []
     , testAccept     = False }
 
 readConfigure :: Either String (CommandLineArgs -> CommandLineArgs)
@@ -194,6 +196,14 @@ readTestWay way =
             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 ->
+            let newTests = words tests ++ brokenTests (testArgs flags)
+            in flags { testArgs = (testArgs flags) {brokenTests = newTests} }
+
 readCompleteStg :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
 readCompleteStg ms = Right $ \flags -> flags { completeStg = ms }
 
@@ -263,6 +273,8 @@ optDescrs =
       "A verbosity value between 0 and 5. 0 is silent, 4 and higher activates extra output."
     , Option [] ["test-way"] (OptArg readTestWay "TEST_WAY")
       "only run these ways"
+    , Option [] ["broken-test"] (OptArg readBrokenTests "TEST_NAME")
+      "consider these tests to be broken"
     , Option ['a'] ["test-accept"] (NoArg readTestAccept) "Accept new output of tests"
     , Option [] ["complete-setting"] (OptArg readCompleteStg "SETTING")
         "Setting key to autocomplete, for the 'autocomplete' target."
diff --git a/hadrian/src/Settings/Builders/RunTest.hs b/hadrian/src/Settings/Builders/RunTest.hs
index c1febb92ac..9d18777a03 100644
--- a/hadrian/src/Settings/Builders/RunTest.hs
+++ b/hadrian/src/Settings/Builders/RunTest.hs
@@ -162,6 +162,7 @@ getTestArgs = do
         skipPerfArg  = if testSkipPerf args
                            then Just "--skip-perf-tests"
                            else Nothing
+        brokenTestArgs = concat [ ["--broken-test", t] | t <- brokenTests args ]
         speedArg     = ["-e", "config.speed=" ++ setTestSpeed (testSpeed args)]
         summaryArg   = case testSummary args of
                            Just filepath -> Just $ "--summary-file " ++ show filepath
@@ -192,6 +193,7 @@ getTestArgs = do
                       , junitArg, metricsArg, verbosityArg  ]
          ++ configArgs ++ wayArgs ++  compilerArg ++ ghcPkgArg
          ++ haddockArg ++ hp2psArg ++ hpcArg ++ inTreeArg
+         ++ brokenTestArgs
 
   where areDocsPresent = expr $ do
           root <- buildRoot