hadrian, testsuite: Teach Hadrian to query the testsuite driver for dependencies

Issues #19072, #17728, #20176

8 files changed, 96 insertions, 20 deletions

diff --git a/hadrian/src/Builder.hs b/hadrian/src/Builder.hs
index c746f95695..bd8cd95040 100644
--- a/hadrian/src/Builder.hs
+++ b/hadrian/src/Builder.hs
@@ -2,7 +2,7 @@
 module Builder (
     -- * Data types
     ArMode (..), CcMode (..), ConfigurationInfo (..), DependencyType (..),
-    GhcMode (..), GhcPkgMode (..), HaddockMode (..), SphinxMode (..),
+    GhcMode (..), GhcPkgMode (..), HaddockMode (..), TestMode(..), SphinxMode (..),
     TarMode (..), Builder (..),
 
     -- * Builder properties
@@ -114,6 +114,15 @@ instance Binary   HaddockMode
 instance Hashable HaddockMode
 instance NFData   HaddockMode
 
+-- | The testsuite driver can be called in two different modes:
+-- * Actually run the tests
+-- * Get all the hadrian targets needed for the current test configuration
+data TestMode = RunTest | GetExtraDeps deriving (Eq, Generic, Show)
+
+instance Binary   TestMode
+instance Hashable TestMode
+instance NFData   TestMode
+
 -- | A 'Builder' is a (usually external) command invoked in a separate process
 -- via 'cmd'. Here are some examples:
 -- * 'Alex' is a lexical analyser generator that builds @Lexer.hs@ from @Lexer.x@.
@@ -148,7 +157,7 @@ data Builder = Alex
              | Patch
              | Python
              | Ranlib
-             | RunTest
+             | Testsuite TestMode
              | Sphinx SphinxMode
              | Tar TarMode
              | Unlit
@@ -225,7 +234,8 @@ instance H.Builder Builder where
     -- contrast this with runBuilderWith, which returns @Action ()@
     -- this returns the @stdout@ from running the builder.
     -- For now this only implements asking @ghc-pkg@ about package
-    -- dependencies.
+    -- dependencies and asking the testsuite driver about hadrian
+    -- dependencies for tests.
     askBuilderWith :: Builder -> BuildInfo -> Action String
     askBuilderWith builder BuildInfo {..} = case builder of
         GhcPkg Dependencies _ -> do
@@ -241,6 +251,13 @@ instance H.Builder Builder where
                 need [path]
             Stdout stdout <- cmd' [path] ["--no-user-package-db", "field", input, "depends"]
             return stdout
+        Testsuite GetExtraDeps -> do
+          path <- builderPath builder
+          withResources buildResources $ do
+              -- The testsuite driver reports the dependencies on stderr
+              -- buildArgs should include --only-report-hadrian-deps at this point
+              Stderr stderr <- cmd' [path] buildArgs
+              return stderr
         _ -> error $ "Builder " ++ show builder ++ " can not be asked!"
 
     runBuilderWith :: Builder -> BuildInfo -> Action ()
@@ -322,7 +339,7 @@ instance H.Builder Builder where
 
                 -- RunTest produces a very large amount of (colorised) output;
                 -- Don't attempt to capture it.
-                RunTest -> do
+                Testsuite RunTest -> do
                   Exit code <- cmd echo [path] buildArgs
                   when (code /= ExitSuccess) $ do
                     fail "tests failed"
@@ -371,7 +388,7 @@ systemBuilderPath builder = case builder of
     Patch           -> fromKey "patch"
     Python          -> fromKey "python"
     Ranlib          -> fromKey "ranlib"
-    RunTest         -> fromKey "python"
+    Testsuite _     -> fromKey "python"
     Sphinx _        -> fromKey "sphinx-build"
     Tar _           -> fromKey "tar"
     Xelatex         -> fromKey "xelatex"
diff --git a/hadrian/src/Expression.hs b/hadrian/src/Expression.hs
index 710986b749..62e83ccecb 100644
--- a/hadrian/src/Expression.hs
+++ b/hadrian/src/Expression.hs
@@ -86,6 +86,13 @@ instance BuilderPredicate a => BuilderPredicate (FilePath -> a) where
             Configure path -> builder (f path)
             _              -> return False
 
+instance BuilderPredicate a => BuilderPredicate (TestMode -> a) where
+    builder f = do
+        b <- getBuilder
+        case b of
+            Testsuite mode -> builder (f mode)
+            _              -> return False
+
 -- | Is the current build 'Way' equal to a certain value?
 way :: Way -> Predicate
 way w = (w ==) <$> getWay
diff --git a/hadrian/src/Flavour.hs b/hadrian/src/Flavour.hs
index 3a23fd878f..d555246c4b 100644
--- a/hadrian/src/Flavour.hs
+++ b/hadrian/src/Flavour.hs
@@ -151,7 +151,7 @@ enableThreadSanitizer = addArgs $ mconcat
     , builder (Ghc LinkHs) ? arg "-optl-fsanitize=thread"
     , builder (Cc  CompileC) ? (arg "-fsanitize=thread" <> arg "-DTSAN_ENABLED")
     , builder (Cabal Flags) ? arg "thread-sanitizer"
-    , builder  RunTest ? arg "--config=have_thread_sanitizer=True"
+    , builder Testsuite ? arg "--config=have_thread_sanitizer=True"
     ]
 
 -- | Use the LLVM backend in stages 1 and later.
