Fix timeout building rule for Linux (#638)

src/GHC.hs

@@ -105,15 +105,18 @@ stage2Packages = return [haddock]
 
 -- | Packages that are built only for the testsuite.
 testsuitePackages :: Action [Package]
-testsuitePackages = return [ checkApiAnnotations
-                           , checkPpr
-                           , ghci
-                           , ghcPkg
-                           , hp2ps
-                           , iserv
-                           , parallel
-                           , runGhc
-                           , timeout           ]
+testsuitePackages = do
+  win <- windowsHost
+  return $
+    [ checkApiAnnotations
+    , checkPpr
+    , ghci
+    , ghcPkg
+    , hp2ps
+    , iserv
+    , parallel
+    , runGhc              ] ++
+    [ timeout | win       ]
 
 -- | Given a 'Context', compute the name of the program that is built in it
 -- assuming that the corresponding package's type is 'Program'. For example, GHC

src/Rules/Test.hs

@@ -21,13 +21,15 @@ testRules = do
     root -/- ghcConfigProgPath ~> do
         ghc             <- builderPath $ Ghc CompileHs Stage0
         cmd ghc [ghcConfigHsPath, "-o" , root -/- ghcConfigProgPath]
- 
-    -- | TODO : Use input test compiler and not just stage2 compiler.  
+
+    -- | TODO : Use input test compiler and not just stage2 compiler.
     root -/- ghcConfigPath ~> do
         ghcPath         <- needfile Stage1 ghc
         need [ root -/- ghcConfigProgPath]
         cmd [FileStdout $ root -/- ghcConfigPath] (root -/- ghcConfigProgPath)
-            [ ghcPath  ] 
+            [ ghcPath  ]
+
+    root -/- timeoutProgPath ~> timeoutProgBuilder
 
     "validate" ~> do
         needTestBuilders
@@ -38,7 +40,7 @@ testRules = do
 
         -- TODO : Should we remove the previosly generated config file?
         -- Prepare Ghc configuration file for input compiler.
-        need [ root -/- ghcConfigPath ]
+        need [ root -/- ghcConfigPath, root -/- timeoutProgPath ]
 
         -- TODO This approach doesn't work.
         -- Set environment variables for test's Makefile.
@@ -93,13 +95,12 @@ timeoutProgBuilder = do
             copyFile prog (root -/- timeoutProgPath)
         else do
             python <- builderPath Python
-            copyFile "testsuite/timeout/timeout.py" (root -/- "test/bin/timeout.py")
+            copyFile "testsuite/timeout/timeout.py" (root -/- timeoutProgPath <.> "py")
             let script = unlines
                     [ "#!/usr/bin/env sh"
                     , "exec " ++ python ++ " $0.py \"$@\""
                     ]
-            liftIO $ do
-                writeFile (root -/- timeoutProgPath) script
+            writeFile' (root -/- timeoutProgPath) script
             makeExecutable (root -/- timeoutProgPath)
 
 needTestBuilders :: Action ()
@@ -108,7 +109,6 @@ needTestBuilders = do
     needBuilder $ GhcPkg Update Stage1
     needBuilder Hpc
     needBuilder (Hsc2Hs Stage1)
-    timeoutProgBuilder
     needTestsuitePackages
 
 -- | Extra flags to send to the Haskell compiler to run tests.
@@ -160,4 +160,3 @@ needfile stage pkg
 -- we are going to use, I suppose?
     | isLibrary pkg = pkgConfFile (Context stage pkg profilingDynamic)
     | otherwise = programPath =<< programContext stage pkg
-

src/Settings/Builders/RunTest.hs

@@ -103,7 +103,7 @@ getTestArgs = do
     args            <- expr $ userSetting defaultTestArgs
     bindir          <- expr $ setBinaryDirectory (testCompiler args)
     compiler        <- expr $ setCompiler (testCompiler args)
-    globalVerbosity <- shakeVerbosity <$> expr getShakeOptions 
+    globalVerbosity <- shakeVerbosity <$> expr getShakeOptions
     let configFileArg= ["--config-file=" ++ (testConfigFile args)]
         testOnlyArg  = case testOnly args of
                            Just cases -> map ("--only=" ++) (words cases)
@@ -125,30 +125,30 @@ getTestArgs = do
         verbosityArg = case testVerbosity args of
                            Nothing -> Just $ "--verbose=" ++ show (fromEnum globalVerbosity)
                            Just verbosity -> Just $ "--verbose=" ++ verbosity
-        wayArgs      = map ("--way=" ++) (testWays args) 
+        wayArgs      = map ("--way=" ++) (testWays args)
         compilerArg  = ["--config", "compiler=" ++ show (compiler)]
         ghcPkgArg    = ["--config", "ghc_pkg=" ++ show (bindir -/- "ghc-pkg")]
         haddockArg   = ["--config", "haddock=" ++ show (bindir -/- "haddock")]
         hp2psArg     = ["--config", "hp2ps=" ++ show (bindir -/- "hp2ps")]
-        hpcArg       = ["--config", "hpc=" ++ show (bindir -/- "hpc")]   
-    pure $  configFileArg ++ testOnlyArg ++ speedArg 
+        hpcArg       = ["--config", "hpc=" ++ show (bindir -/- "hpc")]
+    pure $  configFileArg ++ testOnlyArg ++ speedArg
          ++ catMaybes [ onlyPerfArg, skipPerfArg, summaryArg
-                      , junitArg, verbosityArg  ] 
+                      , junitArg, verbosityArg  ]
          ++ configArgs ++ wayArgs ++  compilerArg ++ ghcPkgArg
          ++ haddockArg ++ hp2psArg ++ hpcArg
 
 -- | Directory to look for Binaries
