From 2fac053131d4f297450e092e24524734afffc220 Mon Sep 17 00:00:00 2001 From: Andrey Mokhov Date: Thu, 23 Aug 2018 00:49:33 +0100 Subject: [PATCH] Fix warnings, improve comments and error handling, minor refactoring (#656) --- src/Hadrian/Utilities.hs | 15 ++-- src/Oracles/TestSettings.hs | 24 +++---- src/Settings/Builders/RunTest.hs | 115 +++++++++++++++---------------- 3 files changed, 78 insertions(+), 76 deletions(-) diff --git a/src/Hadrian/Utilities.hs b/src/Hadrian/Utilities.hs index 4ef0970b59..6cd9963dba 100644 --- a/src/Hadrian/Utilities.hs +++ b/src/Hadrian/Utilities.hs @@ -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 diff --git a/src/Oracles/TestSettings.hs b/src/Oracles/TestSettings.hs index 84be5813e0..1bf75b527d 100644 --- a/src/Oracles/TestSettings.hs +++ b/src/Oracles/TestSettings.hs @@ -1,13 +1,11 @@ -- | We create a file /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" diff --git a/src/Settings/Builders/RunTest.hs b/src/Settings/Builders/RunTest.hs index 6c0c52f9f1..05ec91aa6c 100644 --- a/src/Settings/Builders/RunTest.hs +++ b/src/Settings/Builders/RunTest.hs @@ -1,7 +1,6 @@ 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 -- GitLab