[WIP] Support run GHC's test from hadrian.

cfg/system.config.in

@@ -26,6 +26,10 @@ perl           = @PerlCmd@
 ln-s           = @LN_S@
 xelatex        = @XELATEX@
 
+# Python 3 is required to run test driver.
+# See: https://github.com/ghc/ghc/blob/master/testsuite/mk/boilerplate.mk#L220
+python         = python3
+
 # Information about builders:
 #============================
 

hadrian.cabal

@@ -78,6 +78,7 @@ executable hadrian
                        , Settings.Builders.HsCpp
                        , Settings.Builders.Ld
                        , Settings.Builders.Make
+                       , Settings.Builders.RunTest
                        , Settings.Builders.Xelatex
                        , Settings.Default
                        , Settings.Flavours.Development

src/Builder.hs

@@ -87,6 +87,7 @@ data Builder = Alex
              | Haddock HaddockMode
              | Happy
              | Hpc
+             | Hp2Ps
              | HsCpp
              | Hsc2Hs
              | Ld
@@ -95,7 +96,9 @@ data Builder = Alex
              | Objdump
              | Patch
              | Perl
+             | Python
              | Ranlib
+             | RunTest
              | Sphinx SphinxMode
              | Tar TarMode
              | Unlit
@@ -121,6 +124,7 @@ builderProvenance = \case
     GhcPkg _ _       -> context Stage0 ghcPkg
     Haddock _        -> context Stage2 haddock
     Hpc              -> context Stage1 hpcBin
+    Hp2Ps            -> context Stage0 hp2ps
     Hsc2Hs           -> context Stage0 hsc2hs
     Unlit            -> context Stage0 unlit
     _                -> Nothing
@@ -221,7 +225,9 @@ systemBuilderPath builder = case builder of
     Objdump         -> fromKey "objdump"
     Patch           -> fromKey "patch"
     Perl            -> fromKey "perl"
+    Python          -> fromKey "python"
     Ranlib          -> fromKey "ranlib"
+    RunTest         -> fromKey "python"
     Sphinx _        -> fromKey "sphinx-build"
     Tar _           -> fromKey "tar"
     Xelatex         -> fromKey "xelatex"

src/CommandLine.hs

@@ -1,7 +1,7 @@
 module CommandLine (
     optDescrs, cmdLineArgsMap, cmdFlavour, lookupFreeze1, cmdIntegerSimple,
     cmdProgressColour, cmdProgressInfo, cmdConfigure, cmdSplitObjects,
-    cmdInstallDestDir
+    cmdInstallDestDir, TestArgs(..), defaultTestArgs
     ) where
 
 import Data.Either
@@ -21,7 +21,8 @@ data CommandLineArgs = CommandLineArgs
     , integerSimple  :: Bool
     , progressColour :: UseColour
     , progressInfo   :: ProgressInfo
-    , splitObjects   :: Bool }
+    , splitObjects   :: Bool
+    , testArgs       :: TestArgs }
     deriving (Eq, Show)
 
 -- | Default values for 'CommandLineArgs'.
@@ -34,7 +35,26 @@ defaultCommandLineArgs = CommandLineArgs
     , integerSimple  = False
     , progressColour = Auto
     , progressInfo   = Brief
-    , splitObjects   = False }
+    , splitObjects   = False
+    , testArgs       = defaultTestArgs }
+
+-- | These arguments are used by the `test` target.
+data TestArgs = TestArgs
+    { testOnly     :: Maybe String
+    , testSkipPerf :: Bool
+    , testSummary  :: Maybe FilePath
+    , testJUnit    :: Maybe FilePath
+    , testConfigs  :: [String] }
+    deriving (Eq, Show)
+
+-- | Default value for `TestArgs`.
+defaultTestArgs :: TestArgs
+defaultTestArgs = TestArgs
+    { testOnly     = Nothing
+    , testSkipPerf = False
+    , testSummary  = Nothing
+    , testJUnit    = Nothing
+    , testConfigs  = [] }
 
 readConfigure :: Either String (CommandLineArgs -> CommandLineArgs)
 readConfigure = Right $ \flags -> flags { configure = True }
@@ -79,6 +99,26 @@ readProgressInfo ms =
 readSplitObjects :: Either String (CommandLineArgs -> CommandLineArgs)
 readSplitObjects = Right $ \flags -> flags { splitObjects = True }
 
