Add unique package identifiers (InstalledPackageId) in the package DB

[ghc-hetmet.git] / utils / ghc-cabal / ghc-cabal.hs

diff --git a/utils/ghc-cabal/ghc-cabal.hs b/utils/ghc-cabal/ghc-cabal.hs
index 7d2f522..8ee1304 100644 (file)
--- a/utils/ghc-cabal/ghc-cabal.hs
+++ b/utils/ghc-cabal/ghc-cabal.hs
@@ -3,6 +3,7 @@ module Main (main) where
 
 import qualified Distribution.ModuleName as ModuleName
 import Distribution.PackageDescription
+import Distribution.PackageDescription.Check hiding (doesFileExist)
 import Distribution.PackageDescription.Configuration
 import Distribution.PackageDescription.Parse
 import Distribution.Simple
@@ -12,25 +13,27 @@ import Distribution.Simple.Program
 import Distribution.Simple.Utils (defaultPackageDesc, writeFileAtomic)
 import Distribution.Simple.Build (writeAutogenFiles)
 import Distribution.Simple.Register
-import Distribution.Simple.PackageIndex
 import Distribution.Text
 import Distribution.Verbosity
 import qualified Distribution.InstalledPackageInfo as Installed
 import qualified Distribution.Simple.PackageIndex as PackageIndex
 
-import Control.Monad
+import Data.List
 import Data.Maybe
 import System.IO
 import System.Directory
 import System.Environment
 import System.Exit
 import System.FilePath
+import Data.Char
 
 main :: IO ()
 main = do args <- getArgs
           case args of
               "haddock" : distDir : dir : args' ->
                   runHaddock distDir dir args'
+              "check" : dir : [] ->
+                  doCheck dir
               "install" : ghcpkg : ghcpkgconfig : directory : distDir
                         : myDestDir : myPrefix : myLibdir : myDocdir : args' ->
                   doInstall ghcpkg ghcpkgconfig directory distDir
@@ -66,6 +69,20 @@ withCurrentDirectory directory io
 userHooks :: UserHooks
 userHooks = autoconfUserHooks
 
+doCheck :: FilePath -> IO ()
+doCheck directory
+ = withCurrentDirectory directory
+ $ do let verbosity = normal
+      gpdFile <- defaultPackageDesc verbosity
+      gpd <- readPackageDescription verbosity gpdFile
+      case partition isFailure $ checkPackage gpd Nothing of
+          ([],   [])       -> return ()
+          ([],   warnings) -> mapM_ print warnings
+          (errs, _)        -> do mapM_ print errs
+                                 exitWith (ExitFailure 1)
+    where isFailure (PackageDistSuspicious {}) = False
+          isFailure _ = True
+
 runHaddock :: FilePath -> FilePath -> [String] -> IO ()
 runHaddock distdir directory args
  = withCurrentDirectory directory
@@ -126,7 +143,7 @@ doInstall ghcpkg ghcpkgconf directory distDir myDestDir myPrefix myLibdir myDocd
                     idts' = idts { prefix    = toPathTemplate myPrefix,
                                    libdir    = toPathTemplate myLibdir,
                                    libsubdir = toPathTemplate "$pkgid",
-                                   docdir    = toPathTemplate (myDocdir </> "$pkgid"),
+                                   docdir    = toPathTemplate (myDocdir </> "$pkg"),
                                    htmldir   = toPathTemplate "$docdir" }
                     progs = withPrograms lbi
                     prog = ConfiguredProgram {
@@ -192,9 +209,11 @@ 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?"
 
@@ -226,16 +245,19 @@ generate config_args distdir directory
           -- 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),