@@ -338,7 +338,7 @@ builderPredicate = builderSetting <&> (\(wstg, wpkg, builderMode) ->
        BM_Ghc ghcMode -> wildcard (builder Ghc) (builder . Ghc) ghcMode
        BM_Cc  ccMode  -> wildcard (builder Cc) (builder . Cc) ccMode
        BM_CabalConfigure -> builder (Cabal Setup)
-       BM_RunTest     -> builder RunTest
+       BM_RunTest     -> builder Testsuite
     )
   )
 
diff --git a/hadrian/src/Rules/Test.hs b/hadrian/src/Rules/Test.hs
index 7e19798b10..0088765714 100644
--- a/hadrian/src/Rules/Test.hs
+++ b/hadrian/src/Rules/Test.hs
@@ -170,11 +170,19 @@ testRules = do
             -- which is in turn included by all test 'Makefile's.
             setEnv "ghc_config_mk" (top -/- root -/- ghcConfigPath)
 
+        let test_target tt = target (vanillaContext Stage2 compiler) (Testsuite tt) [] []
+
+        -- We need to ask the testsuite if it needs any extra hadrian dependencies for the
+        -- tests it is going to run,
+        -- for example "docs_haddock"
+        -- We then need to go and build these dependencies
+        extra_targets <- words <$> askWithResources [] (test_target GetExtraDeps)
+        need extra_targets
+
         -- Execute the test target.
         -- We override the verbosity setting to make sure the user can see
         -- the test output: https://gitlab.haskell.org/ghc/ghc/issues/15951.
-        withVerbosity Diagnostic $ buildWithCmdOptions env $
-            target (vanillaContext Stage2 compiler) RunTest [] []
+        withVerbosity Diagnostic $ buildWithCmdOptions env $ test_target RunTest
 
 -- | Build the timeout program.
 -- See: https://github.com/ghc/ghc/blob/master/testsuite/timeout/Makefile#L23
diff --git a/hadrian/src/Settings/Builders/RunTest.hs b/hadrian/src/Settings/Builders/RunTest.hs
index 3c918a28f7..d1bd7b1e0b 100644
--- a/hadrian/src/Settings/Builders/RunTest.hs
+++ b/hadrian/src/Settings/Builders/RunTest.hs
@@ -7,6 +7,8 @@ import CommandLine
 import Oracles.TestSettings
 import Packages
 import Settings.Builders.Common
+import qualified Data.Set    as Set
+import Flavour
 
 getTestSetting :: TestSetting -> Expr String
 getTestSetting key = expr $ testSetting key
@@ -51,7 +53,13 @@ runTestGhcFlags = do
 -- Command line arguments for invoking the @runtest.py@ script. A lot of this
 -- mirrors @testsuite/mk/test.mk@.
 runTestBuilderArgs :: Args
-runTestBuilderArgs = builder RunTest ? do
+runTestBuilderArgs =
+  mconcat [ runTestNormalArgs
+          , builder (Testsuite GetExtraDeps) ? arg "--only-report-hadrian-deps"
+          ]
+
+runTestNormalArgs :: Args
+runTestNormalArgs = builder Testsuite ? do
     pkgs     <- expr $ stagePackages Stage1
     libTests <- expr $ filterM doesDirectoryExist $ concat
             [ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ]
@@ -159,7 +167,13 @@ getTestArgs = do
     bindir          <- expr $ getBinaryDirectory (testCompiler args)
     compiler        <- expr $ getCompilerPath (testCompiler args)
     globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
-    haveDocs        <- areDocsPresent
+    -- the testsuite driver will itself tell us if we need to generate the docs target
+    -- So we always pass the haddock path if the hadrian configuration allows us to build
+    -- docs
+    -- If the configuration doesn't allow us to build docs, then we don't pass the haddock
+    -- option, and the testsuite driver will not subsequently ask us to build haddocks
+    -- for the required tests
+    haveDocs        <- willDocsBeBuilt
     let configFileArg= ["--config-file=" ++ (testConfigFile args)]
         testOnlyArg  =  map ("--only=" ++) (testOnly args ++ testEnvTargets)
         onlyPerfArg  = if testOnlyPerf args
@@ -208,16 +222,10 @@ getTestArgs = do
          ++ haddockArg ++ hp2psArg ++ hpcArg ++ inTreeArg
          ++ brokenTestArgs
 