+readTestOnly :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestOnly tests = Right $ \flags -> flags { testArgs = (testArgs flags) { testOnly = tests } }
+
+readTestSkipPerf :: Either String (CommandLineArgs -> CommandLineArgs)
+readTestSkipPerf = Right $ \flags -> flags { testArgs = (testArgs flags) { testSkipPerf = True } }
+
+readTestSummary :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestSummary filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testJUnit = filepath } }
+
+readTestJUnit :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestJUnit filepath = Right $ \flags -> flags { testArgs = (testArgs flags) { testJUnit = filepath } }
+
+readTestConfig :: Maybe String -> Either String (CommandLineArgs -> CommandLineArgs)
+readTestConfig config =
+    case config of
+         Nothing -> Right id
+         Just conf -> Right $ \flags ->
+                        let configs = conf : testConfigs (testArgs flags)
+                         in flags { testArgs = (testArgs flags) { testConfigs = configs } }
+
 -- | Standard 'OptDescr' descriptions of Hadrian's command line arguments.
 optDescrs :: [OptDescr (Either String (CommandLineArgs -> CommandLineArgs))]
 optDescrs =
@@ -97,7 +137,17 @@ optDescrs =
     , Option [] ["progress-info"] (OptArg readProgressInfo "STYLE")
       "Progress info style (None, Brief, Normal or Unicorn)."
     , Option [] ["split-objects"] (NoArg readSplitObjects)
-      "Generate split objects (requires a full clean rebuild)." ]
+      "Generate split objects (requires a full clean rebuild)."
+    , Option [] ["only"] (OptArg readTestOnly "TESTS")
+      "Test cases to run."
+    , Option [] ["skip-perf"] (NoArg readTestSkipPerf)
+      "Skip performance tests."
+    , Option [] ["summary"] (OptArg readTestSummary "TEST_SUMMARY")
+      "Where to output the test summary file."
+    , Option [] ["summary-junit"] (OptArg readTestJUnit "TEST_SUMMARY_JUNIT")
+      "Output testsuite summary in JUnit format."
+    , Option [] ["config"] (OptArg readTestConfig "EXTRA_TEST_CONFIG")
+      "Configurations to run test, in key=value format." ]
 
 -- | A type-indexed map containing Hadrian command line arguments to be passed
 -- to Shake via 'shakeExtra'.
@@ -107,6 +157,7 @@ cmdLineArgsMap = do
     let args = foldl (flip id) defaultCommandLineArgs (rights opts)
     return $ insertExtra (progressColour args) -- Accessed by Hadrian.Utilities
            $ insertExtra (progressInfo   args) -- Accessed by Hadrian.Utilities
+           $ insertExtra (testArgs       args) -- Accessed by Settings.Builders.RunTest
            $ insertExtra args Map.empty
 
 cmdLineArgs :: Action CommandLineArgs

src/Hadrian/Utilities.hs

