X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-cabal%2Fghc-cabal.hs;h=3d9cf13dcb9fbc16311908230c352de873fa9a34;hb=930421d4ed09e5389e0ef4c5eef36075a6809cc0;hp=8ee1304fb8086ef079a5d23251fd2b55e7ca2746;hpb=72547264724117d689a7fa400104185557fb2a0c;p=ghc-hetmet.git

diff --git a/utils/ghc-cabal/ghc-cabal.hs b/utils/ghc-cabal/ghc-cabal.hs
index 8ee1304..3d9cf13 100644
--- a/utils/ghc-cabal/ghc-cabal.hs
+++ b/utils/ghc-cabal/ghc-cabal.hs
@@ -10,6 +10,7 @@ import Distribution.Simple
 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
@@ -34,9 +35,9 @@ 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) ->
@@ -111,8 +112,9 @@ runHaddock distdir directory args
           = 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 []
@@ -139,28 +141,76 @@ doInstall ghcpkg ghcpkgconf directory distDir myDestDir myPrefix myLibdir myDocd
                      | 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