Commit f4bbf315 authored by Andrey Mokhov's avatar Andrey Mokhov

Minor clean up, taking hlint suggestions

parent 987240f7
......@@ -95,13 +95,12 @@ buildWith rs opts target args = do
putInfo target
verbose <- interpret target verboseCommand
let quietlyUnlessVerbose = if verbose then withVerbosity Loud else quietly
quietlyUnlessVerbose $ do
runBuilderWith (builder target) $ BuildInfo
{ buildArgs = argList
, buildInputs = inputs target
, buildOutputs = outputs target
, buildOptions = opts
, buildResources = rs }
quietlyUnlessVerbose $ runBuilderWith (builder target) $
BuildInfo { buildArgs = argList
, buildInputs = inputs target
, buildOutputs = outputs target
, buildOptions = opts
, buildResources = rs }
-- | Print out information about the command being executed.
putInfo :: Show b => Target c b -> Action ()
......
......@@ -28,7 +28,7 @@ pkgVersion cabalFile = version <$> readCabalFile cabalFile
pkgIdentifier :: FilePath -> Action String
pkgIdentifier cabalFile = do
cabal <- readCabalFile cabalFile
return $ if (null $ version cabal)
return $ if null (version cabal)
then name cabal
else name cabal ++ "-" ++ version cabal
......
......@@ -29,7 +29,7 @@ bashPath = lookupInPath "bash"
-- * "/c/" => "C:/"
-- * "/usr/bin/tar.exe" => "C:/msys/usr/bin/tar.exe"
fixAbsolutePathOnWindows :: FilePath -> Action FilePath
fixAbsolutePathOnWindows path = do
fixAbsolutePathOnWindows path =
if isWindows
then do
let (dir, file) = splitFileName path
......@@ -57,6 +57,6 @@ pathOracle = do
void $ addOracle $ \(LookupInPath name) -> do
let unpack = fromMaybe . error $ "Cannot find executable " ++ quote name
path <- unifyPath <$> unpack <$> liftIO (findExecutable name)
path <- unifyPath . unpack <$> liftIO (findExecutable name)
putLoud $ "| Executable found: " ++ name ++ " => " ++ path
return path
......@@ -58,7 +58,7 @@ lookupValueOrEmpty file key = fromMaybe "" <$> lookupValue file key
-- | Like 'lookupValue' but raises an error if the key is not found.
lookupValueOrError :: FilePath -> String -> Action String
lookupValueOrError file key = (fromMaybe $ error msg) <$> lookupValue file key
lookupValueOrError file key = fromMaybe (error msg) <$> lookupValue file key
where
msg = "Key " ++ quote key ++ " not found in file " ++ quote file
......@@ -73,7 +73,7 @@ lookupValuesOrEmpty file key = fromMaybe [] <$> lookupValues file key
-- | Like 'lookupValues' but raises an error if the key is not found.
lookupValuesOrError :: FilePath -> String -> Action [String]
lookupValuesOrError file key = (fromMaybe $ error msg) <$> lookupValues file key
lookupValuesOrError file key = fromMaybe (error msg) <$> lookupValues file key
where
msg = "Key " ++ quote key ++ " not found in file " ++ quote file
......
......@@ -135,8 +135,8 @@ moduleFilesOracle = void $ do
forM todo $ \(mDir, mFiles) -> do
let fullDir = unifyPath $ dir -/- mDir
files <- getDirectoryFiles fullDir moduleFilePatterns
let cmp fe f = compare (dropExtension fe) f
found = intersectOrd cmp files mFiles
let cmp f = compare (dropExtension f)
found = intersectOrd cmp files mFiles
return (map (fullDir -/-) found, mDir)
let pairs = sort [ (encodeModule d f, f) | (fs, d) <- result, f <- fs ]
multi = [ (m, f1, f2) | (m, f1):(n, f2):_ <- tails pairs, m == n ]
......@@ -151,7 +151,7 @@ moduleFilesOracle = void $ do
generators <- newCache $ \(stage, package) -> do
let context = vanillaContext stage package
files <- contextFiles context
list <- sequence [ (,src) <$> (generatedFile context modName)
list <- sequence [ (,src) <$> generatedFile context modName
| (modName, Just src) <- files
, takeExtension src `notElem` haskellExtensions ]
return $ Map.fromList list
......
......@@ -6,7 +6,7 @@ import Hadrian.Oracles.TextFile
import Base
data PackageData = BuildGhciLib FilePath
newtype PackageData = BuildGhciLib FilePath
data PackageDataList = AsmSrcs FilePath
| CcArgs FilePath
......
......@@ -141,7 +141,7 @@ getSettingList :: SettingList -> Args c b
getSettingList = expr . settingList
matchSetting :: Setting -> [String] -> Action Bool
matchSetting key values = fmap (`elem` values) $ setting key
matchSetting key values = (`elem` values) <$> setting key
anyTargetPlatform :: [String] -> Action Bool
anyTargetPlatform = matchSetting TargetPlatformFull
......@@ -226,7 +226,7 @@ installGhcLibDir = do
-- We also need to respect the system's dynamic extension, e.g. .dll or .so.
libsuf :: Way -> Action String
libsuf way =
if (not . wayUnit Dynamic $ way)
if not (wayUnit Dynamic way)
then return $ waySuffix way ++ ".a" -- e.g., _p.a
else do
extension <- setting DynamicExtension -- e.g., .dll or .so
......
......@@ -5,11 +5,11 @@ import Base
clean :: Action ()
clean = do
cleanSourceTree
putBuild $ "| Remove Hadrian files..."
putBuild "| Remove Hadrian files..."
path <- buildRoot
removeDirectory $ path -/- generatedDir
removeFilesAfter path ["//*"]
putSuccess $ "| Done. "
putSuccess "| Done. "
cleanSourceTree :: Action ()
cleanSourceTree = do
......
......@@ -18,7 +18,7 @@ compilePackage rs context@Context {..} = do
need [src]
needDependencies context src $ obj <.> "d"
buildWithResources rs $ target context (compiler stage) [src] [obj]
compileHs = \[obj, _hi] -> do
compileHs [obj, _hi] = do
path <- buildPath context
(src, deps) <- lookupDependencies (path -/- ".dependencies") obj
need $ src : deps
......
......@@ -18,7 +18,7 @@ buildPackageDependencies rs context@Context {..} =
need srcs
orderOnly =<< interpretInContext context generatedDependencies
let mk = deps <.> "mk"
if srcs == []
if null srcs
then writeFileChanged mk ""
else buildWithResources rs $
target context (Ghc FindHsDependencies stage) srcs [mk]
......
......@@ -36,7 +36,7 @@ The resulting tree structure is organized under @destDir ++ prefix@ as follows:
XXX (izgzhen): Do we need @INSTALL_OPTS@ in the make scripts?
-}
installRules :: Rules ()
installRules = do
installRules =
"install" ~> do
installIncludes
installPackageConf
......@@ -74,12 +74,12 @@ installLibExecs = do
libExecDir <- getLibExecDir
destDir <- getDestDir
installDirectory (destDir ++ libExecDir)
forM_ installBinPkgs $ \pkg -> do
forM_ installBinPkgs $ \pkg ->
withInstallStage pkg $ \stage -> do
context <- programContext stage pkg
let bin = inplaceLibBinPath -/- programName context <.> exe
installProgram bin (destDir ++ libExecDir)
when (pkg == ghc) $ do
when (pkg == ghc) $
moveFile (destDir ++ libExecDir -/- programName context <.> exe)
(destDir ++ libExecDir -/- "ghc" <.> exe)
......@@ -165,8 +165,8 @@ installPackages = do
let rtsDir = destDir ++ ghcLibDir -/- "rts"
installDirectory rtsDir
ways <- interpretInContext (vanillaContext Stage1 rts) getRtsWays
rtsLibs <- mapM pkgLibraryFile $ map (Context Stage1 rts) ways
ffiLibs <- sequence $ map rtsLibffiLibrary ways
rtsLibs <- mapM (pkgLibraryFile . Context Stage1 rts) ways
ffiLibs <- mapM rtsLibffiLibrary ways
-- TODO: Add dynamic libraries.
forM_ (rtsLibs ++ ffiLibs) $ \lib -> installData [lib] rtsDir
......@@ -185,7 +185,7 @@ installPackages = do
-- TODO: Figure out what is the root cause of the missing ghc-gmp.h error.
copyFile (pkgPath integerGmp -/- "gmp/ghc-gmp.h") (pkgPath integerGmp -/- "ghc-gmp.h")
forM_ installLibPkgs $ \pkg -> do
forM_ installLibPkgs $ \pkg ->
case pkgCabalFile pkg of
Nothing -> error $ "Non-Haskell project in installLibPkgs" ++ show pkg
Just cabalFile -> withInstallStage pkg $ \stage -> do
......@@ -222,7 +222,7 @@ installPackages = do
, pref
, ghclibDir
, docDir -/- "html/libraries"
, intercalate " " (map show ways) ]
, unwords (map show ways) ]
-- Register packages
let installedGhcPkgReal = destDir ++ binDir -/- "ghc-pkg" <.> exe
......@@ -232,7 +232,7 @@ installPackages = do
, installedPackageConf, "update"
, confPath ]
forM_ installLibPkgs $ \pkg -> do
forM_ installLibPkgs $ \pkg ->
withInstallStage pkg $ \stage -> do
let context = vanillaContext stage pkg
top <- topDirectory
......@@ -280,13 +280,12 @@ installCommonLibs = do
installLibsTo :: [FilePath] -> FilePath -> Action ()
installLibsTo libs dir = do
installDirectory dir
forM_ libs $ \lib -> do
case takeExtension lib of
".a" -> do
let out = dir -/- takeFileName lib
installData [out] dir
runBuilder Ranlib [out] [out] [out]
_ -> installData [lib] dir
forM_ libs $ \lib -> case takeExtension lib of
".a" -> do
let out = dir -/- takeFileName lib
installData [out] dir
runBuilder Ranlib [out] [out] [out]
_ -> installData [lib] dir
-- ref: includes/ghc.mk
-- | All header files are in includes/{one of these subdirectories}.
......@@ -333,5 +332,5 @@ installDocs = do
installData ["docs/index.html"] htmlDocDir
forM_ ["Haddock", "libraries", "users_guide"] $ \dirname -> do
let dir = (root -/- "docs/html" -/- dirname)
let dir = root -/- "docs/html" -/- dirname
whenM (doesDirectoryExist dir) $ copyDirectory dir htmlDocDir
......@@ -59,7 +59,7 @@ libffiRules = do
putBuild "| System supplied FFI library will be used"
forM_ ["ffi.h", "ffitarget.h"] $ \file ->
copyFile (ffiIncludeDir -/- file) (rtsPath -/- file)
putSuccess $ "| Successfully copied system FFI library header files"
putSuccess "| Successfully copied system FFI library header files"
else do
libffiPath <- libffiBuildPath
build $ target libffiContext (Make libffiPath) [] []
......@@ -73,7 +73,7 @@ libffiRules = do
rtsLib <- rtsLibffiLibrary way
copyFileUntracked (libffiPath -/- libffiLibrary) rtsLib
putSuccess $ "| Successfully built custom library 'libffi'"
putSuccess "| Successfully built custom library 'libffi'"
"//libffi/Makefile.in" %> \mkIn -> do
libffiPath <- libffiBuildPath
......
......@@ -31,16 +31,16 @@ selftestRules =
testBuilder :: Action ()
testBuilder = do
putBuild $ "==== trackArgument"
putBuild "==== trackArgument"
let make = target undefined (Make undefined) undefined undefined
test $ forAll (elements ["-j", "MAKEFLAGS=-j", "THREADS="])
$ \prefix (NonNegative n) ->
trackArgument make prefix == False &&
trackArgument make ("-j" ++ show (n :: Int)) == False
not (trackArgument make prefix) &&
not (trackArgument make ("-j" ++ show (n :: Int)))
testChunksOfSize :: Action ()
testChunksOfSize = do
putBuild $ "==== chunksOfSize"
putBuild "==== chunksOfSize"
test $ chunksOfSize 3 [ "a", "b", "c" , "defg" , "hi" , "jk" ]
== [ ["a", "b", "c"], ["defg"], ["hi"], ["jk"] ]
test $ \n xs ->
......@@ -49,12 +49,12 @@ testChunksOfSize = do
testLookupAll :: Action ()
testLookupAll = do
putBuild $ "==== lookupAll"
putBuild "==== lookupAll"
test $ lookupAll ["b" , "c" ] [("a", 1), ("c", 3), ("d", 4)]
== [Nothing, Just (3 :: Int)]
test $ forAll dicts $ \dict -> forAll extras $ \extra ->
let items = sort $ map fst dict ++ extra
in lookupAll items (sort dict) == map (flip lookup dict) items
in lookupAll items (sort dict) == map (`lookup` dict) items
where
dicts :: Gen [(Int, Int)]
dicts = nubBy (\x y -> fst x == fst y) <$> vector 20
......@@ -63,7 +63,7 @@ testLookupAll = do
testModuleName :: Action ()
testModuleName = do
putBuild $ "==== Encode/decode module name"
putBuild "==== Encode/decode module name"
test $ encodeModule "Data/Functor" "Identity.hs" == "Data.Functor.Identity"
test $ encodeModule "" "Prelude" == "Prelude"
......@@ -76,9 +76,9 @@ testModuleName = do
testPackages :: Action ()
testPackages = do
putBuild $ "==== Check system configuration"
putBuild "==== Check system configuration"
win <- windowsHost -- This depends on the @boot@ and @configure@ scripts.
putBuild $ "==== Packages, interpretInContext, configuration flags"
putBuild "==== Packages, interpretInContext, configuration flags"
forM_ [Stage0 ..] $ \stage -> do
pkgs <- stagePackages stage
when (win32 `elem` pkgs) . test $ win
......@@ -87,6 +87,6 @@ testPackages = do
testWay :: Action ()
testWay = do
putBuild $ "==== Read Way, Show Way"
putBuild "==== Read Way, Show Way"
test $ \(x :: Way) -> read (show x) == x
......@@ -4,25 +4,25 @@ import Settings.Builders.Common
ccBuilderArgs :: Args
ccBuilderArgs = do
way <- getWay
builder Cc ? mconcat
[ getPkgDataList CcArgs
, getStagedSettingList ConfCcArgs
, cIncludeArgs
way <- getWay
builder Cc ? mconcat
[ getPkgDataList CcArgs
, getStagedSettingList ConfCcArgs
, cIncludeArgs
, builder (Cc CompileC) ? mconcat
[ arg "-Werror"
, Dynamic `wayUnit` way ? pure [ "-fPIC", "-DDYNAMIC" ]
-- ref: mk/warning.mk:
-- SRC_CC_OPTS += -Wall $(WERROR)
, arg "-c", arg =<< getInput
, arg "-o", arg =<< getOutput ]
, builder (Cc CompileC) ? mconcat
[ arg "-Werror"
, Dynamic `wayUnit` way ? pure [ "-fPIC", "-DDYNAMIC" ]
-- ref: mk/warning.mk:
-- SRC_CC_OPTS += -Wall $(WERROR)
, arg "-c", arg =<< getInput
, arg "-o", arg =<< getOutput ]
, builder (Cc FindCDependencies) ? do
output <- getOutput
mconcat [ arg "-E"
, arg "-MM", arg "-MG"
, arg "-MF", arg output
, arg "-MT", arg $ dropExtension output -<.> "o"
, arg "-x", arg "c"
, arg =<< getInput ] ]
, builder (Cc FindCDependencies) ? do
output <- getOutput
mconcat [ arg "-E"
, arg "-MM", arg "-MG"
, arg "-MF", arg output
, arg "-MT", arg $ dropExtension output -<.> "o"
, arg "-x", arg "c"
, arg =<< getInput ] ]
......@@ -41,7 +41,7 @@ cArgs = mempty
-- TODO: should be in a different file
cWarnings :: Args
cWarnings = do
let gccGe46 = notM $ (flag GccIsClang ||^ flag GccLt46)
let gccGe46 = notM (flag GccIsClang ||^ flag GccLt46)
mconcat [ arg "-Wall"
, flag GccIsClang ? arg "-Wno-unknown-pragmas"
, gccGe46 ? notM windowsHost ? arg "-Werror=unused-but-set-variable"
......
......@@ -6,7 +6,7 @@ import Settings.Builders.Common
makeBuilderArgs :: Args
makeBuilderArgs = do
threads <- shakeThreads <$> (expr getShakeOptions)
threads <- shakeThreads <$> expr getShakeOptions
gmpPath <- expr gmpBuildPath
libffiPath <- expr libffiBuildPath
let t = show $ max 4 (threads - 2) -- Don't use all Shake's threads
......
......@@ -3,7 +3,7 @@ module Settings.Builders.Tar (tarBuilderArgs) where
import Settings.Builders.Common
tarBuilderArgs :: Args
tarBuilderArgs = do
tarBuilderArgs =
mconcat [ builder (Tar Create) ? mconcat
[ arg "-c"
, output "//*.gz" ? arg "--gzip"
......
......@@ -12,7 +12,7 @@ developmentFlavour ghcStage = defaultFlavour
developmentArgs :: Stage -> Args
developmentArgs ghcStage = do
stage <- getStage
sourceArgs $ SourceArgs
sourceArgs SourceArgs
{ hsDefault = pure ["-O", "-H64m"]
, hsLibrary = notStage0 ? arg "-dcore-lint"
, hsCompiler = succ stage == ghcStage ? pure ["-O0", "-DDEBUG"]
......
......@@ -10,7 +10,7 @@ performanceFlavour = defaultFlavour
, args = defaultBuilderArgs <> performanceArgs <> defaultPackageArgs }
performanceArgs :: Args
performanceArgs = sourceArgs $ SourceArgs
performanceArgs = sourceArgs SourceArgs
{ hsDefault = pure ["-O", "-H64m"]
, hsLibrary = notStage0 ? arg "-O2"
, hsCompiler = mconcat [stage0 ? arg "-O", notStage0 ? arg "-O2"]
......
......@@ -11,7 +11,7 @@ profiledFlavour = defaultFlavour
, ghcProfiled = True }
profiledArgs :: Args
profiledArgs = sourceArgs $ SourceArgs
profiledArgs = sourceArgs SourceArgs
{ hsDefault = pure ["-O0", "-H64m"]
, hsLibrary = notStage0 ? arg "-O"
, hsCompiler = arg "-O"
......
......@@ -14,7 +14,7 @@ quickFlavour = defaultFlavour
, notStage0 ? platformSupportsSharedLibs ? pure [dynamic] ] }
quickArgs :: Args
quickArgs = sourceArgs $ SourceArgs
quickArgs = sourceArgs SourceArgs
{ hsDefault = pure ["-O0", "-H64m"]
, hsLibrary = notStage0 ? arg "-O"
, hsCompiler = stage0 ? arg "-O"
......
......@@ -14,7 +14,7 @@ quickCrossFlavour = defaultFlavour
, notStage0 ? platformSupportsSharedLibs ? pure [dynamic] ] }
quickCrossArgs :: Args
quickCrossArgs = sourceArgs $ SourceArgs
quickCrossArgs = sourceArgs SourceArgs
{ hsDefault = pure ["-O0", "-H64m"]
, hsLibrary = notStage0 ? mconcat [ arg "-O", arg "-fllvm" ]
, hsCompiler = stage0 ? arg "-O"
......
......@@ -12,7 +12,7 @@ quickestFlavour = defaultFlavour
, rtsWays = quickestRtsWays }
quickestArgs :: Args
quickestArgs = sourceArgs $ SourceArgs
quickestArgs = sourceArgs SourceArgs
{ hsDefault = pure ["-O0", "-H64m"]
, hsLibrary = mempty
, hsCompiler = stage0 ? arg "-O"
......
......@@ -6,7 +6,6 @@ import Flavour
import Oracles.Flag
import Oracles.Setting
import Settings
import Oracles.Flag (crossCompiling)
compilerPackageArgs :: Args
compilerPackageArgs = package compiler ? do
......
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