Commit 4238fb77 authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Clean up, fix -Wall warnings.

parent efe9d6fa
import Base
import Rules
main :: IO ()
main = shakeArgs shakeOptions{shakeFiles = shakeFilesPath} $ do
oracleRules -- see module Rules.Oracles
cabalRules -- see module Rules.Cabal
......
......@@ -25,11 +25,11 @@ newtype ArgsHashKey = ArgsHashKey Target
-- TODO: enforce the above assumption via type trickery?
checkArgsHash :: FullTarget -> Action ()
checkArgsHash target = do
tmp <- askOracle . ArgsHashKey $ target { sources = ["src"] } :: Action Int
_ <- askOracle . ArgsHashKey $ target { sources = ["src"] } :: Action Int
return ()
-- Oracle for storing per-target argument list hashes
argsHashOracle :: Rules ()
argsHashOracle = do
addOracle $ \(ArgsHashKey target) -> hash <$> interpret target getArgs
_ <- addOracle $ \(ArgsHashKey target) -> hash <$> interpret target getArgs
return ()
......@@ -36,5 +36,5 @@ configOracle = do
need [configFile]
putOracle $ "Reading " ++ configFile ++ "..."
liftIO $ readConfigFile configFile
addOracle $ \(ConfigKey key) -> Map.lookup key <$> cfg ()
_ <- addOracle $ \(ConfigKey key) -> Map.lookup key <$> cfg ()
return ()
......@@ -45,5 +45,5 @@ dependenciesOracle = do
. groupBy ((==) `on` fst)
. sortBy (compare `on` fst) $ contents
addOracle $ \(DependenciesKey (file, obj)) -> Map.lookup obj <$> deps file
_ <- addOracle $ \(DependenciesKey (file, obj)) -> Map.lookup obj <$> deps file
return ()
module Oracles.Flag (
Flag (..), flag,
supportsPackageKey, crossCompiling, gccIsClang, gccLt46,
crossCompiling, gccIsClang, gccLt46,
platformSupportsSharedLibs, ghcWithSMP, ghcWithNativeCodeGen
) where
......@@ -35,9 +35,6 @@ flag f = do
++ "' instead of 'YES' or 'NO'."
return $ value == "YES"
supportsPackageKey :: Action Bool
supportsPackageKey = flag SupportsPackageKey
crossCompiling :: Action Bool
crossCompiling = flag CrossCompiling
......
......@@ -31,5 +31,5 @@ packageDepsOracle = do
contents <- readFileLines packageDependencies
return . Map.fromList
$ [ (head ps, tail ps) | line <- contents, let ps = words line ]
addOracle $ \(PackageDepsKey pkg) -> Map.lookup pkg <$> deps ()
_ <- addOracle $ \(PackageDepsKey pkg) -> Map.lookup pkg <$> deps ()
return ()
......@@ -24,5 +24,5 @@ windowsRootOracle = do
let root = dropWhileEnd isSpace out
putOracle $ "Detected root on Windows: " ++ root
return root
addOracle $ \WindowsRoot{} -> root ()
_ <- addOracle $ \WindowsRoot{} -> root ()
return ()
{-# LANGUAGE DeriveGeneric #-}
module Package (
Package (..), PackageName, pkgCabalPath,
Package (..), PackageName, pkgCabalFile,
library, topLevel, setPath
) where
......@@ -22,8 +22,8 @@ data Package = Package
deriving Generic
-- Relative path to cabal file, e.g.: "libraries/Cabal/Cabal/Cabal.cabal"
pkgCabalPath :: Package -> FilePath
pkgCabalPath pkg = pkgPath pkg -/- pkgName pkg <.> "cabal"
pkgCabalFile :: Package -> FilePath
pkgCabalFile pkg = pkgPath pkg -/- pkgName pkg <.> "cabal"
instance Show Package where
show = pkgName
......
......@@ -27,17 +27,17 @@ generateTargets = action $ do
fmap concat . forM pkgs $ \pkg -> do
let target = stagePackageTarget stage pkg
buildPath = targetPath stage pkg -/- "build"
buildGhciLib <- interpret target $ getPkgData BuildGhciLib
pkgKey <- interpret target $ getPkgData PackageKey
buildHaddock <- interpret target $ Settings.User.buildHaddock
let ghciLib = [ buildPath -/- "HS" ++ pkgKey <.> "o"
| buildGhciLib == "YES" && stage /= Stage0 ]
haddock = [ pkgHaddockPath pkg | buildHaddock ]
libName <- interpret target $ getPkgData LibName
needGhciLib <- interpret target $ getPkgData BuildGhciLib
needHaddock <- interpret target buildHaddock
let ghciLib = [ buildPath -/- "HS" ++ libName <.> "o"
| needGhciLib == "YES" && stage /= Stage0 ]
haddock = [ pkgHaddockFile pkg | needHaddock ]
ways <- interpret target getWays
libs <- forM ways $ \way -> do
extension <- libsuf way
return $ buildPath -/- "libHS" ++ pkgKey <.> extension
return $ buildPath -/- "libHS" ++ libName <.> extension
return $ ghciLib ++ libs ++ haddock
......
......@@ -10,7 +10,6 @@ import qualified Target
import Oracles.Setting
import Oracles.ArgsHash
import Settings.Args
import Settings.Util
import Settings.User
import Settings.Builders.Ar
......@@ -20,7 +19,7 @@ import Settings.Builders.Ar
buildWithResources :: [(Resource, Int)] -> FullTarget -> Action ()
buildWithResources rs target = do
let builder = Target.builder target
needBuilder builder
needBuilder laxDependencies builder
path <- builderPath builder
argList <- interpret target getArgs
-- The line below forces the rule to be rerun if the args hash has changed
......@@ -55,11 +54,11 @@ interestingInfo builder ss = case builder of
GhcCabal -> prefixAndSuffix 3 0 ss
_ -> ss
where
prefixAndSuffix n m ss =
if length ss <= n + m + 1
then ss
else take n ss
prefixAndSuffix n m list =
if length list <= n + m + 1
then list
else take n list
++ ["... skipping "
++ show (length ss - n - m)
++ show (length list - n - m)
++ " arguments ..."]
++ drop (length ss - m) ss
++ drop (length list - m) list
......@@ -3,7 +3,7 @@ module Rules.Cabal (cabalRules) where
import Base
import Stage
import Package hiding (library)
import Expression hiding (package)
import Expression
import Settings.Packages
import Data.List
import Data.Version
......@@ -15,29 +15,27 @@ import Distribution.PackageDescription.Parse
cabalRules :: Rules ()
cabalRules = do
-- Cache boot package constraints (to be used in cabalArgs)
bootPackageConstraints %> \file -> do
bootPackageConstraints %> \out -> do
pkgs <- interpret (stageTarget Stage0) getPackages
constraints <- forM (sort pkgs) $ \pkg -> do
let cabal = pkgCabalPath pkg
need [cabal]
description <- liftIO $ readPackageDescription silent cabal
let identifier = package . packageDescription $ description
need [pkgCabalFile pkg]
pd <- liftIO . readPackageDescription silent $ pkgCabalFile pkg
let identifier = package . packageDescription $ pd
version = showVersion . pkgVersion $ identifier
PackageName name = Distribution.Package.pkgName identifier
return $ name ++ " == " ++ version
writeFileChanged file . unlines $ constraints
writeFileChanged out . unlines $ constraints
-- Cache package dependencies
packageDependencies %> \file -> do
packageDependencies %> \out -> do
pkgs <- interpret (stageTarget Stage1) getPackages
pkgDeps <- forM (sort pkgs) $ \pkg -> do
let cabal = pkgCabalPath pkg
need [cabal]
description <- liftIO $ readPackageDescription silent cabal
let deps = collectDeps . condLibrary $ description
need [pkgCabalFile pkg]
pd <- liftIO . readPackageDescription silent $ pkgCabalFile pkg
let deps = collectDeps . condLibrary $ pd
depNames = [ name | Dependency (PackageName name) _ <- deps ]
return . unwords $ Package.pkgName pkg : sort depNames
writeFileChanged file . unlines $ pkgDeps
writeFileChanged out . unlines $ pkgDeps
collectDeps :: Maybe (CondTree v [Dependency] a) -> [Dependency]
collectDeps Nothing = []
......
......@@ -12,12 +12,13 @@ configCommand = "AC_CONFIG_FILES([" ++ configPath ++ "system.config])"
configRules :: Rules ()
configRules = do
configPath -/- "system.config" %> \out -> do
configPath -/- "system.config" %> \_ -> do
need [configPath -/- "system.config.in", "configure"]
putBuild "Running configure..."
cmd "bash configure" -- TODO: get rid of 'bash'
"configure" %> \out -> do
-- TODO: this rule won't rebuild if configure.ac is changed. Worth fixing?
"configure" %> \_ -> do
-- Make sure 'configure.ac' script contains a line with configCommand
script <- fmap lines . liftIO $ readFile "configure.ac"
when (configCommand `notElem` script) $ do
......
......@@ -4,7 +4,7 @@ import Base
import Util
import Package
import Builder
import Switches
import Switches (registerPackage)
import Expression
import qualified Target
import Oracles.PackageDeps
......@@ -18,11 +18,11 @@ import Control.Monad.Extra
-- Build package-data.mk by using GhcCabal to process pkgCabal file
buildPackageData :: Resources -> StagePackageTarget -> Rules ()
buildPackageData (Resources ghcCabal ghcPkg) target = do
buildPackageData rs target = do
let stage = Target.stage target
pkg = Target.package target
path = targetPath stage pkg
cabal = pkgCabalPath pkg
cabalFile = pkgCabalFile pkg
configure = pkgPath pkg -/- "configure"
(path -/-) <$>
......@@ -33,7 +33,7 @@ buildPackageData (Resources ghcCabal ghcPkg) target = do
, "build" -/- "autogen" -/- "cabal_macros.h"
-- TODO: Is this needed? Also check out Paths_cpsa.hs.
-- , "build" -/- "autogen" -/- ("Paths_" ++ name) <.> "hs"
] &%> \files -> do
] &%> \outs -> do
-- GhcCabal may run the configure script, so we depend on it
-- We don't know who built the configure script from configure.ac
whenM (doesFileExist $ configure <.> "ac") $ need [configure]
......@@ -41,18 +41,18 @@ buildPackageData (Resources ghcCabal ghcPkg) target = do
-- We configure packages in the order of their dependencies
deps <- packageDeps pkg
pkgs <- interpret target getPackages
let cmp pkg name = compare (pkgName pkg) name
depPkgs = intersectOrd cmp (sort pkgs) deps
let cmp p name = compare (pkgName p) name
depPkgs = intersectOrd cmp (sort pkgs) deps
need [ targetPath stage p -/- "package-data.mk" | p <- depPkgs ]
need [cabal]
buildWithResources [(ghcCabal, 1)] $
fullTarget target GhcCabal [cabal] files
need [cabalFile]
buildWithResources [(ghcCabal rs, 1)] $
fullTarget target GhcCabal [cabalFile] outs
-- TODO: find out of ghc-cabal can be concurrent with ghc-pkg
whenM (interpret target registerPackage) .
buildWithResources [(ghcPkg, 1)] $
fullTarget target (GhcPkg stage) [cabal] files
buildWithResources [(ghcPkg rs, 1)] $
fullTarget target (GhcPkg stage) [cabalFile] outs
postProcessPackageData $ path -/- "package-data.mk"
......
......@@ -21,10 +21,10 @@ buildPackageDependencies _ target =
dropBuild = (pkgPath pkg ++) . drop (length buildPath)
hDepFile = buildPath -/- ".hs-dependencies"
in do
(buildPath <//> "*.c.deps") %> \file -> do
let srcFile = dropBuild . dropExtension $ file
(buildPath <//> "*.c.deps") %> \out -> do
let srcFile = dropBuild . dropExtension $ out
need [srcFile]
build $ fullTarget target (GccM stage) [srcFile] [file]
build $ fullTarget target (GccM stage) [srcFile] [out]
hDepFile %> \file -> do
srcs <- interpret target getPackageSources
......
......@@ -21,20 +21,19 @@ import Control.Monad.Extra
-- files in the Shake databases seems fragile and unnecesarry.
buildPackageDocumentation :: Resources -> StagePackageTarget -> Rules ()
buildPackageDocumentation _ target =
let stage = Target.stage target
pkg = Target.package target
name = pkgName pkg
cabal = pkgCabalPath pkg
haddock = pkgHaddockPath pkg
let stage = Target.stage target
pkg = Target.package target
cabalFile = pkgCabalFile pkg
haddockFile = pkgHaddockFile pkg
in when (stage == Stage1) $ do
haddock %> \file -> do
haddockFile %> \file -> do
whenM (specified HsColour) $ do
need [cabal]
build $ fullTarget target GhcCabalHsColour [cabal] []
need [cabalFile]
build $ fullTarget target GhcCabalHsColour [cabalFile] []
srcs <- interpret target getPackageSources
deps <- interpret target $ getPkgDataList DepNames
let haddocks = [ pkgHaddockPath depPkg
let haddocks = [ pkgHaddockFile depPkg
| Just depPkg <- map findKnownPackage deps ]
need $ srcs ++ haddocks
let haddockWay = if dynamicGhcPrograms then dynamic else vanilla
......
......@@ -3,6 +3,7 @@ module Rules.Resources (
) where
import Base
import Control.Monad
data Resources = Resources
{
......@@ -14,7 +15,5 @@ data Resources = Resources
-- * https://mail.haskell.org/pipermail/ghc-commits/2013-May/001712.html
-- * ghc.mk: see comment about parallel ghc-pkg invokations
resourceRules :: Rules Resources
resourceRules = do
ghcCabal <- newResource "ghc-cabal" 1
ghcPkg <- newResource "ghc-pkg" 1
return $ Resources ghcCabal ghcPkg
resourceRules = liftM2 Resources (newResource "ghc-cabal" 1)
(newResource "ghc-pkg" 1)
module Settings.Builders.Ar (arArgs, arPersistentArgsCount) where
import Builder
import Switches (builder)
import Expression
import Settings.Util
......
......@@ -3,6 +3,7 @@ module Settings.Builders.Gcc (gccArgs, gccMArgs) where
import Base
import Util
import Builder
import Switches (stagedBuilder)
import Expression
import Oracles.PackageData
import Settings.Util
......@@ -10,7 +11,6 @@ import Settings.Util
-- TODO: check code duplication
gccArgs :: Args
gccArgs = stagedBuilder Gcc ? do
path <- getTargetPath
file <- getFile
src <- getSource
ccArgs <- getPkgDataList CcArgs
......@@ -24,28 +24,25 @@ gccArgs = stagedBuilder Gcc ? do
-- TODO: handle custom $1_$2_MKDEPENDC_OPTS and
gccMArgs :: Args
gccMArgs = stagedBuilder GccM ? do
path <- getTargetPath
file <- getFile
src <- getSource
ccArgs <- getPkgDataList CcArgs
mconcat
[ arg "-E"
, arg "-MM"
, append ccArgs -- TODO: remove? any other flags?
, includeGccArgs
, arg "-MF"
, arg file
, arg "-MT"
, arg $ dropExtension file -<.> "o"
, arg "-x"
, arg "c"
, arg src ]
mconcat [ arg "-E"
, arg "-MM"
, append ccArgs -- TODO: remove? any other flags?
, includeGccArgs
, arg "-MF"
, arg file
, arg "-MT"
, arg $ dropExtension file -<.> "o"
, arg "-x"
, arg "c"
, arg src ]
includeGccArgs :: Args
includeGccArgs = do
path <- getTargetPath
pkgPath <- getPackagePath
pkg <- getPackage
iDirs <- getPkgDataList IncludeDirs
dDirs <- getPkgDataList DepIncludeDirs
mconcat
......
......@@ -4,7 +4,7 @@ import Way
import Util
import Stage
import Builder
import Switches
import Switches (stagedBuilder, splitObjects, stage0)
import Expression
import Oracles.Flag
import Oracles.PackageData
......@@ -32,7 +32,7 @@ ghcMArgs = stagedBuilder GhcM ? do
mconcat [ arg "-M"
, commonGhcArgs
, arg "-dep-makefile", arg file
, append $ concat [ ["-dep-suffix", wayPrefix way] | way <- ways ]
, append $ concat [ ["-dep-suffix", wayPrefix w] | w <- ways ]
, append srcs ]
-- This is included into ghcArgs, ghcMArgs and haddockArgs.
......@@ -78,18 +78,16 @@ packageGhcArgs = do
stage <- getStage
supportsPackageKey <- getFlag SupportsPackageKey
pkgKey <- getPkgData PackageKey
pkgDepKeys <- getPkgDataList DepKeys
pkgDeps <- getPkgDataList Deps
pkgDepIds <- getPkgDataList DepIds
mconcat
[ arg "-hide-all-packages"
, arg "-no-user-package-db"
, arg "-include-pkg-deps"
, stage0 ? arg "-package-db libraries/bootstrapping.conf"
, if supportsPackageKey || stage /= Stage0
then mconcat [ arg $ "-this-package-key " ++ pkgKey
, append $ map ("-package-key " ++) pkgDepKeys ]
else mconcat [ arg $ "-package-name " ++ pkgKey
, append $ map ("-package " ++) pkgDeps ]]
then arg $ "-this-package-key " ++ pkgKey
else arg $ "-package-name " ++ pkgKey
, append $ map ("-package-id " ++) pkgDepIds ]
includeGhcArgs :: Args
includeGhcArgs = do
......
......@@ -68,13 +68,12 @@ libraryArgs = do
configureArgs :: Args
configureArgs = do
stage <- getStage
let conf key = appendSubD $ "--configure-option=" ++ key
cFlags = mconcat [ ccArgs
, remove ["-Werror"]
, argSettingList $ ConfCcArgs stage ]
ldFlags = ldArgs <> (argSettingList $ ConfGccLinkerArgs stage)
cppFlags = cppArgs <> (argSettingList $ ConfCppArgs stage)
, argStagedSettingList ConfCcArgs ]
ldFlags = ldArgs <> (argStagedSettingList ConfGccLinkerArgs)
cppFlags = cppArgs <> (argStagedSettingList ConfCppArgs)
mconcat
[ conf "CFLAGS" cFlags
, conf "LDFLAGS" ldFlags
......@@ -86,7 +85,7 @@ configureArgs = do
, conf "--with-gmp-libraries" $ argSettingList GmpLibDirs
-- TODO: why TargetPlatformFull and not host?
, crossCompiling ? (conf "--host" $ argSetting TargetPlatformFull)
, conf "--with-cc" . argM . builderPath $ Gcc stage ]
, conf "--with-cc" $ argStagedBuilderPath Gcc ]
bootPackageDbArgs :: Args
bootPackageDbArgs = do
......@@ -128,16 +127,21 @@ ghcIncludeDirs = [ "includes", "includes/dist"
cppArgs :: Args
cppArgs = append $ map ("-I" ++) ghcIncludeDirs
-- TODO: Is this needed?
-- ifeq "$(GMP_PREFER_FRAMEWORK)" "YES"
-- libraries/integer-gmp_CONFIGURE_OPTS += --with-gmp-framework-preferred
-- endif
-- TODO: move this somewhere
customPackageArgs :: Args
customPackageArgs = do
stage <- getStage
rtsWays <- getRtsWays
nextStage <- fmap succ getStage
rtsWays <- getRtsWays
mconcat
[ package integerGmp2 ?
[ package integerGmp ?
mconcat [ windowsHost ? builder GhcCabal ?
arg "--configure-option=--with-intree-gmp"
, appendCcArgs ["-I" ++ pkgPath integerGmp2 -/- "gmp"] ]
, appendCcArgs ["-I" ++ pkgPath integerGmp -/- "gmp"] ]
, package base ?
builder GhcCabal ?
......@@ -148,8 +152,8 @@ customPackageArgs = do
, package compiler ?
builder GhcCabal ?
mconcat [ arg $ "--ghc-option=-DSTAGE=" ++ show (succ stage)
, arg $ "--flags=stage" ++ show (succ stage)
mconcat [ arg $ "--ghc-option=-DSTAGE=" ++ show nextStage
, arg $ "--flags=stage" ++ show nextStage
, arg "--disable-library-for-ghci"
, targetOs "openbsd" ? arg "--ld-options=-E"
, flag GhcUnregisterised ? arg "--ghc-option=-DNO_REGS"
......@@ -173,7 +177,7 @@ customPackageArgs = do
]
withBuilderKey :: Builder -> String
withBuilderKey builder = case builder of
withBuilderKey b = case b of
Ar -> "--with-ar="
Ld -> "--with-ld="
Gcc _ -> "--with-gcc="
......@@ -186,12 +190,10 @@ withBuilderKey builder = case builder of
-- Expression 'with Gcc' appends "--with-gcc=/path/to/gcc" and needs Gcc.
with :: Builder -> Args
with builder = specified builder ? do
path <- lift $ builderPath builder
lift $ needBuilder builder
append [withBuilderKey builder ++ path]
with b = specified b ? do
path <- lift $ builderPath b
lift $ needBuilder laxDependencies b
append [withBuilderKey b ++ path]
withStaged :: (Stage -> Builder) -> Args
withStaged sb = do
stage <- getStage
with $ sb stage
withStaged sb = (with . sb) =<< getStage
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