Unverified 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 ( ...@@ -4,7 +4,7 @@ module Hadrian.Utilities (
fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize, fromSingleton, replaceEq, minusOrd, intersectOrd, lookupAll, chunksOfSize,
-- * String manipulation -- * String manipulation
quote, yesNo, zeroOne, quote, yesNo, parseYesNo, zeroOne,
-- * FilePath manipulation -- * FilePath manipulation
unifyPath, (-/-), unifyPath, (-/-),
...@@ -105,7 +105,7 @@ chunksOfSize n = repeatedly f ...@@ -105,7 +105,7 @@ chunksOfSize n = repeatedly f
where where
f xs = splitAt (max 1 $ length $ takeWhile (<= n) $ scanl1 (+) $ map length xs) xs 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 :: String -> String
quote s = "'" ++ s ++ "'" quote s = "'" ++ s ++ "'"
...@@ -114,10 +114,17 @@ yesNo :: Bool -> String ...@@ -114,10 +114,17 @@ yesNo :: Bool -> String
yesNo True = "YES" yesNo True = "YES"
yesNo False = "NO" 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 :: Bool -> String
zeroOne True = "1"
zeroOne False = "0" zeroOne False = "0"
zeroOne True = "1"
-- | Normalise a path and convert all path separators to @/@, even on Windows. -- | Normalise a path and convert all path separators to @/@, even on Windows.
unifyPath :: FilePath -> FilePath unifyPath :: FilePath -> FilePath
......
-- | We create a file <root>/test/ghcconfig containing configuration of test -- | We create a file <root>/test/ghcconfig containing configuration of test
-- | compiler. We need to search this file for required keys and setting -- | compiler. We need to search this file for required keys and setting
-- | required for testsuite e.g. WORDSIZE, HOSTOS etc. -- | required for testsuite e.g. WORDSIZE, HOSTOS etc.
module Oracles.TestSettings ( module Oracles.TestSettings (TestSetting (..), testSetting, testRTSSettings) where
TestSetting (..), testSetting, testRTSSettings
) where
import Hadrian.Oracles.TextFile
import Base import Base
import Hadrian.Oracles.TextFile
testConfigFile :: Action FilePath testConfigFile :: Action FilePath
testConfigFile = buildRoot <&> (-/- "test/ghcconfig") testConfigFile = buildRoot <&> (-/- "test/ghcconfig")
...@@ -36,18 +34,18 @@ data TestSetting = TestHostOS ...@@ -36,18 +34,18 @@ data TestSetting = TestHostOS
| TestMinGhcVersion801 | TestMinGhcVersion801
deriving (Show) deriving (Show)
-- | Lookup for testsettings in ghcconfig file -- | Lookup a test setting in @ghcconfig@ file.
-- | To obtain RTS Ways supported in ghcconfig file, use testRTSSettings. -- | To obtain RTS ways supported in @ghcconfig@ file, use 'testRTSSettings'.
testSetting :: TestSetting -> Action String testSetting :: TestSetting -> Action String
testSetting key = do testSetting key = do
file <- testConfigFile file <- testConfigFile
lookupValueOrError file $ case key of lookupValueOrError file $ case key of
TestHostOS -> "HostOS" TestHostOS -> "HostOS"
TestWORDSIZE -> "WORDSIZE" TestWORDSIZE -> "WORDSIZE"
TestTARGETPLATFORM -> "TARGETPLATFORM" TestTARGETPLATFORM -> "TARGETPLATFORM"
TestTargetOS_CPP -> "TargetOS_CPP" TestTargetOS_CPP -> "TargetOS_CPP"
TestTargetARCH_CPP -> "TargetARCH_CPP" TestTargetARCH_CPP -> "TargetARCH_CPP"
TestGhcStage -> "GhcStage" TestGhcStage -> "GhcStage"
TestGhcDebugged -> "GhcDebugged" TestGhcDebugged -> "GhcDebugged"
TestGhcWithNativeCodeGen -> "GhcWithNativeCodeGen" TestGhcWithNativeCodeGen -> "GhcWithNativeCodeGen"
TestGhcWithInterpreter -> "GhcWithInterpreter" TestGhcWithInterpreter -> "GhcWithInterpreter"
...@@ -63,11 +61,9 @@ testSetting key = do ...@@ -63,11 +61,9 @@ testSetting key = do
TestGhcPackageDbFlag -> "GhcPackageDbFlag" TestGhcPackageDbFlag -> "GhcPackageDbFlag"
TestMinGhcVersion711 -> "MinGhcVersion711" TestMinGhcVersion711 -> "MinGhcVersion711"
TestMinGhcVersion801 -> "MinGhcVersion801" TestMinGhcVersion801 -> "MinGhcVersion801"
-- | Get the RTS ways of the test compiler -- | Get the RTS ways of the test compiler
testRTSSettings :: Action [String] testRTSSettings :: Action [String]
testRTSSettings = do testRTSSettings = do
file <- testConfigFile file <- testConfigFile
fmap words $ lookupValueOrError file "GhcRTSWays" words <$> lookupValueOrError file "GhcRTSWays"
module Settings.Builders.RunTest (runTestBuilderArgs) where module Settings.Builders.RunTest (runTestBuilderArgs) where
import CommandLine (TestArgs(..), defaultTestArgs, TestSpeed(..)) import CommandLine (TestArgs(..), defaultTestArgs, TestSpeed(..))
import Context
import Flavour import Flavour
import GHC import GHC
import Hadrian.Utilities import Hadrian.Utilities
...@@ -10,21 +9,17 @@ import Oracles.TestSettings ...@@ -10,21 +9,17 @@ import Oracles.TestSettings
import Rules.Test import Rules.Test
import Settings.Builders.Common import Settings.Builders.Common
oneZero :: String -> Bool -> String getTestSetting :: TestSetting -> Expr String
oneZero lbl False = lbl ++ "=0" getTestSetting key = expr $ testSetting key
oneZero lbl True = lbl ++ "=1"
stringToBool :: String -> Bool -- | Parse the value of a Boolean test setting or report an error.
stringToBool "YES" = True getBooleanSetting :: TestSetting -> Expr Bool
stringToBool "NO" = False 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 -- Command line arguments for invoking the @runtest.py@ script. A lot of this
getBooleanSetting :: TestSetting -> Action Bool -- mirrors @testsuite/mk/test.mk@.
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.
runTestBuilderArgs :: Args runTestBuilderArgs :: Args
runTestBuilderArgs = builder RunTest ? do runTestBuilderArgs = builder RunTest ? do
pkgs <- expr $ stagePackages Stage1 pkgs <- expr $ stagePackages Stage1
...@@ -32,59 +27,62 @@ runTestBuilderArgs = builder RunTest ? do ...@@ -32,59 +27,62 @@ runTestBuilderArgs = builder RunTest ? do
[ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ] [ [ pkgPath pkg -/- "tests", pkgPath pkg -/- "tests-ghc" ]
| pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ] | pkg <- pkgs, isLibrary pkg, pkg /= rts, pkg /= libffi ]
flav <- expr flavour flav <- expr flavour
rtsways <- expr $ testRTSSettings rtsWays <- expr testRTSSettings
libways <- libraryWays flav libWays <- libraryWays flav
let hasRtsWay w = elem w rtsways let hasRtsWay w = elem w rtsWays
hasLibWay w = elem w libways hasLibWay w = elem w libWays
debugged = ghcDebugged flav debugged = ghcDebugged flav
hasDynamic <- expr $ getBooleanSetting TestGhcDynamic hasDynamic <- getBooleanSetting TestGhcDynamic
hasDynamicByDefault <- expr $ getBooleanSetting TestGhcDynamicByDefault hasDynamicByDefault <- getBooleanSetting TestGhcDynamicByDefault
withNativeCodeGen <- expr $ getBooleanSetting TestGhcWithNativeCodeGen withNativeCodeGen <- getBooleanSetting TestGhcWithNativeCodeGen
withInterpreter <- expr $ getBooleanSetting TestGhcWithInterpreter withInterpreter <- getBooleanSetting TestGhcWithInterpreter
unregisterised <- expr $ getBooleanSetting TestGhcUnregisterised unregisterised <- getBooleanSetting TestGhcUnregisterised
withSMP <- expr $ getBooleanSetting TestGhcWithSMP withSMP <- getBooleanSetting TestGhcWithSMP
windows <- expr windowsHost windows <- expr windowsHost
darwin <- expr osxHost darwin <- expr osxHost
threads <- shakeThreads <$> expr getShakeOptions threads <- shakeThreads <$> expr getShakeOptions
os <- expr $ testSetting TestHostOS os <- getTestSetting TestHostOS
arch <- expr $ testSetting TestTargetARCH_CPP arch <- getTestSetting TestTargetARCH_CPP
platform <- expr $ testSetting TestTARGETPLATFORM platform <- getTestSetting TestTARGETPLATFORM
wordsize <- expr $ testSetting TestWORDSIZE wordsize <- getTestSetting TestWORDSIZE
top <- expr topDirectory top <- expr $ topDirectory
ghcFlags <- expr runTestGhcFlags ghcFlags <- expr runTestGhcFlags
timeoutProg <- expr buildRoot <&> (-/- timeoutProgPath) 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" mconcat [ arg $ "testsuite/driver/runtests.py"
, arg $ "--rootdir=" ++ ("testsuite" -/- "tests") , arg $ "--rootdir=" ++ ("testsuite" -/- "tests")
, pure ["--rootdir=" ++ test | test <- libTests] , pure ["--rootdir=" ++ test | test <- libTests]
, arg "-e", arg $ "windows=" ++ show windows , arg "-e", arg $ "windows=" ++ show windows
, arg "-e", arg $ "darwin=" ++ show darwin , arg "-e", arg $ "darwin=" ++ show darwin
, arg "-e", arg $ "config.local=True" , 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 $ "config.compiler_debugged=" ++ quote (yesNo debugged)
, arg "-e", arg $ "ghc_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.have_interp=" ++ show withInterpreter
, arg "-e", arg $ "config.unregisterised=" ++ show unregisterised , arg "-e", arg $ "config.unregisterised=" ++ show unregisterised
, arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags , arg "-e", arg $ "ghc_compiler_always_flags=" ++ quote ghcFlags
, arg "-e", arg $ oneZero "ghc_with_dynamic_rts" (hasRtsWay "dyn") , arg "-e", arg $ asZeroOne "ghc_with_dynamic_rts" (hasRtsWay "dyn")
, arg "-e", arg $ oneZero "ghc_with_threaded_rts" (hasRtsWay "thr") , arg "-e", arg $ asZeroOne "ghc_with_threaded_rts" (hasRtsWay "thr")
, arg "-e", arg $ oneZero "config.have_vanilla" (hasLibWay vanilla) , arg "-e", arg $ asZeroOne "config.have_vanilla" (hasLibWay vanilla)
, arg "-e", arg $ oneZero "config.have_dynamic" (hasLibWay dynamic) , arg "-e", arg $ asZeroOne "config.have_dynamic" (hasLibWay dynamic)
, arg "-e", arg $ oneZero "config.have_profiling" (hasLibWay profiling) , arg "-e", arg $ asZeroOne "config.have_profiling" (hasLibWay profiling)
, arg "-e", arg $ oneZero "ghc_with_smp" withSMP , arg "-e", arg $ asZeroOne "ghc_with_smp" withSMP
, arg "-e", arg $ "ghc_with_llvm=0" -- TODO: support LLVM , 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_by_default=" ++ show hasDynamicByDefault
, arg "-e", arg $ "config.ghc_dynamic=" ++ show hasDynamic , 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.top=" ++ show (top -/- "testsuite")
, arg "-e", arg $ "config.wordsize=" ++ show wordsize , arg "-e", arg $ "config.wordsize=" ++ show wordsize
, arg "-e", arg $ "config.os=" ++ show os , arg "-e", arg $ "config.os=" ++ show os
...@@ -97,7 +95,7 @@ runTestBuilderArgs = builder RunTest ? do ...@@ -97,7 +95,7 @@ runTestBuilderArgs = builder RunTest ? do
, getTestArgs -- User-provided arguments from command line. , 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 :: Args
getTestArgs = do getTestArgs = do
args <- expr $ userSetting defaultTestArgs args <- expr $ userSetting defaultTestArgs
...@@ -137,6 +135,7 @@ getTestArgs = do ...@@ -137,6 +135,7 @@ getTestArgs = do
++ configArgs ++ wayArgs ++ compilerArg ++ ghcPkgArg ++ configArgs ++ wayArgs ++ compilerArg ++ ghcPkgArg
++ haddockArg ++ hp2psArg ++ hpcArg ++ haddockArg ++ hp2psArg ++ hpcArg
-- TODO: Switch to 'Stage' as the first argument instead of 'String'.
-- | Directory to look for Binaries -- | 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. -- | in which ghc is stored and that they have their conventional name.
...@@ -151,25 +150,25 @@ setBinaryDirectory "stage1" = liftM2 (-/-) topDirectory (stageBinPath Stage0) ...@@ -151,25 +150,25 @@ setBinaryDirectory "stage1" = liftM2 (-/-) topDirectory (stageBinPath Stage0)
setBinaryDirectory "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1) setBinaryDirectory "stage2" = liftM2 (-/-) topDirectory (stageBinPath Stage1)
setBinaryDirectory compiler = pure $ parentPath compiler 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 :: String -> Action FilePath
setCompiler "stage0" = setting SystemGhc setCompiler "stage0" = setting SystemGhc
setCompiler "stage1" = liftM2 (-/-) topDirectory (fullpath Stage0 ghc) setCompiler "stage1" = liftM2 (-/-) topDirectory (fullPath Stage0 ghc)
setCompiler "stage2" = liftM2 (-/-) topDirectory (fullpath Stage1 ghc) setCompiler "stage2" = liftM2 (-/-) topDirectory (fullPath Stage1 ghc)
setCompiler compiler = pure compiler setCompiler compiler = pure compiler
-- | Set speed for test -- | Set speed for test
setTestSpeed :: TestSpeed -> String setTestSpeed :: TestSpeed -> String
setTestSpeed Fast = "2"
setTestSpeed Average = "1"
setTestSpeed Slow = "0" setTestSpeed Slow = "0"
setTestSpeed Average = "1"
setTestSpeed Fast = "2"
-- | Returns parent path of test compiler -- | 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 :: String -> String
parentPath path = let upPath = init $ splitOn "/" path parentPath path = intercalate "/" $ init $ splitOn "/" path
in intercalate "/" upPath
-- | TODO: move to hadrian utilities. -- | TODO: Move to Hadrian utilities.
fullpath :: Stage -> Package -> Action FilePath fullPath :: Stage -> Package -> Action FilePath
fullpath stage pkg = programPath =<< programContext stage pkg 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