@@ -4,7 +4,7 @@ module Hadrian.Utilities (
     fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize,
 
     -- * String manipulation
-    quote, yesNo,
+    quote, yesNo, zeroOne,
 
     -- * FilePath manipulation
     unifyPath, (-/-),
@@ -13,7 +13,7 @@ module Hadrian.Utilities (
     insertExtra, lookupExtra, userSetting,
 
     -- * Paths
-    BuildRoot (..), buildRoot, isGeneratedSource,
+    BuildRoot (..), buildRoot, buildRootRules, isGeneratedSource,
 
     -- * File system operations
     copyFile, copyFileUntracked, fixFile, makeExecutable, moveFile, removeFile,
@@ -26,7 +26,6 @@ module Hadrian.Utilities (
     ProgressInfo (..), putProgressInfo,
     renderAction, renderProgram, renderLibrary, renderBox, renderUnicorn,
 
-
     -- * Miscellaneous
     (<&>), (%%>), cmdLineLengthLimit,
 
@@ -115,6 +114,11 @@ yesNo :: Bool -> String
 yesNo True  = "YES"
 yesNo False = "NO"
 
+-- | Pretty-print a `Bool` as a @"1"@ or @"0"@ string
+zeroOne :: Bool -> String
+zeroOne True = "1"
+zeroOne False = "0"
+
 -- | Normalise a path and convert all path separators to @/@, even on Windows.
 unifyPath :: FilePath -> FilePath
 unifyPath = toStandard . normaliseEx
@@ -168,6 +172,13 @@ userSetting defaultValue = do
     extra <- shakeExtra <$> getShakeOptions
     return $ lookupExtra defaultValue extra
 
+-- | Lookup a user setting in Shake's type-indexed map 'shakeExtra'. If the
+-- setting is not found, return the provided default value instead.
+userSettingRules :: Typeable a => a -> Rules a
+userSettingRules defaultValue = do
+    extra <- shakeExtra <$> getShakeOptionsRules
+    return $ lookupExtra defaultValue extra
+
 newtype BuildRoot = BuildRoot FilePath deriving Typeable
 
 -- | All build results are put into the 'buildRoot' directory.
@@ -176,6 +187,11 @@ buildRoot = do
     BuildRoot path <- userSetting (BuildRoot "")
     return path
 
+buildRootRules :: Rules FilePath
+buildRootRules = do
+    BuildRoot path <- userSettingRules (BuildRoot "")
+    return path
+
 -- | A version of 'fmap' with flipped arguments. Useful for manipulating values
 -- in context, e.g. 'buildRoot', as in the example below.
 --

src/Rules/Test.hs

@@ -1,17 +1,37 @@
-module Rules.Test (testRules) where
+module Rules.Test (testRules, runTestGhcFlags, timeoutProgPath) where
 
 import Base
 import Expression
-import Flavour
 import Oracles.Flag
 import Oracles.Setting
-import Settings
 import Target
 import Utilities
 
+import System.Environment
+
 -- TODO: clean up after testing
 testRules :: Rules ()
 testRules = do
+
+    root <- buildRootRules
+
+    root -/- timeoutPyPath ~> do
+        copyFile "testsuite/timeout/timeout.py" (root -/- timeoutPyPath)
+
+    -- TODO windows is still not supported.
+    --
+    -- See: https://github.com/ghc/ghc/blob/master/testsuite/timeout/Makefile#L23
+    root -/- timeoutProgPath ~> do
+        python <- builderPath Python
+        need [root -/- timeoutPyPath]
+        let script = unlines
+                [ "#!/usr/bin/env sh"
+                , "exec " ++ python ++ " $0.py \"$@\""
+                ]
+        liftIO $ do
+            writeFile (root -/- timeoutProgPath) script
+        makeExecutable (root -/- timeoutProgPath)
+
     "validate" ~> do
         need inplaceLibCopyTargets
         needBuilder $ Ghc CompileHs Stage2
@@ -24,49 +44,62 @@ testRules = do
         build $ target (vanillaContext Stage2 compiler) (Make "testsuite/tests") [] []
 
     "test" ~> do
-        pkgs     <- stagePackages Stage1
-        tests    <- filterM doesDirectoryExist $ concat
-                    [ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ]
-                    | pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ]
-        windows  <- windowsHost
-        top      <- topDirectory
-        compiler <- builderPath $ Ghc CompileHs Stage2
-        ghcPkg   <- builderPath $ GhcPkg Update Stage1
-        haddock  <- builderPath (Haddock BuildPackage)
-        threads  <- shakeThreads <$> getShakeOptions
-        debugged <- ghcDebugged <$> flavour
-        ghcWithNativeCodeGenInt <- fromEnum <$> ghcWithNativeCodeGen
-        ghcWithInterpreterInt   <- fromEnum <$> ghcWithInterpreter
-        ghcUnregisterisedInt    <- fromEnum <$> flag GhcUnregisterised
-        quietly . cmd "python2" $
-            [ "testsuite/driver/runtests.py" ]
-            ++ map ("--rootdir="++) tests ++
-            [ "-e", "windows=" ++ show windows
-            , "-e", "config.speed=2"
-            , "-e", "ghc_compiler_always_flags=" ++ show "-fforce-recomp -dcore-lint -dcmm-lint -dno-debug-output -no-user-package-db -rtsopts"
-            , "-e", "ghc_with_native_codegen=" ++ show ghcWithNativeCodeGenInt
-            , "-e", "ghc_debugged=" ++ show (yesNo debugged)
-            , "-e", "ghc_with_vanilla=1" -- TODO: do we always build vanilla?
-            , "-e", "ghc_with_dynamic=0" -- TODO: support dynamic
-            , "-e", "ghc_with_profiling=0" -- TODO: support profiling
-            , "-e", "ghc_with_interpreter=" ++ show ghcWithInterpreterInt
-            , "-e", "ghc_unregisterised=" ++ show ghcUnregisterisedInt
-            , "-e", "ghc_with_threaded_rts=0" -- TODO: support threaded
-            , "-e", "ghc_with_dynamic_rts=0" -- TODO: support dynamic
-            , "-e", "ghc_dynamic_by_default=False" -- TODO: support dynamic
-            , "-e", "ghc_dynamic=0" -- TODO: support dynamic
-            , "-e", "ghc_with_llvm=0" -- TODO: support LLVM
-            , "-e", "in_tree_compiler=True" -- TODO: when is it equal to False?
-            , "-e", "clean_only=False" -- TODO: do we need to support True?
-            , "--configfile=testsuite/config/ghc"
-            , "--config", "compiler=" ++ show (top -/- compiler)
-            , "--config", "ghc_pkg="  ++ show (top -/- ghcPkg)
-            , "--config", "haddock="  ++ show (top -/- haddock)
-            , "--summary-file", "testsuite_summary.txt"
-            , "--threads=" ++ show threads
-            ]
-
-            -- , "--config", "hp2ps="    ++ quote ("hp2ps")
-            -- , "--config", "hpc="      ++ quote ("hpc")
-            -- , "--config", "gs=$(call quote_path,$(GS))"
-            -- , "--config", "timeout_prog=$(call quote_path,$(TIMEOUT_PROGRAM))"
+        -- Prepare the timeout program.
+        need [ root -/- timeoutProgPath ]
+
+        -- TODO This approach doesn't work.
+        -- Set environment variables for test's Makefile.
+        env <- sequence
+            [ builderEnvironment "MAKE" $ Make ""
+            , builderEnvironment "TEST_HC" $ Ghc CompileHs Stage2
+            , AddEnv "TEST_HC_OPTS" <$> runTestGhcFlags ]
+
+        makePath       <- builderPath $ Make ""
+        top            <- topDirectory
+        ghcPath        <- (top -/-) <$> builderPath (Ghc CompileHs Stage2)
+        ghcFlags       <- runTestGhcFlags
+
+        -- Set environment variables for test's Makefile.
+        liftIO $ do
+            setEnv "MAKE" makePath
+            setEnv "TEST_HC" ghcPath
+            setEnv "TEST_HC_OPTS" ghcFlags
+
+        -- Execute the test target.
+        buildWithCmdOptions env $ target (vanillaContext Stage2 compiler) RunTest [] []
+
+-- | Extra flags to send to the Haskell compiler to run tests.
+runTestGhcFlags :: Action String
+runTestGhcFlags = do
+    unregisterised <- flag GhcUnregisterised
+
+    let ifMinGhcVer ver opt = do v <- ghcCanonVersion
+                                 if ver <= v then pure opt
+                                             else pure ""
+
+    -- Read extra argument for test from command line, like `-fvectorize`.
+    ghcOpts <- fromMaybe "" <$> (liftIO $ lookupEnv "EXTRA_HC_OPTS")
+
+    -- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L28
+    let ghcExtraFlags = if unregisterised
+                           then "-optc-fno-builtin"
+                           else ""
+
+    -- Take flags to send to the Haskell compiler from test.mk.
+    -- See: https://github.com/ghc/ghc/blob/master/testsuite/mk/test.mk#L37
+    unwords <$> sequence
+        [ pure " -dcore-lint -dcmm-lint -no-user-package-db -rtsopts"
+        , pure ghcOpts
+        , pure ghcExtraFlags
+        , ifMinGhcVer "711" "-fno-warn-missed-specialisations"
+        , ifMinGhcVer "711" "-fshow-warning-groups"
+        , ifMinGhcVer "801" "-fdiagnostics-color=never"
+        , ifMinGhcVer "801" "-fno-diagnostics-show-caret"
+        , pure "-dno-debug-output"
+        ]
+
+timeoutPyPath :: FilePath
+timeoutPyPath = "test/bin/timeout.py"
+
+timeoutProgPath :: FilePath
+timeoutProgPath = "test/bin/timeout" <.> exe