Hadrian: various improvements around the 'test' rule
[ghc.git] / hadrian / src / Rules / Test.hs
1 module Rules.Test (testRules) where
2
3 import System.Environment
4
5 import Base
6 import CommandLine
7 import Expression
8 import Flavour
9 import Oracles.Setting
10 import Oracles.TestSettings
11 import Packages
12 import Settings
13 import Settings.Default
14 import Settings.Builders.RunTest
15 import Target
16 import Utilities
17
18 ghcConfigHsPath :: FilePath
19 ghcConfigHsPath = "testsuite/mk/ghc-config.hs"
20
21 ghcConfigProgPath :: FilePath
22 ghcConfigProgPath = "test/bin/ghc-config" <.> exe
23
24 checkPprProgPath, checkPprSourcePath :: FilePath
25 checkPprProgPath = "test/bin/check-ppr" <.> exe
26 checkPprSourcePath = "utils/check-ppr/Main.hs"
27
28 checkApiAnnotationsProgPath, checkApiAnnotationsSourcePath :: FilePath
29 checkApiAnnotationsProgPath = "test/bin/check-api-annotations" <.> exe
30 checkApiAnnotationsSourcePath = "utils/check-api-annotations/Main.hs"
31
32 checkPrograms :: [(FilePath, FilePath)]
33 checkPrograms =
34 [ (checkPprProgPath, checkPprSourcePath)
35 , (checkApiAnnotationsProgPath, checkApiAnnotationsSourcePath)
36 ]
37
38 ghcConfigPath :: FilePath
39 ghcConfigPath = "test/ghcconfig"
40
41 -- TODO: clean up after testing
42 testRules :: Rules ()
43 testRules = do
44 root <- buildRootRules
45
46 -- Using program shipped with testsuite to generate ghcconfig file.
47 root -/- ghcConfigProgPath %> \_ -> do
48 ghc0Path <- (<.> exe) <$> getCompilerPath "stage0"
49 cmd [ghc0Path] [ghcConfigHsPath, "-o" , root -/- ghcConfigProgPath]
50
51 -- Rules for building check-ppr and check-ppr-annotations with the compiler
52 -- we are going to test (in-tree or out-of-tree).
53 forM_ checkPrograms $ \(progPath, sourcePath) ->
54 root -/- progPath %> \path -> do
55 testGhc <- testCompiler <$> userSetting defaultTestArgs
56 top <- topDirectory
57 when (testGhc `elem` ["stage1", "stage2", "stage3"]) $ do
58 let stg = stageOf testGhc
59 need . (:[]) =<< programPath (Context stg ghc vanilla)
60 bindir <- getBinaryDirectory testGhc
61 cmd [bindir </> "ghc" <.> exe]
62 ["-package", "ghc", "-o", top -/- path, top -/- sourcePath]
63
64 root -/- ghcConfigPath %> \_ -> do
65 args <- userSetting defaultTestArgs
66 let testGhc = testCompiler args
67 stg = stageOf testGhc
68 ghcPath <- getCompilerPath testGhc
69 when (testGhc `elem` ["stage1", "stage2", "stage3"]) $
70 need . (:[]) =<< programPath (Context stg ghc vanilla)
71 need [root -/- ghcConfigProgPath]
72 cmd [FileStdout $ root -/- ghcConfigPath] (root -/- ghcConfigProgPath)
73 [ghcPath]
74
75 root -/- timeoutPath %> \_ -> timeoutProgBuilder
76
77 "test" ~> do
78 needTestBuilders
79
80 -- TODO : Should we remove the previosly generated config file?
81 -- Prepare Ghc configuration file for input compiler.
82 need [root -/- ghcConfigPath, root -/- timeoutPath]
83
84 args <- userSetting defaultTestArgs
85 ghcPath <- getCompilerPath (testCompiler args)
86
87 -- TODO This approach doesn't work.
88 -- Set environment variables for test's Makefile.
89 env <- sequence
90 [ builderEnvironment "MAKE" $ Make ""
91 , builderEnvironment "TEST_HC" $ Ghc CompileHs Stage2
92 , AddEnv "TEST_HC_OPTS" <$> runTestGhcFlags ]
93
94 makePath <- builderPath $ Make ""
95 top <- topDirectory
96 ghcFlags <- runTestGhcFlags
97 let ghciFlags = ghcFlags ++ unwords
98 [ "--interactive", "-v0", "-ignore-dot-ghci"
99 , "-fno-ghci-history"
100 ]
101
102 pythonPath <- builderPath Python
103 need [ root -/- checkPprProgPath, root -/- checkApiAnnotationsProgPath ]
104
105 -- Set environment variables for test's Makefile.
106 -- TODO: Ideally we would define all those env vars in 'env', so that
107 -- Shake can keep track of them, but it is not as easy as it seems
108 -- to get that to work.
109 liftIO $ do
110 setEnv "MAKE" makePath
111 setEnv "PYTHON" pythonPath
112 setEnv "TEST_HC" ghcPath
113 setEnv "TEST_HC_OPTS" ghcFlags
114 setEnv "TEST_HC_OPTS_INTERACTIVE" ghciFlags
115 setEnv "CHECK_PPR" (top -/- root -/- checkPprProgPath)
116 setEnv "CHECK_API_ANNOTATIONS"
117 (top -/- root -/- checkApiAnnotationsProgPath)
118
119 -- Execute the test target.
120 -- We override the verbosity setting to make sure the user can see
121 -- the test output: https://ghc.haskell.org/trac/ghc/ticket/15951.
122 withVerbosity Loud $ buildWithCmdOptions env $
123 target (vanillaContext Stage2 compiler) RunTest [] []
124
125 -- | Build the timeout program.
126 -- See: https://github.com/ghc/ghc/blob/master/testsuite/timeout/Makefile#L23
127 timeoutProgBuilder :: Action ()
128 timeoutProgBuilder = do
129 root <- buildRoot
130 windows <- windowsHost
131 if windows
132 then do
133 prog <- programPath =<< programContext Stage1 timeout
134 copyFile prog (root -/- timeoutPath)
135 else do
136 python <- builderPath Python
137 copyFile "testsuite/timeout/timeout.py" (root -/- timeoutPath <.> "py")
138 let script = unlines
139 [ "#!/usr/bin/env sh"
140 , "exec " ++ python ++ " $0.py \"$@\"" ]
141 writeFile' (root -/- timeoutPath) script
142 makeExecutable (root -/- timeoutPath)
143
144 needTestBuilders :: Action ()
145 needTestBuilders = do
146 testGhc <- testCompiler <$> userSetting defaultTestArgs
147 when (testGhc `elem` ["stage1", "stage2", "stage3"]) needTestsuitePackages
148
149 -- | Build extra programs and libraries required by testsuite
150 needTestsuitePackages :: Action ()
151 needTestsuitePackages = do
152 testGhc <- testCompiler <$> userSetting defaultTestArgs
153 when (testGhc `elem` ["stage1", "stage2", "stage3"]) $ do
154 let stg = stageOf testGhc
155 allpkgs <- packages <$> flavour
156 stgpkgs <- allpkgs (succ stg)
157 testpkgs <- testsuitePackages
158 targets <- mapM (needFile stg) (stgpkgs ++ testpkgs)
159 needIservBins
160 need targets
161
162 -- stage 1 ghc lives under stage0/bin,
163 -- stage 2 ghc lives under stage1/bin, etc
164 stageOf :: String -> Stage
165 stageOf "stage1" = Stage0
166 stageOf "stage2" = Stage1
167 stageOf "stage3" = Stage2
168 stageOf _ = error "unexpected stage argument"
169
170 needIservBins :: Action ()
171 needIservBins = do
172 -- iserv is not supported under Windows
173 windows <- windowsHost
174 when (not windows) $ do
175 testGhc <- testCompiler <$> userSetting defaultTestArgs
176 let stg = stageOf testGhc
177 rtsways <- interpretInContext (vanillaContext stg ghc) getRtsWays
178 need =<< traverse programPath
179 [ Context stg iserv w
180 | w <- [vanilla, profiling, dynamic]
181 , w `elem` rtsways
182 ]
183
184 needFile :: Stage -> Package -> Action FilePath
185 needFile stage pkg
186 | isLibrary pkg = pkgConfFile (Context stage pkg profilingDynamic)
187 | otherwise = programPath =<< programContext stage pkg