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
runHaddock distDir dir args'
"check" : dir : [] ->
doCheck dir
- "install" : ghcpkg : ghcpkgconfig : directory : distDir
+ "install" : ghc : ghcpkg : topdir : directory : distDir
: myDestDir : myPrefix : myLibdir : myDocdir : args' ->
- doInstall ghcpkg ghcpkgconfig directory distDir
+ doInstall ghc ghcpkg topdir directory distDir
myDestDir myPrefix myLibdir myDocdir args'
"configure" : args' -> case break (== "--") args' of
(config_args, "--" : distdir : directories) ->
= f pd lbi us flags
doInstall :: FilePath -> FilePath -> FilePath -> FilePath -> FilePath
- -> FilePath -> FilePath -> FilePath -> [String] -> IO ()
-doInstall ghcpkg ghcpkgconf directory distDir myDestDir myPrefix myLibdir myDocdir args
+ -> FilePath -> FilePath -> FilePath -> FilePath -> [String]
+ -> IO ()
+doInstall ghc ghcpkg topdir directory distDir myDestDir myPrefix myLibdir myDocdir args
= withCurrentDirectory directory $ do
defaultMainWithHooksArgs hooks (["copy", "--builddir", distDir]
++ (if null myDestDir then []
| 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
- prog = ConfiguredProgram {
- programId = programName ghcPkgProgram,
- programVersion = Nothing,
- programArgs = ["--global-conf", ghcpkgconf]
- ++ if not (null myDestDir)
- then ["--force"]
- else [],
- programLocation = UserSpecified ghcpkg
+ = 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" }
+ 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'
}
- progs' = updateProgram prog progs
- lbi' = lbi {
- installDirTemplates = idts',
- withPrograms = progs'
- }
- in f pd lbi' us flags
+ 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
(Nothing, Nothing) -> return ()
(Just lib, Just clbi) -> do
cwd <- getCurrentDirectory
+ let ipid = InstalledPackageId (display (packageId pd) ++ "-inplace")
let installedPkgInfo = inplaceInstalledPackageInfo cwd distdir
pd lib lbi clbi
- content = Installed.showInstalledPackageInfo installedPkgInfo ++ "\n"
+ final_ipi = installedPkgInfo{ Installed.installedPackageId = ipid }
+ content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
writeFileAtomic (distdir </> "inplace-pkg-config") content
_ -> error "Inconsistent lib components; can't happen?"
-- stricter than gnu ld). Thus we remove the ldOptions for
-- GHC's rts package:
hackRtsPackage index =
- case PackageIndex.lookupPackageName index (PackageName "rts") of
- [rts] -> PackageIndex.insert rts { Installed.ldOptions = [] } index
+ case PackageIndex.lookupInstalledPackageByName index (PackageName "rts") of
+ [rts] -> PackageIndex.addToInstalledPackageIndex rts { Installed.ldOptions = [] } index
_ -> error "No (or multiple) ghc rts package is registered!!"
+ dep_ids = map (packageId.getLocalPackageInfo lbi) $
+ externalPackageDeps lbi
+
let variablePrefix = directory ++ '_':distdir
let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)),
variablePrefix ++ "_MODULES = " ++ unwords (map display modules),
variablePrefix ++ "_HS_SRC_DIRS = " ++ unwords (hsSourceDirs bi),
- variablePrefix ++ "_DEPS = " ++ unwords (map display (externalPackageDeps lbi)),
- variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) (externalPackageDeps lbi)),
+ variablePrefix ++ "_DEPS = " ++ unwords (map display dep_ids),
+ variablePrefix ++ "_DEP_NAMES = " ++ unwords (map (display . packageName) dep_ids),
variablePrefix ++ "_INCLUDE_DIRS = " ++ unwords (includeDirs bi),
variablePrefix ++ "_INCLUDES = " ++ unwords (includes bi),
variablePrefix ++ "_INSTALL_INCLUDES = " ++ unwords (installIncludes bi),
projects / ghc-hetmet.git / blobdiff