Commit 20037b1e authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Initialise bootstrapping.conf (fix #42).

parent f80dd4cc
......@@ -19,15 +19,16 @@ module Base (
-- * Paths
shakeFilesPath, configPath, sourcePath, programInplacePath,
bootPackageConstraints, packageDependencies,
bootstrappingConf, bootstrappingConfInitialised,
-- * Output
putColoured, putOracle, putBuild, putSuccess, putError, renderBox,
module System.Console.ANSI,
-- * Miscellaneous utilities
bimap, minusOrd, intersectOrd, removeFileIfExists, replaceEq, quote,
chunksOfSize, replaceSeparators, decodeModule, encodeModule, unifyPath,
(-/-), versionToInt
bimap, minusOrd, intersectOrd, replaceEq, quote, chunksOfSize,
replaceSeparators, decodeModule, encodeModule, unifyPath, (-/-),
versionToInt, removeFileIfExists, removeDirectoryIfExists
) where
import Control.Applicative
......@@ -71,6 +72,12 @@ bootPackageConstraints = shakeFilesPath -/- "boot-package-constraints"
packageDependencies :: FilePath
packageDependencies = shakeFilesPath -/- "package-dependencies"
bootstrappingConf :: FilePath
bootstrappingConf = "libraries/bootstrapping.conf"
bootstrappingConfInitialised :: FilePath
bootstrappingConfInitialised = shakeFilesPath -/- "bootstrapping-conf-initialised"
-- Utility functions
-- | Find and replace all occurrences of a value in a list
replaceEq :: Eq a => a -> a -> [a] -> [a]
......@@ -194,6 +201,11 @@ intersectOrd cmp = loop
EQ -> x : loop xs ys
GT -> loop (x:xs) ys
-- Convenient helper function for removing a file that doesn't necessarily exist
-- | Remove a file that doesn't necessarily exist
removeFileIfExists :: FilePath -> Action ()
removeFileIfExists f = liftIO . whenM (IO.doesFileExist f) $ IO.removeFile f
-- | Remove a directory that doesn't necessarily exist
removeDirectoryIfExists :: FilePath -> Action ()
removeDirectoryIfExists d =
liftIO . whenM (IO.doesDirectoryExist d) $ IO.removeDirectoryRecursive d
......@@ -7,6 +7,7 @@ import Distribution.PackageDescription.Parse
import Distribution.Verbosity
import Expression
import GHC
import Rules.Actions
import Settings
cabalRules :: Rules ()
......@@ -37,6 +38,18 @@ cabalRules = do
return . unwords $ pkgNameString pkg : sort depNames
writeFileChanged out . unlines $ pkgDeps
-- When the file exists, the bootstrappingConf has been initialised
-- TODO: get rid of an extra file?
bootstrappingConfInitialised %> \out -> do
removeDirectoryIfExists bootstrappingConf
-- TODO: can we get rid of this fake target?
let target = PartialTarget Stage0 cabal
build $ fullTarget target (GhcPkg Stage0) [] [bootstrappingConf]
let message = "Successfully initialised " ++ bootstrappingConf
writeFileChanged out message
putSuccess message
collectDeps :: Maybe (CondTree v [Dependency] a) -> [Dependency]
collectDeps Nothing = []
collectDeps (Just (CondNode _ deps ifs)) = deps ++ concatMap f ifs
......
......@@ -35,8 +35,8 @@ buildPackageData rs target @ (PartialTarget stage pkg) = do
-- library components only
when (isLibrary pkg) .
whenM (interpretPartial target registerPackage) .
buildWithResources [(resGhcPkg rs, 1)] $
fullTarget target (GhcPkg stage) [cabalFile] [mk]
buildWithResources [(resGhcPkg rs, 1)] $
fullTarget target (GhcPkg stage) [cabalFile] [mk]
postProcessPackageData dataFile
......@@ -58,7 +58,7 @@ buildPackageData rs target @ (PartialTarget stage pkg) = do
, "DEP_EXTRA_LIBS = m"
, "CC_OPTS = " ++ unwords (map ("-I"++) ghcIncludeDirs) ]
writeFileChanged mk contents
putBuild $ "| Successfully generated '" ++ mk ++ "'."
putSuccess $ "| Successfully generated '" ++ mk ++ "'."
-- Bootstrapping `ghcCabal`: although `ghcCabal` is a proper cabal
-- package, we cannot generate the corresponding `package-data.mk` file
......@@ -70,7 +70,7 @@ buildPackageData rs target @ (PartialTarget stage pkg) = do
, "utils_ghc-cabal_stage0_SYNOPSIS = Bootstrapped ghc-cabal utility."
, "utils_ghc-cabal_stage0_HS_SRC_DIRS = ." ]
writeFileChanged mk contents
putBuild $ "| Successfully generated '" ++ mk ++ "'."
putSuccess $ "| Successfully generated '" ++ mk ++ "'."
-- Prepare a given 'packaga-data.mk' file for parsing by readConfigFile:
-- 1) Drop lines containing '$'
......
......@@ -31,7 +31,7 @@ generate :: FilePath -> PartialTarget -> Expr String -> Action ()
generate file target expr = do
contents <- interpretPartial target expr
writeFileChanged file contents
putBuild $ "| Successfully generated '" ++ file ++ "'."
putSuccess $ "| Successfully generated '" ++ file ++ "'."
generatePackageCode :: Resources -> PartialTarget -> Rules ()
......@@ -82,17 +82,18 @@ generatePackageCode _ target @ (PartialTarget stage pkg) =
when (pkg == runghc) $ buildPath -/- "Main.hs" %> \file -> do
copyFileChanged (pkgPath pkg -/- "runghc.hs") file
putBuild $ "| Successfully generated '" ++ file ++ "'."
putSuccess $ "| Successfully generated '" ++ file ++ "'."
generateRules :: Rules ()
generateRules = do
"includes/ghcautoconf.h" <~ generateGhcAutoconfH
"includes/ghcplatform.h" <~ generateGhcPlatformH
where
file <~ gen = file %> \out -> generate out fakeTarget gen
file <~ gen = file %> \out -> generate out emptyTarget gen
-- TODO: Use the Types, Luke! (drop partial function)
fakeTarget :: PartialTarget
fakeTarget = PartialTarget (error "fakeTarget: unknown stage")
(error "fakeTarget: unknown package")
-- We sometimes need to evaluate expressions that do not require knowing all
-- information about the target. In this case, we don't want to know anything.
emptyTarget :: PartialTarget
emptyTarget = PartialTarget (error "Rules.Generate.emptyTarget: unknown stage")
(error "Rules.Generate.emptyTarget: unknown package")
......@@ -5,6 +5,7 @@ import Oracles
import GHC
import Predicates hiding (way, stage)
import Settings
import Settings.Builders.GhcCabal (bootPackageDbArgs)
-- TODO: add support for -dyno
-- $1/$2/build/%.$$($3_o-bootsuf) : $1/$4/%.hs-boot
......@@ -98,7 +99,7 @@ packageGhcArgs = do
[ not (pkg == hp2ps || pkg == ghcCabal && stage == Stage0) ?
arg "-hide-all-packages"
, arg "-no-user-package-db"
, stage0 ? arg "-package-db libraries/bootstrapping.conf"
, bootPackageDbArgs
, isLibrary pkg ?
if supportsComponentId || stage /= Stage0
then arg $ "-this-package-key " ++ compId
......
......@@ -17,7 +17,7 @@ cabalArgs = builder GhcCabal ? do
, dll0Args
, withStaged Ghc
, withStaged GhcPkg
, stage0 ? bootPackageDbArgs
, bootPackageDbArgs
, libraryArgs
, with HsColour
, configureArgs
......@@ -77,9 +77,12 @@ configureArgs = do
, conf "--with-cc" $ argStagedBuilderPath Gcc ]
bootPackageDbArgs :: Args
bootPackageDbArgs = do
bootPackageDbArgs = stage0 ? do
path <- getSetting GhcSourcePath
arg $ "--package-db=" ++ path -/- "libraries/bootstrapping.conf"
lift $ need [bootstrappingConfInitialised]
isGhc <- (||) <$> stagedBuilder Ghc <*> stagedBuilder GhcM
let prefix = if isGhc then "-package-db " else "--package-db="
arg $ prefix ++ path -/- bootstrappingConf
packageConstraints :: Args
packageConstraints = stage0 ? do
......
......@@ -6,9 +6,17 @@ import Settings
import Settings.Builders.GhcCabal
ghcPkgArgs :: Args
ghcPkgArgs = stagedBuilder GhcPkg ? do
ghcPkgArgs = stagedBuilder GhcPkg ? (initArgs <> updateArgs)
initArgs :: Args
initArgs = file bootstrappingConf ? do
mconcat [ arg "init"
, arg =<< getOutput ]
updateArgs :: Args
updateArgs = notM (file bootstrappingConf) ? do
path <- getTargetPath
mconcat [ arg "update"
, arg "--force"
, stage0 ? bootPackageDbArgs
, bootPackageDbArgs
, arg $ path -/- "inplace-pkg-config" ]
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