-  where areDocsPresent = expr $ do
-          root <- buildRoot
-          and <$> traverse doesFileExist (docFiles root)
+  where willDocsBeBuilt = expr $ do
+          doctargets <- ghcDocs =<< flavour
+          pure $ Haddocks `Set.member` doctargets
 
-        docFiles root =
-          [ root -/- "docs" -/- "html" -/- "libraries" -/- p -/- (p ++ ".haddock")
-          -- list of packages from
-          -- utils/haddock/haddock-test/src/Test/Haddock/Config.hs
-          | p <- [ "array", "base", "ghc-prim", "process", "template-haskell" ]
-          ]
 
 -- | Set speed for test
 setTestSpeed :: TestSpeed -> String
diff --git a/testsuite/driver/runtests.py b/testsuite/driver/runtests.py
index 2c76661184..b315e80d09 100644
--- a/testsuite/driver/runtests.py
+++ b/testsuite/driver/runtests.py
@@ -79,6 +79,8 @@ perf_group.add_argument("--skip-perf-tests", action="store_true", help="skip per
 perf_group.add_argument("--only-perf-tests", action="store_true", help="Only do performance tests")
 parser.add_argument("--ignore-perf-failures", choices=['increases','decreases','all'],
                         help="Do not fail due to out-of-tolerance perf tests")
+parser.add_argument("--only-report-hadrian-deps", action="store_true",
+                        help="Dry run the testsuite and report all extra hadrian depenedencies needed on stderr")
 
 args = parser.parse_args()
 
@@ -148,6 +150,9 @@ if args.threads:
 if args.verbose is not None:
     config.verbose = args.verbose
 
+config.only_report_hadrian_deps = args.only_report_hadrian_deps
+
+
 # Note force skip perf tests: skip if this is not a git repo (estimated with inside_git_repo)
 # and no metrics file is given. In this case there is no way to read the previous commit's
 # perf test results, nor a way to store new perf test results.
@@ -563,6 +568,11 @@ else:
     if args.junit:
         junit(t).write(args.junit)
 
+    if config.only_report_hadrian_deps:
+      print("WARNING - skipping all tests and only reporting required hadrian dependencies:", config.hadrian_deps)
+      for d in config.hadrian_deps:
+        print(d,file=sys.stderr)
+
 if len(t.unexpected_failures) > 0 or \
    len(t.unexpected_stat_failures) > 0 or \
    len(t.unexpected_passes) > 0 or \
diff --git a/testsuite/driver/testglobals.py b/testsuite/driver/testglobals.py
index adb2109923..e3df29c980 100644
--- a/testsuite/driver/testglobals.py
+++ b/testsuite/driver/testglobals.py
@@ -210,6 +210,13 @@ class TestConfig:
         # I have no idea what this does
         self.package_conf_cache_file = None # type: Optional[Path]
 
+        # The extra hadrian dependencies we need for all configured tests
+        self.hadrian_deps = set() # type: Set[str]
+
+        # Are we only reporting hadrian dependencies?
+        self.only_report_hadrian_deps = False # type: bool
+
+
     def validate(self) -> None:
         """ Check the TestConfig for self-consistency """
         def assert_implies(a: bool, b: bool):
@@ -438,6 +445,9 @@ class TestOptions:
        # Should we copy the files of symlink the files for the test?
        self.copy_files = False
 
+       # The extra hadrian dependencies we need for this particular test
+       self.hadrian_deps = set() # type: Set[str]
+
 # The default set of options
 global default_testopts
 default_testopts = TestOptions()
diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py
index 3202bab65c..20b4181004 100644
--- a/testsuite/driver/testlib.py
+++ b/testsuite/driver/testlib.py
@@ -196,7 +196,17 @@ def _reqlib( name, opts, lib ):
         for db in config.test_package_db:
             opts.extra_hc_opts = opts.extra_hc_opts + ' -package-db=' + db + ' '
 
+def _req_hadrian_deps(name,opts,deps):
+    opts.hadrian_deps.update(deps)
+
+def req_hadrian_deps(deps):
+    return lambda name, opts: _req_hadrian_deps(name,opts,deps)
+
+# We want the 'docs-haddock' dependency and not just the
+# haddock executable since the haddock tests need documentation
+# for the boot libraries
 def req_haddock( name, opts ):
+    _req_hadrian_deps(name,opts,["docs-haddock"])
     if not config.haddock:
         opts.expect = 'missing-lib'
         opts.skip   = True
@@ -1079,6 +1089,12 @@ def test_common_work(watcher: testutil.Watcher,
             else:
                 framework_fail(name, None, 'extra_file is empty string')
 
+        # If we are only reporting hadrian dependencies, then skip the test
+        # and add its dependencies to the global set
+        if do_ways and config.only_report_hadrian_deps:
+            do_ways = []
+            config.hadrian_deps |= getTestOpts().hadrian_deps
+
         # Run the required tests...
         for way in do_ways:
             if stopping():