"check" : dir : [] ->
doCheck dir
"install" : ghc : ghcpkg : topdir : directory : distDir
- : myDestDir : myPrefix : myLibdir : myDocdir : args' ->
+ : myDestDir : myPrefix : myLibdir : myDocdir
+ : relocatableBuild : args' ->
doInstall ghc ghcpkg topdir directory distDir
- myDestDir myPrefix myLibdir myDocdir args'
+ myDestDir myPrefix myLibdir myDocdir
+ relocatableBuild args'
"configure" : args' -> case break (== "--") args' of
(config_args, "--" : distdir : directories) ->
mapM_ (generate config_args distdir) directories
" ghc-cabal install <ghc-pkg> <directory> <distdir> <destdir> <prefix> <args>...",
" ghc-cabal haddock <distdir> <directory> <args>..."]
-die :: [String] -> IO ()
+die :: [String] -> IO a
die errs = do mapM_ (hPutStrLn stderr) errs
exitWith (ExitFailure 1)
= f pd lbi us flags
doInstall :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath
- -> FilePath -> FilePath -> FilePath -> FilePath -> [String]
+ -> FilePath -> FilePath -> FilePath -> FilePath -> String
+ -> [String]
-> IO ()
-doInstall ghc ghcpkg topdir directory distDir myDestDir myPrefix myLibdir myDocdir args
+doInstall ghc ghcpkg topdir directory distDir
+ myDestDir myPrefix myLibdir myDocdir
+ relocatableBuildStr args
= withCurrentDirectory directory $ do
- defaultMainWithHooksArgs hooks (["copy", "--builddir", distDir]
- ++ (if null myDestDir then []
- else ["--destdir", myDestDir])
- ++ args)
- defaultMainWithHooksArgs hooks ("register" : "--builddir" : distDir : args)
- where
- hooks = userHooks {
- copyHook = noGhcPrimHook (modHook (copyHook userHooks)),
- regHook = modHook (regHook userHooks)
- }
+ relocatableBuild <- case relocatableBuildStr of
+ "YES" -> return True
+ "NO" -> return False
+ _ -> die ["Bad relocatableBuildStr: " ++
+ show relocatableBuildStr]
+ let copyArgs = ["copy", "--builddir", distDir]
+ ++ (if null myDestDir
+ then []
+ else ["--destdir", myDestDir])
+ ++ args
+ regArgs = "register" : "--builddir" : distDir : args
+ copyHooks = userHooks {
+ copyHook = noGhcPrimHook
+ $ modHook False
+ $ copyHook userHooks
+ }
+ regHooks = userHooks {
+ regHook = modHook relocatableBuild
+ $ regHook userHooks
+ }
+ defaultMainWithHooksArgs copyHooks copyArgs
+ defaultMainWithHooksArgs regHooks regArgs
+ where
noGhcPrimHook f pd lbi us flags
= let pd'
| packageName pd == PackageName "ghc-prim" =
error "Expected a library, but none found"
| otherwise = pd
in f pd' lbi us flags
- modHook f pd lbi us flags
+ modHook relocatableBuild f pd lbi us flags
= do let verbosity = normal
idts = installDirTemplates lbi
- idts' = idts { prefix = toPathTemplate myPrefix,
- libdir = toPathTemplate myLibdir,
- libsubdir = toPathTemplate "$pkgid",
- docdir = toPathTemplate (myDocdir </> "$pkg"),
- htmldir = toPathTemplate "$docdir" }
+ idts' = idts {
+ prefix = toPathTemplate $
+ if relocatableBuild
+ then "$topdir"
+ else myPrefix,
+ libdir = toPathTemplate $
+ if relocatableBuild
+ then "$topdir"
+ else myLibdir,
+ libsubdir = toPathTemplate "$pkgid",
+ docdir = toPathTemplate $
+ if relocatableBuild
+ then "$topdir/$pkg"
+ else (myDocdir </> "$pkg"),
+ htmldir = toPathTemplate "$docdir"
+ }
progs = withPrograms lbi
ghcProg = ConfiguredProgram {
programId = programName ghcProgram,
progs' = updateProgram ghcProg
$ updateProgram ghcPkgProg progs
instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
- let installedPkgs' = PackageIndex.listToInstalledPackageIndex
- instInfos
+ let installedPkgs' = PackageIndex.fromList instInfos
let mlc = libraryConfig lbi
mlc' = case mlc of
Just lc ->
- let cipds = componentInstalledPackageDeps lc
- cipds' = map (fixupPackageId instInfos) cipds
+ let cipds = componentPackageDeps lc
+ cipds' = [ (fixupPackageId instInfos ipid, pid)
+ | (ipid,pid) <- cipds ]
in Just $ lc {
- componentInstalledPackageDeps = cipds'
+ componentPackageDeps = cipds'
}
Nothing -> Nothing
lbi' = lbi {
-- stricter than gnu ld). Thus we remove the ldOptions for
-- GHC's rts package:
hackRtsPackage index =
- case PackageIndex.lookupInstalledPackageByName index (PackageName "rts") of
- [rts] -> PackageIndex.addToInstalledPackageIndex rts { Installed.ldOptions = [] } index
+ case PackageIndex.lookupPackageName index (PackageName "rts") of
+ [(_,[rts])] -> PackageIndex.insert rts{ Installed.ldOptions = [] } index
_ -> error "No (or multiple) ghc rts package is registered!!"
- dep_ids = map (packageId.getLocalPackageInfo lbi) $
- externalPackageDeps lbi
+ dep_ids = map snd (externalPackageDeps lbi)
let variablePrefix = directory ++ '_':distdir
let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),