--- | We assume that required programs are present in the same binary directory 
+-- | We assume that required programs are present in the same binary directory
 -- | in which ghc is stored and that they have their conventional name.
 -- | QUESTION : packages can be named different from their conventional names.
 -- | For example, ghc-pkg can be named as ghc-pkg-version. In such cases, it will
--- | be impossible to search the binary. Only possible way will be to take user 
--- | inputs for these directory also. boilerplate soes not account for this 
+-- | be impossible to search the binary. Only possible way will be to take user
+-- | inputs for these directory also. boilerplate soes not account for this
 -- | problem, but simply returns an error. How should we handle such cases?
 setBinaryDirectory :: String -> Action FilePath
 setBinaryDirectory "stage0" = setting InstallBinDir
-setBinaryDirectory "stage1" = liftM2 (-/-) topDirectory (stageBinPath Stage0) 
-setBinaryDirectory "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1) 
+setBinaryDirectory "stage1" = liftM2 (-/-) topDirectory (stageBinPath Stage0)
+setBinaryDirectory "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1)
 setBinaryDirectory compiler = pure $ parentPath compiler
 
 -- | Set Test Compiler
@@ -156,7 +156,7 @@ setCompiler :: String -> Action FilePath
 setCompiler "stage0" = setting SystemGhc
 setCompiler "stage1" = liftM2 (-/-) topDirectory (fullpath Stage0 ghc)
 setCompiler "stage2" = liftM2 (-/-) topDirectory (fullpath Stage1 ghc)
-setCompiler compiler = pure compiler 
+setCompiler compiler = pure compiler
 
 -- | Set speed for test
 setTestSpeed :: TestSpeed -> String
@@ -164,7 +164,7 @@ setTestSpeed Fast    = "2"
 setTestSpeed Average = "1"
 setTestSpeed Slow    = "0"
 
--- | Returns parent path of test compiler 
+-- | Returns parent path of test compiler
 -- | TODO : Is there a simpler way to find parent directory?
 parentPath :: String -> String
 parentPath path = let upPath = init $ splitOn "/" path
@@ -173,4 +173,3 @@ parentPath path = let upPath = init $ splitOn "/" path
 -- | TODO: move to hadrian utilities.
 fullpath :: Stage -> Package -> Action FilePath
 fullpath stage pkg = programPath =<< programContext stage pkg
-