Commit 2fac0531 authored by Andrey Mokhov's avatar Andrey Mokhov Committed by GitHub

Fix warnings, improve comments and error handling, minor refactoring (#656)

parent 4265e3aa
......@@ -4,7 +4,7 @@ module Hadrian.Utilities (
fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize,
-- * String manipulation
quote, yesNo, zeroOne,
quote, yesNo, parseYesNo, zeroOne,
-- * FilePath manipulation
unifyPath, (-/-),
......@@ -105,7 +105,7 @@ chunksOfSize n = repeatedly f
where
f xs = splitAt (max 1 $ length $ takeWhile (<= n) $ scanl1 (+) $ map length xs) xs
-- | Add single quotes around a String.
-- | Add single quotes around a string.
quote :: String -> String
quote s = "'" ++ s ++ "'"
......@@ -114,10 +114,17 @@ yesNo :: Bool -> String
yesNo True = "YES"
yesNo False = "NO"
-- | Pretty-print a `Bool` as a @"1"@ or @"0"@ string
-- | Parse a 'Bool' from a @"YES"@ or @"NO"@ string. Returns @Nothing@ in case
-- of a parse failure.
parseYesNo :: String -> Maybe Bool
parseYesNo "YES" = Just True
parseYesNo "NO" = Just False
parseYesNo _ = Nothing
-- | Pretty-print a 'Bool' as a @"0"@ or @"1"@ string
zeroOne :: Bool -> String
zeroOne True = "1"
zeroOne False = "0"
zeroOne True = "1"
-- | Normalise a path and convert all path separators to @/@, even on Windows.
unifyPath :: FilePath -> FilePath
......
-- | We create a file <root>/test/ghcconfig containing configuration of test
-- | compiler. We need to search this file for required keys and setting
-- | required for testsuite e.g. WORDSIZE, HOSTOS etc.
-- | compiler. We need to search this file for required keys and setting
-- | required for testsuite e.g. WORDSIZE, HOSTOS etc.
module Oracles.TestSettings (
TestSetting (..), testSetting, testRTSSettings
) where
module Oracles.TestSettings (TestSetting (..), testSetting, testRTSSettings) where
import Hadrian.Oracles.TextFile
import Base
import Hadrian.Oracles.TextFile
testConfigFile :: Action FilePath
testConfigFile = buildRoot <&> (-/- "test/ghcconfig")
......@@ -36,18 +34,18 @@ data TestSetting = TestHostOS
| TestMinGhcVersion801
deriving (Show)
-- | Lookup for testsettings in ghcconfig file
-- | To obtain RTS Ways supported in ghcconfig file, use testRTSSettings.
-- | Lookup a test setting in @ghcconfig@ file.
-- | To obtain RTS ways supported in @ghcconfig@ file, use 'testRTSSettings'.
testSetting :: TestSetting -> Action String
testSetting key = do
file <- testConfigFile
lookupValueOrError file $ case key of
TestHostOS -> "HostOS"
TestWORDSIZE -> "WORDSIZE"
TestWORDSIZE -> "WORDSIZE"
TestTARGETPLATFORM -> "TARGETPLATFORM"
TestTargetOS_CPP -> "TargetOS_CPP"
TestTargetARCH_CPP -> "TargetARCH_CPP"
TestGhcStage -> "GhcStage"
TestGhcStage -> "GhcStage"
TestGhcDebugged -> "GhcDebugged"
TestGhcWithNativeCodeGen -> "GhcWithNativeCodeGen"
TestGhcWithInterpreter -> "GhcWithInterpreter"
......@@ -63,11 +61,9 @@ testSetting key = do
TestGhcPackageDbFlag -> "GhcPackageDbFlag"
TestMinGhcVersion711 -> "MinGhcVersion711"
TestMinGhcVersion801 -> "MinGhcVersion801"
-- | Get the RTS ways of the test compiler
testRTSSettings :: Action [String]
testRTSSettings = do
testRTSSettings = do
file <- testConfigFile
fmap words $ lookupValueOrError file "GhcRTSWays"
words <$> lookupValueOrError file "GhcRTSWays"
module Settings.Builders.RunTest (runTestBuilderArgs) where
import CommandLine (TestArgs(..), defaultTestArgs, TestSpeed(..))
import Context
import Flavour
import GHC
import Hadrian.Utilities
......@@ -10,21 +9,17 @@ import Oracles.TestSettings
import Rules.Test
import Settings.Builders.Common
oneZero :: String -> Bool -> String
oneZero lbl False = lbl ++ "=0"
oneZero lbl True = lbl ++ "=1"
getTestSetting :: TestSetting -> Expr String
getTestSetting key = expr $ testSetting key
stringToBool :: String -> Bool
stringToBool "YES" = True
stringToBool "NO" = False
-- | Parse the value of a Boolean test setting or report an error.
getBooleanSetting :: TestSetting -> Expr Bool
getBooleanSetting key = fromMaybe (error msg) <$> parseYesNo <$> getTestSetting key
where
msg = "Cannot parse test setting " ++ quote (show key)
-- | An abstraction to get boolean value of some settings
getBooleanSetting :: TestSetting -> Action Bool
getBooleanSetting key = fmap stringToBool $ testSetting key
-- Arguments to send to the runtest.py script.
--
-- A lot of this mirrors what's achieved at testsuite/mk/test.mk.
-- Command line arguments for invoking the @runtest.py@ script. A lot of this
-- mirrors @testsuite/mk/test.mk@.
runTestBuilderArgs :: Args
runTestBuilderArgs = builder RunTest ? do
pkgs <- expr $ stagePackages Stage1
......@@ -32,59 +27,62 @@ runTestBuilderArgs = builder RunTest ? do
[ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ]
| pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ]
flav <- expr flavour
rtsways <- expr $ testRTSSettings
libways <- libraryWays flav
let hasRtsWay w = elem w rtsways
hasLibWay w = elem w libways
debugged = ghcDebugged flav
hasDynamic <- expr $ getBooleanSetting TestGhcDynamic
hasDynamicByDefault <- expr $ getBooleanSetting TestGhcDynamicByDefault
withNativeCodeGen <- expr $ getBooleanSetting TestGhcWithNativeCodeGen
withInterpreter <- expr $ getBooleanSetting TestGhcWithInterpreter
unregisterised <- expr $ getBooleanSetting TestGhcUnregisterised
withSMP <- expr $ getBooleanSetting TestGhcWithSMP
windows <- expr windowsHost
darwin <- expr osxHost
threads <- shakeThreads <$> expr getShakeOptions
os <- expr $ testSetting TestHostOS
arch <- expr $ testSetting TestTargetARCH_CPP
platform <- expr $ testSetting TestTARGETPLATFORM
wordsize <- expr $ testSetting TestWORDSIZE
top <- expr topDirectory
flav <- expr flavour
rtsWays <- expr testRTSSettings
libWays <- libraryWays flav
let hasRtsWay w = elem w rtsWays
hasLibWay w = elem w libWays
debugged = ghcDebugged flav
hasDynamic <- getBooleanSetting TestGhcDynamic
hasDynamicByDefault <- getBooleanSetting TestGhcDynamicByDefault
withNativeCodeGen <- getBooleanSetting TestGhcWithNativeCodeGen
withInterpreter <- getBooleanSetting TestGhcWithInterpreter
unregisterised <- getBooleanSetting TestGhcUnregisterised
withSMP <- getBooleanSetting TestGhcWithSMP
windows <- expr windowsHost
darwin <- expr osxHost
threads <- shakeThreads <$> expr getShakeOptions
os <- getTestSetting TestHostOS
arch <- getTestSetting TestTargetARCH_CPP
platform <- getTestSetting TestTARGETPLATFORM
wordsize <- getTestSetting TestWORDSIZE
top <- expr $ topDirectory
ghcFlags <- expr runTestGhcFlags
timeoutProg <- expr buildRoot <&> (-/- timeoutProgPath)
-- TODO: set CABAL_MINIMAL_BUILD/CABAL_PLUGIN_BUILD
let asZeroOne s b = s ++ zeroOne b
-- TODO: set CABAL_MINIMAL_BUILD/CABAL_PLUGIN_BUILD
mconcat [ arg $ "testsuite/driver/runtests.py"
, arg $ "--rootdir=" ++ ("testsuite" -/- "tests")
, pure ["--rootdir=" ++ test | test <- libTests]
, arg "-e", arg $ "windows=" ++ show windows
, arg "-e", arg $ "darwin=" ++ show darwin
, arg "-e", arg $ "config.local=True"
, arg "-e", arg $ "config.cleanup=False" -- Don't clean up.
, arg "-e", arg $ "config.cleanup=False" -- Don't clean up.
, arg "-e", arg $ "config.compiler_debugged=" ++ quote (yesNo debugged)
, arg "-e", arg $ "ghc_debugged=" ++ quote (yesNo debugged)
, arg "-e", arg $ oneZero "ghc_with_native_codegen" withNativeCodeGen
, arg "-e", arg $ asZeroOne "ghc_with_native_codegen" withNativeCodeGen
, arg "-e", arg $ "config.have_interp=" ++ show withInterpreter
, arg "-e", arg $ "config.unregisterised=" ++ show unregisterised
, arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags
, arg "-e", arg $ oneZero "ghc_with_dynamic_rts" (hasRtsWay "dyn")
, arg "-e", arg $ oneZero "ghc_with_threaded_rts" (hasRtsWay "thr")
, arg "-e", arg $ oneZero "config.have_vanilla" (hasLibWay vanilla)
, arg "-e", arg $ oneZero "config.have_dynamic" (hasLibWay dynamic)
, arg "-e", arg $ oneZero "config.have_profiling" (hasLibWay profiling)
, arg "-e", arg $ oneZero "ghc_with_smp" withSMP
, arg "-e", arg $ "ghc_with_llvm=0" -- TODO: support LLVM
, arg "-e", arg $ asZeroOne "ghc_with_dynamic_rts" (hasRtsWay "dyn")
, arg "-e", arg $ asZeroOne "ghc_with_threaded_rts" (hasRtsWay "thr")
, arg "-e", arg $ asZeroOne "config.have_vanilla" (hasLibWay vanilla)
, arg "-e", arg $ asZeroOne "config.have_dynamic" (hasLibWay dynamic)
, arg "-e", arg $ asZeroOne "config.have_profiling" (hasLibWay profiling)
, arg "-e", arg $ asZeroOne "ghc_with_smp" withSMP
, arg "-e", arg $ "ghc_with_llvm=0" -- TODO: support LLVM
, arg "-e", arg $ "config.ghc_dynamic_by_default=" ++ show hasDynamicByDefault
, arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic
, arg "-e", arg $ "config.in_tree_compiler=True" -- Use default value, see https://github.com/ghc/ghc/blob/master/testsuite/mk/boilerplate.mk
-- Use default value, see:
-- https://github.com/ghc/ghc/blob/master/testsuite/mk/boilerplate.mk
, arg "-e", arg $ "config.in_tree_compiler=True"
, arg "-e", arg $ "config.top=" ++ show (top -/- "testsuite")
, arg "-e", arg $ "config.wordsize=" ++ show wordsize
, arg "-e", arg $ "config.os=" ++ show os
......@@ -97,7 +95,7 @@ runTestBuilderArgs = builder RunTest ? do
, getTestArgs -- User-provided arguments from command line.
]
-- | Prepare the command-line arguments to run GHC's test script.
-- | Command line arguments for running GHC's test script.
getTestArgs :: Args
getTestArgs = do
args <- expr $ userSetting defaultTestArgs
......@@ -137,6 +135,7 @@ getTestArgs = do
++ configArgs ++ wayArgs ++ compilerArg ++ ghcPkgArg
++ haddockArg ++ hp2psArg ++ hpcArg
-- TODO: Switch to 'Stage' as the first argument instead of 'String'.
-- | Directory to look for Binaries
-- | We assume that required programs are present in the same binary directory
-- | in which ghc is stored and that they have their conventional name.
......@@ -151,25 +150,25 @@ setBinaryDirectory "stage1" = liftM2 (-/-) topDirectory (stageBinPath Stage0)
setBinaryDirectory "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1)
setBinaryDirectory compiler = pure $ parentPath compiler
-- | Set Test Compiler
-- TODO: Switch to 'Stage' as the first argument instead of 'String'.
-- | Set Test Compiler.
setCompiler :: String -> Action FilePath
setCompiler "stage0" = setting SystemGhc
setCompiler "stage1" = liftM2 (-/-) topDirectory (fullpath Stage0 ghc)
setCompiler "stage2" = liftM2 (-/-) topDirectory (fullpath Stage1 ghc)
setCompiler "stage1" = liftM2 (-/-) topDirectory (fullPath Stage0 ghc)
setCompiler "stage2" = liftM2 (-/-) topDirectory (fullPath Stage1 ghc)
setCompiler compiler = pure compiler
-- | Set speed for test
setTestSpeed :: TestSpeed -> String
setTestSpeed Fast = "2"
setTestSpeed Average = "1"
setTestSpeed Slow = "0"
setTestSpeed Average = "1"
setTestSpeed Fast = "2"
-- | Returns parent path of test compiler
-- | TODO : Is there a simpler way to find parent directory?
-- | TODO: Is there a simpler way to find parent directory?
parentPath :: String -> String
parentPath path = let upPath = init $ splitOn "/" path
in intercalate "/" upPath
parentPath path = intercalate "/" $ init $ splitOn "/" path
-- | TODO: move to hadrian utilities.
fullpath :: Stage -> Package -> Action FilePath
fullpath stage pkg = programPath =<< programContext stage pkg
-- | TODO: Move to Hadrian utilities.
fullPath :: Stage -> Package -> Action FilePath
fullPath stage pkg = programPath =<< programContext stage pkg
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment