import Distribution.Simple.Configure
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program
+import Distribution.Simple.Program.HcPkg
import Distribution.Simple.Utils (defaultPackageDesc, writeFileAtomic)
import Distribution.Simple.Build (writeAutogenFiles)
import Distribution.Simple.Register
import System.Environment
import System.Exit
import System.FilePath
-import Data.Char
main :: IO ()
main = do args <- getArgs
"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
_ -> die syntax_error
+ "sdist" : dir : distDir : [] ->
+ doSdist dir distDir
_ -> die syntax_error
syntax_error :: [String]
" 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)
userHooks :: UserHooks
userHooks = autoconfUserHooks
+runDefaultMain :: IO ()
+runDefaultMain
+ = do let verbosity = normal
+ gpdFile <- defaultPackageDesc verbosity
+ gpd <- readPackageDescription verbosity gpdFile
+ case buildType (flattenPackageDescription gpd) of
+ Just Configure -> defaultMainWithHooks autoconfUserHooks
+ -- time has a "Custom" Setup.hs, but it's actually Configure
+ -- plus a "./Setup test" hook. However, Cabal is also
+ -- "Custom", but doesn't have a configure script.
+ Just Custom ->
+ do configureExists <- doesFileExist "configure"
+ if configureExists
+ then defaultMainWithHooks autoconfUserHooks
+ else defaultMain
+ -- not quite right, but good enough for us:
+ _ -> defaultMain
+
+doSdist :: FilePath -> FilePath -> IO ()
+doSdist directory distDir
+ = withCurrentDirectory directory
+ $ withArgs (["sdist", "--builddir", distDir])
+ runDefaultMain
+
doCheck :: FilePath -> IO ()
doCheck directory
= withCurrentDirectory directory
= 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
- = let idts = installDirTemplates lbi
- idts' = idts { prefix = toPathTemplate myPrefix,
- libdir = toPathTemplate myLibdir,
- libsubdir = toPathTemplate "$pkgid",
- docdir = toPathTemplate (myDocdir </> "$pkg"),
- htmldir = toPathTemplate "$docdir" }
- progs = withPrograms lbi
- ghcProg = ConfiguredProgram {
- programId = programName ghcProgram,
- programVersion = Nothing,
- programArgs = ["-B" ++ topdir],
- programLocation = UserSpecified ghc
- }
- ghcpkgconf = topdir </> "package.conf"
- ghcPkgProg = ConfiguredProgram {
- programId = programName ghcPkgProgram,
- programVersion = Nothing,
- programArgs = ["--global-conf",
- ghcpkgconf]
- ++ if not (null myDestDir)
- then ["--force"]
- else [],
- programLocation = UserSpecified ghcpkg
- }
- progs' = updateProgram ghcProg
- $ updateProgram ghcPkgProg progs
- lbi' = lbi {
- installDirTemplates = idts',
- withPrograms = progs'
- }
- in f pd lbi' us flags
+ modHook relocatableBuild f pd lbi us flags
+ = do let verbosity = normal
+ idts = installDirTemplates lbi
+ 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,
+ programVersion = Nothing,
+ programArgs = ["-B" ++ topdir],
+ programLocation = UserSpecified ghc
+ }
+ ghcpkgconf = topdir </> "package.conf.d"
+ ghcPkgProg = ConfiguredProgram {
+ programId = programName ghcPkgProgram,
+ programVersion = Nothing,
+ programArgs = ["--global-conf",
+ ghcpkgconf]
+ ++ if not (null myDestDir)
+ then ["--force"]
+ else [],
+ programLocation = UserSpecified ghcpkg
+ }
+ progs' = updateProgram ghcProg
+ $ updateProgram ghcPkgProg progs
+ instInfos <- dump verbosity ghcPkgProg GlobalPackageDB
+ let installedPkgs' = PackageIndex.listToInstalledPackageIndex
+ instInfos
+ let mlc = libraryConfig lbi
+ mlc' = case mlc of
+ Just lc ->
+ let cipds = componentInstalledPackageDeps lc
+ cipds' = map (fixupPackageId instInfos) cipds
+ in Just $ lc {
+ componentInstalledPackageDeps = cipds'
+ }
+ Nothing -> Nothing
+ lbi' = lbi {
+ libraryConfig = mlc',
+ installedPkgs = installedPkgs',
+ installDirTemplates = idts',
+ withPrograms = progs'
+ }
+ f pd lbi' us flags
+
+-- The packages are built with the package ID ending in "-inplace", but
+-- when they're installed they get the package hash appended. We need to
+-- fix up the package deps so that they use the hash package IDs, not
+-- the inplace package IDs.
+fixupPackageId :: [Installed.InstalledPackageInfo]
+ -> InstalledPackageId
+ -> InstalledPackageId
+fixupPackageId _ x@(InstalledPackageId ipi)
+ | "builtin_" `isPrefixOf` ipi = x
+fixupPackageId ipinfos (InstalledPackageId ipi)
+ = case stripPrefix (reverse "-inplace") $ reverse ipi of
+ Nothing ->
+ error ("Installed package ID doesn't end in -inplace: " ++ show ipi)
+ Just x ->
+ let ipi' = reverse ('-' : x)
+ f (ipinfo : ipinfos') = case Installed.installedPackageId ipinfo of
+ y@(InstalledPackageId ipinfoid)
+ | ipi' `isPrefixOf` ipinfoid ->
+ y
+ _ ->
+ f ipinfos'
+ f [] = error ("Installed package ID not registered: " ++ show ipi)
+ in f ipinfos
generate :: [String] -> FilePath -> FilePath -> IO ()
generate config_args distdir directory
= withCurrentDirectory directory
$ do let verbosity = normal
- gpdFile <- defaultPackageDesc verbosity
- gpd <- readPackageDescription verbosity gpdFile
-
-- XXX We shouldn't just configure with the default flags
-- XXX And this, and thus the "getPersistBuildConfig distdir" below,
-- aren't going to work when the deps aren't built yet
withArgs (["configure", "--distdir", distdir] ++ config_args)
- (case buildType (flattenPackageDescription gpd) of
- Just Configure -> defaultMainWithHooks autoconfUserHooks
- -- time has a "Custom" Setup.hs, but it's actually Configure
- -- plus a "./Setup test" hook. However, Cabal is also
- -- "Custom", but doesn't have a configure script.
- Just Custom ->
- do configureExists <- doesFileExist "configure"
- if configureExists
- then defaultMainWithHooks autoconfUserHooks
- else defaultMain
- -- not quite right, but good enough for us:
- _ -> defaultMain)
+ runDefaultMain
lbi <- getPersistBuildConfig distdir
let pd0 = localPkgDescr lbi
projects / ghc-hetmet.git / blobdiff