Remove more validation errors (#628)
[hadrian.git] / src / Settings / Builders / RunTest.hs
1 module Settings.Builders.RunTest (runTestBuilderArgs) where
2
3 import CommandLine (TestArgs(..), defaultTestArgs, TestSpeed(..))
4 import Context
5 import Flavour
6 import GHC
7 import Hadrian.Utilities
8 import Oracles.Setting (setting)
9 import Oracles.TestSettings
10 import Rules.Test
11 import Settings.Builders.Common
12
13 oneZero :: String -> Bool -> String
14 oneZero lbl False = lbl ++ "=0"
15 oneZero lbl True = lbl ++ "=1"
16
17 stringToBool :: String -> Bool
18 stringToBool "YES" = True
19 stringToBool "NO" = False
20
21 -- | An abstraction to get boolean value of some settings
22 getBooleanSetting :: TestSetting -> Action Bool
23 getBooleanSetting key = fmap stringToBool $ testSetting key
24
25 -- Arguments to send to the runtest.py script.
26 --
27 -- A lot of this mirrors what's achieved at testsuite/mk/test.mk.
28 runTestBuilderArgs :: Args
29 runTestBuilderArgs = builder RunTest ? do
30 pkgs <- expr $ stagePackages Stage1
31 libTests <- expr $ filterM doesDirectoryExist $ concat
32 [ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ]
33 | pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ]
34
35 flav <- expr flavour
36 rtsways <- expr $ testRTSSettings
37 libways <- libraryWays flav
38 let hasRtsWay w = elem w rtsways
39 hasLibWay w = elem w libways
40 debugged = ghcDebugged flav
41 hasDynamic <- expr $ getBooleanSetting TestGhcDynamic
42 hasDynamicByDefault <- expr $ getBooleanSetting TestGhcDynamicByDefault
43 withNativeCodeGen <- expr $ getBooleanSetting TestGhcWithNativeCodeGen
44 withInterpreter <- expr $ getBooleanSetting TestGhcWithInterpreter
45 unregisterised <- expr $ getBooleanSetting TestGhcUnregisterised
46 withSMP <- expr $ getBooleanSetting TestGhcWithSMP
47
48 windows <- expr windowsHost
49 darwin <- expr osxHost
50 threads <- shakeThreads <$> expr getShakeOptions
51 os <- expr $ testSetting TestHostOS
52 arch <- expr $ testSetting TestTargetARCH_CPP
53 platform <- expr $ testSetting TestTARGETPLATFORM
54 wordsize <- expr $ testSetting TestWORDSIZE
55 top <- expr topDirectory
56 ghcFlags <- expr runTestGhcFlags
57 timeoutProg <- expr buildRoot <&> (-/- timeoutProgPath)
58
59 -- TODO: set CABAL_MINIMAL_BUILD/CABAL_PLUGIN_BUILD
60
61 mconcat [ arg $ "testsuite/driver/runtests.py"
62 , arg $ "--rootdir=" ++ ("testsuite" -/- "tests")
63 , pure ["--rootdir=" ++ test | test <- libTests]
64 , arg "-e", arg $ "windows=" ++ show windows
65 , arg "-e", arg $ "darwin=" ++ show darwin
66 , arg "-e", arg $ "config.local=True"
67 , arg "-e", arg $ "config.cleanup=False" -- Don't clean up.
68 , arg "-e", arg $ "config.compiler_debugged=" ++ quote (yesNo debugged)
69 , arg "-e", arg $ "ghc_debugged=" ++ quote (yesNo debugged)
70 , arg "-e", arg $ oneZero "ghc_with_native_codegen" withNativeCodeGen
71
72 , arg "-e", arg $ "config.have_interp=" ++ show withInterpreter
73 , arg "-e", arg $ "config.unregisterised=" ++ show unregisterised
74
75 , arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags
76 , arg "-e", arg $ oneZero "ghc_with_dynamic_rts" (hasRtsWay "dyn")
77 , arg "-e", arg $ oneZero "ghc_with_threaded_rts" (hasRtsWay "thr")
78 , arg "-e", arg $ oneZero "config.have_vanilla" (hasLibWay vanilla)
79 , arg "-e", arg $ oneZero "config.have_dynamic" (hasLibWay dynamic)
80 , arg "-e", arg $ oneZero "config.have_profiling" (hasLibWay profiling)
81 , arg "-e", arg $ oneZero "ghc_with_smp" withSMP
82 , arg "-e", arg $ "ghc_with_llvm=0" -- TODO: support LLVM
83
84 , arg "-e", arg $ "config.ghc_dynamic_by_default=" ++ show hasDynamicByDefault
85 , arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic
86
87 , arg "-e", arg $ "config.in_tree_compiler=True" -- Use default value, see https://github.com/ghc/ghc/blob/master/testsuite/mk/boilerplate.mk
88 , arg "-e", arg $ "config.top=" ++ show (top -/- "testsuite")
89 , arg "-e", arg $ "config.wordsize=" ++ show wordsize
90 , arg "-e", arg $ "config.os=" ++ show os
91 , arg "-e", arg $ "config.arch=" ++ show arch
92 , arg "-e", arg $ "config.platform=" ++ show platform
93
94 , arg "--config", arg $ "gs=gs" -- Use the default value as in test.mk
95 , arg "--config", arg $ "timeout_prog=" ++ show (top -/- timeoutProg)
96 , arg $ "--threads=" ++ show threads
97 , getTestArgs -- User-provided arguments from command line.
98 ]
99
100 -- | Prepare the command-line arguments to run GHC's test script.
101 getTestArgs :: Args
102 getTestArgs = do
103 args <- expr $ userSetting defaultTestArgs
104 bindir <- expr $ setBinaryDirectory (testCompiler args)
105 compiler <- expr $ setCompiler (testCompiler args)
106 globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
107 let configFileArg= ["--config-file=" ++ (testConfigFile args)]
108 testOnlyArg = case testOnly args of
109 Just cases -> map ("--only=" ++) (words cases)
110 Nothing -> []
111 onlyPerfArg = if testOnlyPerf args
112 then Just "--only-perf-tests"
113 else Nothing
114 skipPerfArg = if testSkipPerf args
115 then Just "--skip-perf-tests"
116 else Nothing
117 speedArg = ["-e", "config.speed=" ++ setTestSpeed (testSpeed args)]
118 summaryArg = case testSummary args of
119 Just filepath -> Just $ "--summary-file" ++ quote filepath
120 Nothing -> Just $ "--summary-file=testsuite_summary.txt"
121 junitArg = case testJUnit args of
122 Just filepath -> Just $ "--junit " ++ quote filepath
123 Nothing -> Nothing
124 configArgs = concat [["-e", configArg] | configArg <- testConfigs args]
125 verbosityArg = case testVerbosity args of
126 Nothing -> Just $ "--verbose=" ++ show (fromEnum globalVerbosity)
127 Just verbosity -> Just $ "--verbose=" ++ verbosity
128 wayArgs = map ("--way=" ++) (testWays args)
129 compilerArg = ["--config", "compiler=" ++ show (compiler)]
130 ghcPkgArg = ["--config", "ghc_pkg=" ++ show (bindir -/- "ghc-pkg")]
131 haddockArg = ["--config", "haddock=" ++ show (bindir -/- "haddock")]
132 hp2psArg = ["--config", "hp2ps=" ++ show (bindir -/- "hp2ps")]
133 hpcArg = ["--config", "hpc=" ++ show (bindir -/- "hpc")]
134 pure $ configFileArg ++ testOnlyArg ++ speedArg
135 ++ catMaybes [ onlyPerfArg, skipPerfArg, summaryArg
136 , junitArg, verbosityArg ]
137 ++ configArgs ++ wayArgs ++ compilerArg ++ ghcPkgArg
138 ++ haddockArg ++ hp2psArg ++ hpcArg
139
140 -- | Directory to look for Binaries
141 -- | We assume that required programs are present in the same binary directory
142 -- | in which ghc is stored and that they have their conventional name.
143 -- | QUESTION : packages can be named different from their conventional names.
144 -- | For example, ghc-pkg can be named as ghc-pkg-version. In such cases, it will
145 -- | be impossible to search the binary. Only possible way will be to take user
146 -- | inputs for these directory also. boilerplate soes not account for this
147 -- | problem, but simply returns an error. How should we handle such cases?
148 setBinaryDirectory :: String -> Action FilePath
149 setBinaryDirectory "stage0" = setting InstallBinDir
150 setBinaryDirectory "stage1" = liftM2 (-/-) topDirectory (stageBinPath Stage0)
151 setBinaryDirectory "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1)
152 setBinaryDirectory compiler = pure $ parentPath compiler
153
154 -- | Set Test Compiler
155 setCompiler :: String -> Action FilePath
156 setCompiler "stage0" = setting SystemGhc
157 setCompiler "stage1" = liftM2 (-/-) topDirectory (fullpath Stage0 ghc)
158 setCompiler "stage2" = liftM2 (-/-) topDirectory (fullpath Stage1 ghc)
159 setCompiler compiler = pure compiler
160
161 -- | Set speed for test
162 setTestSpeed :: TestSpeed -> String
163 setTestSpeed Fast = "2"
164 setTestSpeed Average = "1"
165 setTestSpeed Slow = "0"
166
167 -- | Returns parent path of test compiler
168 -- | TODO : Is there a simpler way to find parent directory?
169 parentPath :: String -> String
170 parentPath path = let upPath = init $ splitOn "/" path
171 in intercalate "/" upPath
172
173 -- | TODO: move to hadrian utilities.
174 fullpath :: Stage -> Package -> Action FilePath
175 fullpath stage pkg = programPath =<< programContext stage pkg
176